Cleanups after feedback from Tristan.

- Avoid defining our own show.
- Use sequence_ from Control.Monad.
- Use vcat when pretty printing.
- Define default value of outputFunction as an error instead of
  undefined.
- Use if instead of case for conditionals on booleans.

diff --git a/src/HighLevel.hs b/src/HighLevel.hs
index 5f462809cdb0b844b8b1e432711a4f7de30d0cf7..8e0703b356bd97a4b7e29ca81591bed34c5c6784 100644 (file)
--- a/src/HighLevel.hs
+++ b/src/HighLevel.hs
@@ -1,18 +1,21 @@
 module HighLevel where
 import TargetMapping
 import Text.PrettyPrint
-import Data.Map as Map (Map, lookup, insertWithKey, assocs, empty)
 import Data.List (foldl')
+import Data.Map as Map (Map, lookup, insertWithKey, assocs, empty)
 
 -- The top-level types
-data BaseType = RealType | FunctionType | IntegerType deriving (Eq, Enum, Bounded)
-
-instance Show BaseType where
-  show RealType = "Real"
-  show FunctionType = "Function"
-  show IntegerType = "Integer"
-
-data IndexType = FunctionIndex | SpinIndex | SpatialIndex deriving (Show, Eq, Enum, Bounded)
+data BaseType = 
+  RealType | 
+  FunctionType | 
+  IntegerType 
+  deriving (Show, Eq, Enum, Bounded)
+
+data IndexType = 
+  FunctionIndex | 
+  SpinIndex | 
+  SpatialIndex 
+  deriving (Show, Eq, Enum, Bounded)
 
 -- Expressions
 data Expression = 
@@ -29,10 +32,22 @@ data Expression =
   Sub Expression Expression |
   Power Expression Expression |
   PositionComponent String |
-  Derivative Expression String deriving Show
+  Derivative Expression String 
+  deriving Show
   
 data Assignment = Assign Expression Expression deriving Show
 
+class OFLKeyword a where
+  toOFLString :: a -> String
+
+instance OFLKeyword BaseType where
+  toOFLString RealType = "Real"
+  toOFLString FunctionType = "Function"
+  toOFLString IntegerType = "Integer"
+
+instance OFLKeyword IndexType where
+  toOFLString indexType = show indexType
+
 -- The symbol table
 data SymbolType = ValueTag BaseType [IndexType] | IndexTag IndexType deriving Show
 type SymbolTable = Map String SymbolType
@@ -42,22 +57,22 @@ data OFL = OFL {
   assignments :: [Assignment],
   targetMappings :: MappingTable,
   outputFunction :: FortranFunction
-}
+} deriving Show
 
 toDoc :: OFL -> Doc
-toDoc ofl = symbolDoc $$ assignmentsDoc $$ targetMappingsDoc $$ outputFunctionDoc
+toDoc ofl = vcat [symbolDoc, assignmentsDoc, targetMappingsDoc, outputFunctionDoc]
   where
   symbolDoc = text "Symbol table:"
-    $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [text $ show x | x <- assocs $ symbols ofl])
+    $$ nest 1 (vcat [text $ show x | x <- assocs $ symbols ofl])
   assignmentsDoc = text "Assignments: "
-    $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [text $ show x | x <- assignments ofl])
+    $$ nest 1 (vcat [text $ show x | x <- assignments ofl])
   targetMappingsDoc = text "Target properties: "
-    $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [text $ show x | x <- assocs $ targetMappings ofl])
+    $$ nest 1 (vcat [text $ show x | x <- assocs $ targetMappings ofl])
   outputFunctionDoc = text "OutputFunction:"
     $$ nest 1 (text $ show $ outputFunction ofl)
 
-instance Show OFL where
-  show ofl = renderStyle Style {mode = PageMode, lineLength=10, ribbonsPerLine=1.5 } $ toDoc ofl
+prettyPrint :: OFL -> String
+prettyPrint ofl = renderStyle Style {mode = PageMode, lineLength=10, ribbonsPerLine=1.5 } $ toDoc ofl
 
 -- Symbol table manipulators
 addValueDeclaration :: OFL -> String -> BaseType -> [IndexType] -> OFL
@@ -134,7 +149,12 @@ getType ofl (Power a b) = promoteType (getType ofl a) (getType ofl b)
 getType ofl (Derivative e _) = getType ofl e
 
 emptyOFL :: OFL
-emptyOFL = OFL { assignments = [], symbols = Map.empty, targetMappings = Map.empty, outputFunction = undefined}
+emptyOFL = OFL { 
+  assignments = [], 
+  symbols = Map.empty, 
+  targetMappings = Map.empty, 
+  outputFunction = error "Output function not defined"
+}
 
 -- Validation
 data ValidationError = Message String deriving Show
@@ -151,21 +171,23 @@ validateAssignment ofl (Assign lhs rhs) = do
   validateExpression ofl lhs
   validateExpression ofl rhs
   isLValue ofl lhs
-  case (getType ofl lhs) == (getType ofl rhs) of
-    True -> validationSuccess
-    False -> validationFailure $ "Types of left and right-hand sides of assignment do not match"
+  if (getType ofl lhs) == (getType ofl rhs) 
+    then validationSuccess 
+    else validationFailure $ "Types of left and right-hand sides of assignment do not match"
 
 isLValue :: OFL -> Expression -> ValidationResult
 isLValue _ (IndexedIdentifier _ _) = validationSuccess
 isLValue _ e = validationFailure $ "Expression " ++ show e ++ " is not an assignable value"
 
 indexExists :: OFL -> String -> ValidationResult
