From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Wed, 26 Sep 2012 18:44:07 +0000 (+0100)
Subject: More work on second-level representation.
X-Git-Url: https://git.unchartedbackwaters.co.uk/w/?a=commitdiff_plain;h=d0126c31553516ef911d50eaf734f3c9c89d7df9;p=francis%2Fofc.git

More work on second-level representation.
---

diff --git a/OFC/Common.hs b/OFC/Common.hs
index 44f77c1..c10c03d 100644
--- a/OFC/Common.hs
+++ b/OFC/Common.hs
@@ -1,7 +1,13 @@
 module OFC.Common where
+import Text.PrettyPrint (Doc, renderStyle, Style(..), Mode(..))
 
 data IndexType = 
   FunctionIndex | 
   SpinIndex | 
   SpatialIndex 
   deriving (Show, Eq, Enum, Bounded)
+
+class PrettyPrintable a where
+  toDoc :: a -> Doc
+  prettyPrint :: a -> String
+  prettyPrint = renderStyle Style {mode = PageMode, lineLength=72, ribbonsPerLine=1.5 } . toDoc
diff --git a/OFC/SecondLevel.hs b/OFC/SecondLevel.hs
index df63c65..ceef1b7 100644
--- a/OFC/SecondLevel.hs
+++ b/OFC/SecondLevel.hs
@@ -1,12 +1,32 @@
 module OFC.SecondLevel where
+import OFC.Common
+import OFC.TargetMapping (MappingTable, FortranFunction)
+import OFC.TopLevel (OFL)
+import qualified OFC.TopLevel as TopLevel
 import Data.Complex
+import Text.PrettyPrint
+import Data.Map (Map)
+import qualified Data.Map as Map
 
-data Type = 
+type SymbolTable = Map String SymbolType
+
+data Quantification = 
+  Forall |
+  Bound
+  deriving Show
+
+data SymbolType = 
+  ValueTag ValueType [IndexType] | 
+  IndexTag IndexType Quantification
+  deriving Show
+
+data ValueType = 
   RealType | 
   ComplexType |
   IntegerType |
   Psinc Integer | 
   PsincReciprocal Integer
+  deriving Show
 
 data Expression = 
   IndexedIdentifier String [String] |
@@ -15,10 +35,16 @@ data Expression =
   Apply DiagonalOperator Expression |
   Product Expression Expression |
   InnerProduct Expression Expression
+  deriving Show
+
+data Assignment =
+ Assign Expression Expression 
+ deriving Show 
 
 data DiagonalOperator = 
   PositionOperator OperatorExpr |
   MomentumOperator OperatorExpr
+  deriving Show
 
 data OperatorExpr = 
   ConstReal Double |
@@ -29,3 +55,33 @@ data OperatorExpr =
   Multiply OperatorExpr OperatorExpr |
   Sum OperatorExpr String |
   Power OperatorExpr OperatorExpr
+  deriving Show
+
+data OFL2 = OFL2 {
+  symbols :: SymbolTable,
+  assignments :: [Assignment],
+  targetMappings :: MappingTable,
+  outputFunction :: FortranFunction
+} deriving Show
+
+instance PrettyPrintable OFL2 where
+  toDoc ofl2 = text $ show ofl2
+
+emptyOFL2 :: OFL2
+emptyOFL2 = OFL2 { 
+  symbols = Map.empty, 
+  assignments = [], 
+  targetMappings = Map.empty, 
+  outputFunction = error "Output function not defined"
+}
+
+buildSecondLevel :: OFL -> OFL2
+buildSecondLevel ofl = 
+  emptyOFL2 {
+    symbols = buildSymbolTable ofl,
+    targetMappings = TopLevel.getTargetMappings ofl,
+    outputFunction = TopLevel.getOutputFunction ofl
+  }
+
+buildSymbolTable :: OFL -> SymbolTable
+buildSymbolTable _ = error "Building second-level symbol table not yet implemented!"
diff --git a/OFC/TargetMapping.hs b/OFC/TargetMapping.hs
index 33a115e..2cbe4dc 100644
--- a/OFC/TargetMapping.hs
+++ b/OFC/TargetMapping.hs
@@ -1,4 +1,7 @@
 module OFC.TargetMapping where
+import Data.Map (Map)
+
+type MappingTable = Map String TargetType
 
 data TargetType = 
   FortranParameter [FortranParameterProperty] |
