From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Mon, 29 Oct 2012 14:49:37 +0000 (+0000)
Subject: Work on defining a typed second-level representation.
X-Git-Url: https://git.unchartedbackwaters.co.uk/w/?a=commitdiff_plain;h=5ee7368cd6b584306cea61e11f93105512014e35;p=francis%2Fofc.git

Work on defining a typed second-level representation.
---

diff --git a/OFC/Common.hs b/OFC/Common.hs
index e234719..aeb8e65 100644
--- a/OFC/Common.hs
+++ b/OFC/Common.hs
@@ -3,7 +3,10 @@ module OFC.Common
   , PrettyPrintable(..)
   ) where
 
-import Text.PrettyPrint (Doc, renderStyle, Style(..), Mode(..))
+import Text.PrettyPrint 
+  (Doc, renderStyle, Style(..), Mode(..), hcat, text, double, float
+  , integer, int, parens)
+import Data.Complex (Complex(..), realPart, imagPart)
 
 data IndexType = 
   FunctionIndex | 
@@ -15,3 +18,22 @@ class PrettyPrintable a where
   toDoc :: a -> Doc
   prettyPrint :: a -> String
   prettyPrint = renderStyle Style {mode = PageMode, lineLength=72, ribbonsPerLine=1.5 } . toDoc