-indexExists ofl name = if (hasIndex ofl name) then validationSuccess else validationFailure $ "Unknown index " ++ name
+indexExists ofl name = if (hasIndex ofl name)
+  then validationSuccess 
+  else validationFailure $ "Unknown index " ++ name
 
 indexIsType :: OFL -> String -> IndexType -> ValidationResult
-indexIsType ofl name indexType = case indexType == (getIndexType ofl name) of
-  True -> validationSuccess
-  False -> validationFailure $ "Expected index " ++ name ++ " to be be of type " ++ show indexType
+indexIsType ofl name indexType = if indexType == (getIndexType ofl name) 
+  then validationSuccess
+  else validationFailure $ "Expected index " ++ name ++ " to be be of type " ++ show indexType
 
 valueExists :: OFL -> String -> ValidationResult
 valueExists ofl name = if (hasValue ofl name) then validationSuccess else validationFailure $ "Unknown value " ++ name
@@ -181,9 +203,9 @@ validateExpression ofl (IndexedIdentifier name indices) = do
   valueExists ofl name
   foldl' (>>) validationSuccess $ map (indexExists ofl) indices
   let indexTypes = map (getIndexType ofl) indices in
-    case indexTypes == (getIndices ofl name) of
-      True -> validationSuccess
-      False -> validationFailure $ "Incorrect number or type of indices used to index " ++ name
+    if indexTypes == (getIndices ofl name)
+      then validationSuccess
+      else validationFailure $ "Incorrect number or type of indices used to index " ++ name
 
 validateExpression _ (ConstReal _) = validationSuccess
 

diff --git a/src/Main.hs b/src/Main.hs
index 60b5851bf6e5a37eb6de3be67f6f6385b0642c7c..1878493bf9869f49ae27e9b3b38b910669fc87d6 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,7 @@
 module Main (main) where
 import System.Environment (getArgs)
-import Parser
+import Parser (runOFLParser)
+import HighLevel (prettyPrint)
 
 main :: IO()
 main = do 
@@ -17,4 +18,4 @@ processFile filename = do
   let result = runOFLParser contents in
     case result of
       Left err -> putStrLn $ show err
-      Right ofl -> putStrLn $ show ofl
+      Right ofl -> putStrLn $ prettyPrint ofl

diff --git a/src/Parser.hs b/src/Parser.hs
index 4ca63d35a1028d0789259d2853a7c46844fd7008..dd9f0267ca7d95501223e36521c165db68757cf1 100644 (file)
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -36,16 +36,16 @@ TokenParser {
   stringLiteral = lStringLiteral
 } = makeTokenParser oflDef
 
-oflOperatorTable = [[Infix  (do _ <- lSymbol "^"; return (\x y -> Power x y)) AssocLeft],
-                    [Prefix (do _ <- lSymbol "-"; return (\x -> Negate x))],
-                    [Infix  (do _ <- lSymbol "*"; return (\x y -> Multiply x y)) AssocLeft
-                    ,Infix  (do _ <- lSymbol "/"; return (\x y -> Divide x y)) AssocLeft],
-                    [Infix  (do _ <- lSymbol "+"; return (\x y -> Add x y)) AssocLeft
-                    ,Infix  (do _ <- lSymbol "-"; return (\x y -> Sub x y)) AssocLeft]
+oflOperatorTable = [[Infix  (do _ <- lSymbol "^"; return Power) AssocLeft],
+                    [Prefix (do _ <- lSymbol "-"; return Negate)],
+                    [Infix  (do _ <- lSymbol "*"; return Multiply) AssocLeft
+                    ,Infix  (do _ <- lSymbol "/"; return Divide) AssocLeft],
+                    [Infix  (do _ <- lSymbol "+"; return Add) AssocLeft
+                    ,Infix  (do _ <- lSymbol "-"; return Sub) AssocLeft]
                    ]
 
-parseType = foldl1' (<|>) [do lReserved $ show t; return t | t <- [minBound::BaseType ..]]
-parseIndex = foldl1' (<|>) [do lReserved $ show t; return t | t <- [minBound::IndexType ..]]
+parseType = foldl1' (<|>) [do lReserved $ toOFLString t; return t | t <- [minBound::BaseType ..]]
+parseIndex = foldl1' (<|>) [do lReserved $ toOFLString t; return t | t <- [minBound::IndexType ..]]
 
 parseDeclaration :: Parsec String OFL ()
 parseDeclaration = parseValueDeclaration <|> parseIndexDeclaration <?> "declaration"
@@ -55,14 +55,14 @@ parseValueDeclaration = do
   valueType <- parseType
   indices <- option [] (lBrackets $ lCommaSep parseIndex)
   names <- lCommaSep1 parseIdentifier
-  foldl1' (>>) [modifyState(\x -> addValueDeclaration x name valueType indices) | name <- names]
+  sequence_ [modifyState(\x -> addValueDeclaration x name valueType indices) | name <- names]
   <?> "value declaration"
 
 parseIndexDeclaration :: Parsec String OFL ()
 parseIndexDeclaration = do
   indexType <- parseIndex
   names <- lCommaSep1 parseIdentifier
-  foldl1' (>>) [modifyState(\x -> addIndexDeclaration x name indexType) | name <- names]
+  sequence_ [modifyState(\x -> addIndexDeclaration x name indexType) | name <- names]
   <?> "index declaration"
 
 parseIdentifier = lIdentifier <?> "identifier"