diff --git a/OFC/TopLevel.hs b/OFC/TopLevel.hs
index 8045fed..ec2a397 100644
--- a/OFC/TopLevel.hs
+++ b/OFC/TopLevel.hs
@@ -32,7 +32,9 @@ data Expression =
   SpatialDerivative Expression String Integer
   deriving Show
 
-data Assignment = Assign Expression Expression deriving Show
+data Assignment = 
+  Assign Expression Expression 
+  deriving Show
 
 class OFLKeyword a where
   toOFLString :: a -> String
@@ -52,7 +54,6 @@ data SymbolType =
   deriving Show
 
 type SymbolTable = Map String SymbolType
-type MappingTable = Map String TargetType
 
 data OFL = OFL {
   symbols :: SymbolTable,
@@ -62,21 +63,18 @@ data OFL = OFL {
   outputFunction :: FortranFunction
 } deriving Show
 
-toDoc :: OFL -> Doc
-toDoc ofl = vcat [symbolDoc, assignmentsDoc, targetMappingsDoc, outputFunctionDoc]
-  where
-  symbolDoc = text "Symbol table:"
-    $$ nest 1 (vcat [text $ show x | x <- Map.assocs $ symbols ofl])
-  assignmentsDoc = text "Assignments: "
-    $$ nest 1 (vcat [text $ show x | x <- assignments ofl])
-  targetMappingsDoc = text "Target properties: "
-    $$ nest 1 (vcat [text $ show x | x <- Map.assocs $ targetMappings ofl])
-  outputFunctionDoc = text "OutputFunction:"
-    $$ nest 1 (text $ show $ outputFunction ofl)
-
-prettyPrint :: OFL -> String
-prettyPrint ofl = renderStyle Style {mode = PageMode, lineLength=10, ribbonsPerLine=1.5 } $ toDoc ofl
-
+instance PrettyPrintable OFL where
+  toDoc ofl = vcat [symbolDoc, assignmentsDoc, targetMappingsDoc, outputFunctionDoc]
+    where
+    symbolDoc = text "Symbol table:"
+      $$ nest 1 (vcat [text $ show x | x <- Map.assocs $ symbols ofl])
+    assignmentsDoc = text "Assignments: "
+      $$ nest 1 (vcat [text $ show x | x <- assignments ofl])
+    targetMappingsDoc = text "Target properties: "
+      $$ nest 1 (vcat [text $ show x | x <- Map.assocs $ targetMappings ofl])
+    outputFunctionDoc = text "OutputFunction:"
+      $$ nest 1 (text $ show $ outputFunction ofl)
+  
 -- Symbol table manipulators
 addValueDeclaration :: OFL -> String -> BaseType -> [IndexType] -> OFL
 addValueDeclaration ofl name baseType indices = ofl { symbols = symbols' }
@@ -90,6 +88,12 @@ addTargetMapping ofl name properties = result where
     then error $ "error: target binding " ++ show name ++ " conflicts with internally generated identifer."
     else ofl'
 
+getTargetMappings :: OFL -> MappingTable
+getTargetMappings = targetMappings
+
+getOutputFunction :: OFL -> FortranFunction
+getOutputFunction = outputFunction
+
 addIndexDeclaration :: OFL -> String -> IndexType -> OFL
 addIndexDeclaration ofl name indexType = ofl { symbols = symbols' }
   where symbols' = Map.insertWithKey errorOnDuplicate name (IndexTag indexType) (symbols ofl)
diff --git a/src/Main.hs b/src/Main.hs
index 31fdc90..1b7afd1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,7 +1,9 @@
 module Main (main) where
 import System.Environment (getArgs)
+import OFC.Common
 import OFC.Parser (runOFLParser)
-import OFC.TopLevel (prettyPrint)
+import OFC.TopLevel (OFL)
+import OFC.SecondLevel (buildSecondLevel)
 
 main :: IO()
 main = do 
@@ -18,4 +20,13 @@ processFile filename = do
   let result = runOFLParser contents in
     case result of
       Left err -> putStrLn $ show err
-      Right ofl -> putStrLn $ prettyPrint ofl
+      Right ofl -> printRefinements ofl
+
+printRefinements :: OFL -> IO()
+printRefinements ofl = do
+  let ofl' = buildSecondLevel ofl in
+    do 
+      putStrLn "Top-level representation:"
+      putStrLn $ prettyPrint ofl
+      putStrLn "\nSecond-level representation:"
+      putStrLn $ prettyPrint ofl'