+
+instance PrettyPrintable Double where 
+  toDoc = double
+
+instance PrettyPrintable Float where
+  toDoc = float
+
+instance PrettyPrintable Integer where 
+  toDoc = integer
+
+instance PrettyPrintable Int where 
+  toDoc = int
+
+instance (PrettyPrintable n, RealFloat n) => PrettyPrintable (Complex n) where 
+  toDoc c
+    | imagPart c == (fromInteger 0) = toDoc $ realPart c
+    | realPart c == (fromInteger 0) = hcat [toDoc $ imagPart c, text "i"]
+    | otherwise = parens $ hcat [toDoc $ realPart c, text "+", toDoc $ imagPart c, text "i"]
+
diff --git a/OFC/SecondLevel.hs b/OFC/SecondLevel.hs
index 9c16fb9..79ca072 100644
--- a/OFC/SecondLevel.hs
+++ b/OFC/SecondLevel.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs, EmptyDataDecls, StandaloneDeriving #-}
+
 module OFC.SecondLevel 
   ( SymbolTable
   , Quantification(..)
@@ -37,65 +39,152 @@ data ValueType =
   IntegerType |
   Psinc Integer |
   PsincReciprocal Integer |
-  RealFunction |
-  ComplexFunction
+  PositionFunction |
+  MomentumFunction
   deriving Show
 
-data Expression =
-  IndexedIdentifier String [String] |
-  ToMomentum Expression |
-  ToPosition Expression |
-  Upsample Expression |
-  Downsample Expression |
-  Integrate Expression |
-  ConstReal Double |
-  ConstInteger Integer |
-  ConstComplex (Complex Double) |
-  LatticeComponent String |
-  Negate Expression |
-  Sum Expression String |
-  Add Expression Expression |
-  Sub Expression Expression |
-  Mul Expression Expression |
-  Div Expression Expression |
-  Pow Expression Expression
+data PsincE
+data PsincReciprocalE
+data ScalarE
+
+deriving instance Show PsincE
+deriving instance Show PsincReciprocalE
+deriving instance Show ScalarE
+
+data OperatorExpr num terminal =
+  OpAdd (OperatorExpr num terminal) (OperatorExpr num terminal) |
+  OpSub (OperatorExpr num terminal) (OperatorExpr num terminal) |
+  OpMul (OperatorExpr num terminal) (OperatorExpr num terminal) |
+  OpDiv (OperatorExpr num terminal) (OperatorExpr num terminal) |
+  OpPow (OperatorExpr num terminal) (OperatorExpr num terminal) |
+  OpNeg (OperatorExpr num terminal) |
+  OpConstant num |
+  OpTerminal terminal
   deriving Show
 
-instance PrettyPrintable Expression where
+instance (PrettyPrintable num, PrettyPrintable terminal) => PrettyPrintable (OperatorExpr num terminal) where
+  toDoc e = case e of 
+    OpAdd a b -> binaryToDoc "+" a b
+    OpSub a b -> binaryToDoc "-" a b
+    OpMul a b -> binaryToDoc "*" a b
+    OpDiv a b -> binaryToDoc "/" a b
+    OpPow a b -> binaryToDoc "^" a b
+    OpNeg o -> hcat [text "(-", toDoc o, text ")"]
+    OpConstant c -> toDoc c
+    OpTerminal t -> toDoc t
+    where
+    binaryToDoc op lhs rhs = parens $ hcat [toDoc lhs, text op, toDoc rhs]
+
+data PositionTerminal =
+  PositionComponent String
+  deriving Show
+
+instance PrettyPrintable PositionTerminal where
+  toDoc (PositionComponent index) = text $ "r[" ++ index ++ "]"
+
+data MomentumTerminal =
+  MomentumComponent String
+  deriving Show
+
+instance PrettyPrintable MomentumTerminal where
+  toDoc (MomentumComponent index) = text $ "p[" ++ index ++ "]"
+
+data Expression e where
+  IndexedPsincIdentifier :: String -> [String] -> Expression PsincE
+  IndexedScalarIdentifier :: String -> [String] -> Expression ScalarE
+  ToMomentum :: Expression PsincE -> Expression PsincReciprocalE
+  ToPosition :: Expression PsincReciprocalE -> Expression PsincE
+  Upsample :: Expression PsincE -> Expression PsincE
+  Downsample :: Expression PsincE -> Expression PsincE
+  Integrate :: Expression PsincE -> Expression ScalarE
+  AnalyticMomentum :: OperatorExpr (Complex Double) MomentumTerminal -> Expression PsincReciprocalE
+  AnalyticPosition :: OperatorExpr Double PositionTerminal -> Expression PsincE
+  Sum :: Expression e -> String -> Expression e
+  Add :: Expression e -> Expression e -> Expression e
+  Sub :: Expression e -> Expression e -> Expression e
+  Neg :: Expression e -> Expression e
+  MulScalar :: Expression e -> Expression ScalarE -> Expression e
+  DivScalar :: Expression e -> Expression ScalarE -> Expression e
+  PsincProduct :: Expression PsincE -> Expression PsincE -> Expression PsincE
+  PsincReciprocalProduct :: Expression PsincReciprocalE -> Expression PsincReciprocalE -> Expression PsincReciprocalE
+  ConstInteger :: Integer -> Expression ScalarE
+  ConstReal :: Double -> Expression ScalarE
+  ConstComplex :: (Complex Double) -> Expression ScalarE
+
+deriving instance Show (Expression e)
+
+instance PrettyPrintable (Expression e) where
   toDoc expression = case expression of
-    IndexedIdentifier name indices -> text name <> case indices of
-      [] -> empty
-      nonNil -> brackets $ hcat $ punctuate comma (map text nonNil)
+    IndexedPsincIdentifier  name indices -> identifierToDoc name indices
+    IndexedScalarIdentifier name indices -> identifierToDoc name indices
     ToMomentum e -> functionToDoc "to_momentum" [toDoc e]
     ToPosition e -> functionToDoc "to_position" [toDoc e]
     Upsample e -> functionToDoc "upsample" [toDoc e]
     Downsample e -> functionToDoc "downsample" [toDoc e]
     Integrate e -> functionToDoc "integrate" [toDoc e]
-    ConstReal r -> double r
-    ConstInteger i -> integer i
-    ConstComplex c -> parens $ text $ showComplex c
-    LatticeComponent i -> text $ "lattice[" ++ i ++ "]"
-    Negate e -> hcat [text "(", toDoc e, text ")"]
+    ConstReal r -> toDoc r
+    ConstInteger i -> toDoc i
+    ConstComplex c -> toDoc c
+    Neg e -> hcat [text "(-", toDoc e, text ")"]
     Sum e i -> functionToDoc "sum" [toDoc e, text i]
     Add a b -> binaryToDoc "+" a b
     Sub a b -> binaryToDoc "-" a b
-    Mul a b -> binaryToDoc "*" a b
-    Div a b -> binaryToDoc "/" a b
-    Pow a b -> binaryToDoc "^" a b
+    AnalyticPosition e -> text "position_operator" <> (parens $ toDoc e)
+    AnalyticMomentum e -> text "momentum_operator" <> (parens $ toDoc e)
+    MulScalar a b -> binaryToDoc "*" a b
+    DivScalar a b -> binaryToDoc "/" a b
+    PsincProduct a b -> binaryToDoc "*" a b
+    PsincReciprocalProduct a b -> binaryToDoc "*" a b
     where
+    identifierToDoc name indices = text name <> case indices of
+      [] -> empty
+      nonNil -> brackets $ hcat $ punctuate comma (map text nonNil)
     binaryToDoc op lhs rhs = parens $ hcat [toDoc lhs, text op, toDoc rhs]
     functionToDoc name params = text name <> (parens $ hcat (intersperse (text ", ") params))
-    showComplex c
-      | imagPart c == 0 = show $ realPart c
-      | realPart c == 0 = (show $ imagPart c) ++ "i"
-      | otherwise = concat [show $ realPart c, "+", show $ imagPart c, "i"]
+
+-- getType :: OFL2 -> Expression -> ValueType
+-- getType ofl2 (IndexedIdentifier name _) = getValueType ofl2 name
+-- getType ofl2 (ToMomentum e) = case getType ofl2 e of
+--   basis@(PsincReciprocal _) -> basis
+--   Psinc i -> PsincReciprocal i
+--   _ -> error "ToMomentum applied to non-Psinc value"
+-- getType ofl2 (ToPosition e) = case getType ofl2 e of
+--   basis@(Psinc _) -> basis
+--   PsincReciprocal i -> Psinc i
+--   _ -> error "ToPosition applied to non-Psinc value"
+-- getType ofl2 (Upsample e) = case getType ofl2 e of 
+--   Psinc i -> Psinc $ i+1
+--   _ -> error "Upsample applied to non-Psinc value"
+-- getType ofl2 (Downsample e) = case getType ofl2 e of 
+--   Psinc i -> Psinc $ i-1
+--   _ -> error "Downsample applied to non-Psinc value"
+-- getType ofl2 (Integrate e) = case getType ofl2 e of
+--   Psinc _ -> RealType
+--   _ -> error "Integrate applied to non-Psinc value"
+-- getType _ (ConstReal _) = RealType
+-- getType _ (ConstInteger _) = IntegerType
+-- getType _ (ConstComplex _) = ComplexType
+-- getType _ (PositionComponent _) = PositionFunction
+-- getType _ (MomentumComponent _) = MomentumFunction
+-- getType ofl2 (Negate e) = getType ofl2 e
+-- getType ofl2 (Sum e _) = getType ofl2 e
+--getType ofl2 e = error "Unimplemented"
+
+getValueType :: OFL2 -> String -> ValueType
+getValueType ofl2 name = case Map.lookup name (symbols ofl2) of
+  Just (ValueTag baseType _) -> baseType
+  _ -> error $ "Could not find type of symbol " ++ name
 
 data Assignment =
- Assign Expression Expression
+ AssignPsinc (Expression PsincE) (Expression PsincE) |
+ AssignScalar (Expression ScalarE) (Expression ScalarE)
  deriving Show 
 
 instance PrettyPrintable Assignment where
-  toDoc (Assign lhs rhs) = hcat [toDoc lhs, text " = ", toDoc rhs]
+  toDoc expr = case expr of
+    AssignPsinc lhs rhs -> genDoc lhs rhs
+    AssignScalar lhs rhs -> genDoc lhs rhs
+    where genDoc lhs rhs = hcat [toDoc lhs, text " = ", toDoc rhs]
 
 data OFL2 = OFL2 {
   symbols :: SymbolTable,
@@ -174,25 +263,38 @@ getTargetValueType (TM.FortranParameter properties) = case TM.findSpace properti
     fortranToValueType (TM.Array t _) = fortranToValueType t
 
 buildAssignment :: OFL -> OFL2 -> TopLevel.Assignment -> Assignment
-buildAssignment ofl ofl2 (TopLevel.Assign lhs rhs) = 
-  Assign (buildExpression' lhs) (buildExpression' rhs) 
-  where
-  buildExpression' = buildExpression ofl ofl2
-
-buildExpression :: OFL -> OFL2 -> TopLevel.Expression -> Expression
-buildExpression _ _ (TopLevel.IndexedIdentifier name indices) = IndexedIdentifier name indices
-buildExpression _ _ (TopLevel.ConstReal r) = ConstReal r
-buildExpression _ _ (TopLevel.ConstInteger i) = ConstInteger i
-buildExpression ofl ofl2 (TopLevel.Negate e) = Negate $ buildExpression ofl ofl2 e
-buildExpression ofl ofl2 (TopLevel.Integrate e) = Integrate $ buildExpression ofl ofl2 e
-buildExpression ofl ofl2 (TopLevel.Sum e index) = Sum (buildExpression ofl ofl2 e) index
-buildExpression ofl ofl2 (TopLevel.Multiply e1 e2) = Mul (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
-buildExpression ofl ofl2 (TopLevel.Divide e1 e2) = Div (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
-buildExpression ofl ofl2 (TopLevel.Add e1 e2) = Add (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
-buildExpression ofl ofl2 (TopLevel.Sub e1 e2) = Sub (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
-buildExpression ofl ofl2 (TopLevel.Power e1 e2) = Pow (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
-buildExpression _ _ (TopLevel.PositionComponent i) = LatticeComponent i
-buildExpression ofl ofl2 (TopLevel.SpatialDerivative e index n) = Mul operator $ ToMomentum (buildExpression ofl ofl2 e)
-  where
-  operator = Pow derivative (ConstInteger n)
-  derivative = Mul (LatticeComponent index) (ConstComplex $ 0.0 :+ (-1.0))
+buildAssignment ofl ofl2 (TopLevel.Assign lhs rhs) = case TopLevel.getType ofl lhs of
+  TopLevel.IntegerType -> buildScalarAssign
+  TopLevel.RealType -> buildScalarAssign
+  TopLevel.FunctionType -> buildFieldAssign
+  where buildScalarAssign = AssignScalar (buildScalarExpression ofl ofl2 lhs) (buildScalarExpression ofl ofl2 rhs)
+        buildFieldAssign = AssignPsinc (buildPsincExpression ofl ofl2 lhs) (buildPsincExpression ofl ofl2 rhs)
+
+buildScalarExpression :: OFL -> OFL2 -> TopLevel.Expression -> Expression ScalarE
+buildScalarExpression _ _ e = error $ "Unimplemented scalar expression: " ++ prettyPrint e
+
+buildPsincExpression :: OFL -> OFL2 -> TopLevel.Expression -> Expression PsincE
+buildPsincExpression _ _ e = error $ "Unimplemented psinc expression: " ++ prettyPrint e
+
+-- buildAssignment ofl ofl2 (TopLevel.Assign lhs rhs) = 
+--   Assign (buildExpression' lhs) (buildExpression' rhs) 
+--   where
+--   buildExpression' = buildExpression ofl ofl2
+-- 
+-- buildExpression :: OFL -> OFL2 -> TopLevel.Expression -> Expression
+-- buildExpression _ _ (TopLevel.IndexedIdentifier name indices) = IndexedIdentifier name indices
+-- buildExpression _ _ (TopLevel.ConstReal r) = ConstReal r
+-- buildExpression _ _ (TopLevel.ConstInteger i) = ConstInteger i
+-- buildExpression ofl ofl2 (TopLevel.Negate e) = Negate $ buildExpression ofl ofl2 e
+-- buildExpression ofl ofl2 (TopLevel.Integrate e) = Integrate $ buildExpression ofl ofl2 e
+-- buildExpression ofl ofl2 (TopLevel.Sum e index) = Sum (buildExpression ofl ofl2 e) index
+-- buildExpression ofl ofl2 (TopLevel.Multiply e1 e2) = Mul (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
+-- buildExpression ofl ofl2 (TopLevel.Divide e1 e2) = Div (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
+-- buildExpression ofl ofl2 (TopLevel.Add e1 e2) = Add (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
+-- buildExpression ofl ofl2 (TopLevel.Sub e1 e2) = Sub (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
+-- buildExpression ofl ofl2 (TopLevel.Power e1 e2) = Pow (buildExpression ofl ofl2 e1) (buildExpression ofl ofl2 e2)
+-- buildExpression _ _ (TopLevel.PositionComponent i) = PositionComponent i
+-- buildExpression ofl ofl2 (TopLevel.SpatialDerivative e index n) = Mul operator $ ToMomentum (buildExpression ofl ofl2 e)
+--   where
+--   operator = Pow derivative (ConstInteger n)
+--   derivative = Mul (MomentumComponent index) (ConstComplex $ 0.0 :+ (-1.0))
diff --git a/OFC/TargetMapping.hs b/OFC/TargetMapping.hs
index f447c67..d8feb92 100644
--- a/OFC/TargetMapping.hs
+++ b/OFC/TargetMapping.hs
@@ -78,4 +78,3 @@ getProperty getter properties = case catMaybes $ map getter properties of
   [] -> Nothing
   [x] -> Just x
   dups -> error $ "Duplicate properties found: " ++ show dups
-