From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Wed, 10 Oct 2012 15:12:32 +0000 (+0100)
Subject: Add pretty printing for second-level AST.
X-Git-Url: https://git.unchartedbackwaters.co.uk/w/?a=commitdiff_plain;h=ca568041f07a7b7e474e6735f895ceff2cb2402d;p=francis%2Fofc.git

Add pretty printing for second-level AST.
---

diff --git a/OFC/SecondLevel.hs b/OFC/SecondLevel.hs
index 80d85eb..c011993 100644
--- a/OFC/SecondLevel.hs
+++ b/OFC/SecondLevel.hs
@@ -16,7 +16,7 @@ import qualified OFC.TopLevel as TopLevel
 import Data.Complex
 import Text.PrettyPrint
 import Data.Map (Map)
-import Data.List (foldl')
+import Data.List (foldl', intersperse)
 import qualified Data.Map as Map
 
 type SymbolTable = Map String SymbolType
@@ -61,10 +61,38 @@ data Expression =
   Pow Expression Expression
   deriving Show
 
+instance PrettyPrintable Expression where
+  toDoc expression = case expression of
+    IndexedIdentifier name indices -> text name <> case indices of
+      [] -> empty
+      nonNil -> brackets $ hcat $ punctuate comma (map text nonNil)
+    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 ((show $ realPart c) ++ " + i*" ++ (show $ imagPart c) ++ ")")
+    LatticeComponent i -> text $ "lattice[" ++ i ++ "]"
+    Negate 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
+    where
+    binaryToDoc op lhs rhs = parens $ hcat [toDoc lhs, text op, toDoc rhs]
+    functionToDoc name params = text name <> (parens $ hcat (intersperse (text ", ") params))
+
 data Assignment =
  Assign Expression Expression
  deriving Show 
 
+instance PrettyPrintable Assignment where
+  toDoc (Assign lhs rhs) = hcat [toDoc lhs, text " = ", toDoc rhs]
+
 data OFL2 = OFL2 {
   symbols :: SymbolTable,
   assignments :: [Assignment],
@@ -78,7 +106,7 @@ instance PrettyPrintable OFL2 where
     symbolDoc = text "Symbol table:"
       $$ nest 1 (vcat [text $ show x | x <- Map.assocs $ symbols ofl2])
     assignmentsDoc = text "Assignments: "
-      $$ nest 1 (vcat [text $ show x | x <- assignments ofl2])
+      $$ nest 1 (vcat $ map toDoc $ assignments ofl2)
   
 emptyOFL2 :: OFL2
 emptyOFL2 = OFL2 { 
diff --git a/OFC/TopLevel.hs b/OFC/TopLevel.hs
index 18ad360..1239152 100644
--- a/OFC/TopLevel.hs
+++ b/OFC/TopLevel.hs
@@ -35,7 +35,7 @@ module OFC.TopLevel
 import OFC.TargetMapping
 import OFC.Common
 import Text.PrettyPrint
-import Data.List (foldl', intercalate, intersperse)
+import Data.List (foldl', intersperse)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -67,12 +67,12 @@ data Expression =
 
 instance PrettyPrintable Expression where
   toDoc expression = case expression of 
-    IndexedIdentifier name indices -> text $ name ++ case indices of 
-      [] -> ""
-      nonNil -> "[" ++ (intercalate ", " nonNil) ++ "]"
-    ConstReal r -> text $ show r
-    ConstInteger i -> text $ show i
-    Negate e -> text "(-" <> toDoc e <> text ")"
+    IndexedIdentifier name indices -> text name <> case indices of 
+      [] -> empty
+      nonNil -> brackets $ hcat $ punctuate comma (map text nonNil)
+    ConstReal r -> double r
+    ConstInteger i -> integer i
+    Negate e -> parens $ text "-" <> toDoc e
     Integrate e -> functionToDoc "integrate" [toDoc e]
     Sum e i -> functionToDoc "sum" [toDoc e, text i]
     Multiply a b -> binaryToDoc "*" a b
@@ -83,8 +83,8 @@ instance PrettyPrintable Expression where
     PositionComponent index -> text $ "r[" ++ index ++ "]"
     SpatialDerivative e index degree -> functionToDoc "diff" [toDoc e, text index, text $ show degree]
     where
-    binaryToDoc op lhs rhs = hcat [text "(", toDoc lhs, text op, toDoc rhs, text ")"]
-    functionToDoc name params = text (name ++ "(") <> hcat (intersperse (text ", ") params) <> text ")"
+    binaryToDoc op lhs rhs = parens $ hcat [toDoc lhs, text op, toDoc rhs]
+    functionToDoc name params = text name <> (parens $ hcat (intersperse (text ", ") params))
 
 data Assignment = 
   Assign Expression Expression