From b0c0b93a315a39a8a28ad288f37e7e7882baa987 Mon Sep 17 00:00:00 2001 From: Francis Russell Date: Mon, 17 Sep 2012 19:16:17 +0100 Subject: [PATCH] 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. --- src/HighLevel.hs | 78 +++++++++++++++++++++++++++++++----------------- src/Main.hs | 5 ++-- src/Parser.hs | 20 ++++++------- 3 files changed, 63 insertions(+), 40 deletions(-) diff --git a/src/HighLevel.hs b/src/HighLevel.hs index 5f46280..8e0703b 100644 --- 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 60b5851..1878493 100644 --- 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 4ca63d3..dd9f026 100644 --- 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" -- 2.47.3