getFileName _ = error "Usage: ofc input_file"
processOFL :: String -> IO()
-processOFL input = let result = parseAsOFL input in
- do { case result of
- Left err -> putStrLn $ show err
- Right ofl -> putStrLn $ show ofl
- }
+processOFL input =
+ let result = parseAsOFL input in do
+ case result of
+ Left err -> putStrLn $ show err
+ Right ofl -> putStrLn $ show ofl
data IndexType = FunctionIndex | SpinIndex | SpatialIndex deriving (Show, Eq, Enum, Bounded)
-- Expressions
-data Expression = IndexedIdentifier String [String] |
- ConstReal Double |
- ConstInteger Integer |
- Negate Expression |
- Inner Expression Expression |
- Laplacian Expression |
- Sum Expression String |
- Multiply Expression Expression |
- Divide Expression Expression |
- Add Expression Expression |
- Sub Expression Expression |
- Power Expression Expression |
- PositionComponent String |
- Derivative Expression String deriving Show
-
+data Expression =
+ IndexedIdentifier String [String] |
+ ConstReal Double |
+ ConstInteger Integer |
+ Negate Expression |
+ Inner Expression Expression |
+ Laplacian Expression |
+ Sum Expression String |
+ Multiply Expression Expression |
+ Divide Expression Expression |
+ Add Expression Expression |
+ Sub Expression Expression |
+ Power Expression Expression |
+ PositionComponent String |
+ Derivative Expression String deriving Show
+
data Assignment = Assign Expression Expression deriving Show
-- The symbol table
where symbols' = insertWithKey errorOnDuplicate name (IndexTag indexType) (symbols ofl)
addAssignment :: OFL -> Expression -> Expression -> OFL
-addAssignment ofl lhs rhs = let assignment = (Assign lhs rhs) in
+addAssignment ofl lhs rhs =
+ let assignment = (Assign lhs rhs) in
case (validateAssignment ofl assignment) of
Right () -> ofl { assignments = (Assign lhs rhs):(assignments ofl) }
Left reason -> error $ show reason
errorOnDuplicate key _ _ = error $ "Attempted redefinition of symbol " ++ show key
getIndices :: OFL -> String -> [IndexType]
-getIndices ofl name =
- case Map.lookup name (symbols ofl) of
- Just (ValueTag _ indices) -> indices
- _ -> fail $ "Cannot find indices for " ++ show name
+getIndices ofl name = case Map.lookup name (symbols ofl) of
+ Just (ValueTag _ indices) -> indices
+ _ -> fail $ "Cannot find indices for " ++ show name
getIndexType :: OFL -> String -> IndexType
getIndexType ofl name = case Map.lookup name (symbols ofl) of
- Just (IndexTag indexType) -> indexType
- _ -> error $ "Cannot find index type of " ++ show name
+ Just (IndexTag indexType) -> indexType
+ _ -> error $ "Cannot find index type of " ++ show name
getValueType :: OFL -> String -> BaseType
getValueType ofl name = case Map.lookup name (symbols ofl) of
- Just (ValueTag baseType _) -> baseType
- _ -> error $ "Cannot find type of value " ++ show name
+ Just (ValueTag baseType _) -> baseType
+ _ -> error $ "Cannot find type of value " ++ show name
hasIndex :: OFL -> String -> Bool
hasIndex ofl name = case Map.lookup name (symbols ofl) of
- Just (IndexTag _) -> True
- _ -> False
+ Just (IndexTag _) -> True
+ _ -> False
hasValue :: OFL -> String -> Bool
hasValue ofl name = case Map.lookup name (symbols ofl) of
- Just (ValueTag _ _) -> True
- _ -> False
+ Just (ValueTag _ _) -> True
+ _ -> False
promote :: BaseType -> BaseType -> BaseType
promote Function _ = Function
validationFailure = \x -> Left (Message x)
validateAssignment :: OFL -> Assignment -> ValidationResult
-validateAssignment ofl (Assign lhs rhs) = do {
- validateExpression ofl lhs;
- validateExpression ofl rhs;
- isLValue ofl lhs;
+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"
-}
isLValue :: OFL -> Expression -> ValidationResult
isLValue ofl (IndexedIdentifier name indices) = validationSuccess
validateExpression :: OFL -> Expression -> ValidationResult
-validateExpression ofl (IndexedIdentifier name indices) = do {
- valueExists ofl name;
- foldl (>>) validationSuccess $ map (indexExists ofl) indices;
+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
-}
validateExpression ofl (ConstReal _) = validationSuccess
validateExpression ofl (Negate e) = validateExpression ofl e
-validateExpression ofl (Inner a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
- isFunction ofl a;
- isFunction ofl b;
-}
-
-validateExpression ofl (Laplacian e) = do {
- validateExpression ofl e;
- isFunction ofl e;
-}
-
-validateExpression ofl (Sum e i) = do {
- validateExpression ofl e;
- indexExists ofl i;
-}
-
-validateExpression ofl (Multiply a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
-}
-
-validateExpression ofl (Divide a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
-}
-
-validateExpression ofl (Add a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
-}
-
-validateExpression ofl (Sub a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
-}
-
-validateExpression ofl (Power a b) = do {
- validateExpression ofl a;
- validateExpression ofl b;
-}
-
-validateExpression ofl (PositionComponent i) = do {
- indexExists ofl i;
+validateExpression ofl (Inner a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+ isFunction ofl a
+ isFunction ofl b
+
+validateExpression ofl (Laplacian e) = do
+ validateExpression ofl e
+ isFunction ofl e
+
+validateExpression ofl (Sum e i) = do
+ validateExpression ofl e
+ indexExists ofl i
+
+validateExpression ofl (Multiply a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+
+validateExpression ofl (Divide a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+
+validateExpression ofl (Add a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+
+validateExpression ofl (Sub a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+
+validateExpression ofl (Power a b) = do
+ validateExpression ofl a
+ validateExpression ofl b
+
+validateExpression ofl (PositionComponent i) = do
+ indexExists ofl i
indexIsType ofl i SpatialIndex
-}
-validateExpression ofl (Derivative e i) = do {
- validateExpression ofl e;
- indexExists ofl i;
+validateExpression ofl (Derivative e i) = do
+ validateExpression ofl e
+ indexExists ofl i
indexIsType ofl i SpatialIndex
-}
import Text.Parsec.Combinator
oflKeywords = map show [minBound::IndexType ..] ++
- map show [minBound::BaseType ..] ++
- ["^", "+", "-", "*", "/", "laplacian", "inner", "sum", "derivative", "r", "target"]
+ map show [minBound::BaseType ..] ++
+ ["^", "+", "-", "*", "/", "laplacian", "inner", "sum", "derivative", "r", "target"]
-oflDef = emptyDef{ commentStart = ""
- , commentEnd = ""
- , commentLine = "#"
- , nestedComments = False
- , identStart = letter <|> char '_'
- , identLetter = alphaNum <|> char '_'
- , caseSensitive = True
- , reservedNames = oflKeywords
- }
+oflDef = emptyDef {
+ commentStart = "",
+ commentEnd = "",
+ commentLine = "#",
+ nestedComments = False,
+ identStart = letter <|> char '_',
+ identLetter = alphaNum <|> char '_',
+ caseSensitive = True,
+ reservedNames = oflKeywords
+}
-TokenParser { reserved = lReserved
- , whiteSpace = lWhiteSpace
- , identifier = lIdentifier
- , commaSep = lCommaSep
- , commaSep1 = lCommaSep1
- , brackets = lBrackets
- , symbol = lSymbol
- , parens = lParens
- , naturalOrFloat = lNaturalOrFloat
+TokenParser {
+ reserved = lReserved,
+ whiteSpace = lWhiteSpace,
+ identifier = lIdentifier,
+ commaSep = lCommaSep,
+ commaSep1 = lCommaSep1,
+ brackets = lBrackets,
+ symbol = lSymbol,
+ parens = lParens,
+ naturalOrFloat = lNaturalOrFloat
} = 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 (\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]
]
-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 $ show t; return t | t <- [minBound::BaseType ..]]
+parseIndex = foldl1 (<|>) [do lReserved $ show t; return t | t <- [minBound::IndexType ..]]
parseDeclaration :: Parsec String OFL ()
parseDeclaration = parseValueDeclaration <|> parseIndexDeclaration
parseValueDeclaration :: Parsec String OFL ()
-parseValueDeclaration = do { valueType <- parseType;
- indices <- option [] (lBrackets $ lCommaSep parseIndex);
- names <- lCommaSep1 parseIdentifier;
- foldl1 (>>) [modifyState(\x -> addValueDeclaration x name valueType indices) | name <- names]
-} <?> "value declaration"
+parseValueDeclaration = do
+ valueType <- parseType
+ indices <- option [] (lBrackets $ lCommaSep parseIndex)
+ names <- lCommaSep1 parseIdentifier
+ foldl1 (>>) [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]
- } <?> "index declaration"
+parseIndexDeclaration = do
+ indexType <- parseIndex
+ names <- lCommaSep1 parseIdentifier
+ foldl1 (>>) [modifyState(\x -> addIndexDeclaration x name indexType) | name <- names]
+ <?> "index declaration"
parseIdentifier = lIdentifier <?> "identifier"
parseAssignment :: Parsec String OFL ()
-parseAssignment = do { lhs <- parseExpression;
- lSymbol "=";
- rhs <- parseExpression;
- modifyState(\x -> addAssignment x lhs rhs)
- } <?> "assignment"
+parseAssignment = do
+ lhs <- parseExpression
+ lSymbol "="
+ rhs <- parseExpression
+ modifyState(\x -> addAssignment x lhs rhs)
+ <?> "assignment"
parseExpression = buildExpressionParser oflOperatorTable parseTerm
-parseTerm = do { lReserved "laplacian"; operand <- lParens parseExpression; return $ Laplacian operand } <|>
- do { lReserved "inner"; inner <- lParens parseInner; return inner} <|>
- do { lReserved "sum"; sum <- lParens parseSum; return sum} <|>
- do { lReserved "derivative"; derivative <- lParens parseDerivative; return derivative} <|>
- do { lReserved "r"; index <- lBrackets parseIdentifier; return $ PositionComponent index} <|>
- do { number <- lNaturalOrFloat;
- return $ case number of
- Left i -> ConstInteger i
- Right r -> ConstReal r
- } <|>
- lParens parseExpression <|>
- parseIdentifierAccess <?>
- "term"
+parseTerm = do
+ lReserved "laplacian"; operand <- lParens parseExpression; return $ Laplacian operand
+ <|> do lReserved "inner"; inner <- lParens parseInner; return inner
+ <|> do lReserved "sum"; sum <- lParens parseSum; return sum
+ <|> do lReserved "derivative"; derivative <- lParens parseDerivative; return derivative
+ <|> do lReserved "r"; index <- lBrackets parseIdentifier; return $ PositionComponent index
+ <|> do number <- lNaturalOrFloat
+ return $ case number of
+ Left i -> ConstInteger i
+ Right r -> ConstReal r
+ <|> lParens parseExpression
+ <|> parseIdentifierAccess
+ <?> "term"
-parseInner = do { e1 <- parseExpression; lSymbol ","; e2 <- parseExpression; return $ Inner e1 e2} <?> "inner product"
+parseInner = do
+ e1 <- parseExpression
+ lSymbol ","
+ e2 <- parseExpression
+ return $ Inner e1 e2
+ <?> "inner product"
-parseSum = do { e1 <- parseExpression; lSymbol ","; index <- parseIdentifier; return $ Sum e1 index} <?> "sum"
+parseSum = do
+ e1 <- parseExpression
+ lSymbol ","
+ index <- parseIdentifier
+ return $ Sum e1 index
+ <?> "sum"
-parseDerivative = do { e1 <- parseExpression; lSymbol ","; index <- parseIdentifier; return $ Derivative e1 index} <?> "derivative"
+parseDerivative = do
+ e1 <- parseExpression
+ lSymbol ","
+ index <- parseIdentifier
+ return $ Derivative e1 index
+ <?> "derivative"
-parseIdentifierAccess = do { identifier <- parseIdentifier;
- indices <- option [] (lBrackets $ lCommaSep parseIdentifier);
- return $ IndexedIdentifier identifier indices
- } <?> "indexed identifier"
+parseIdentifierAccess = do
+ identifier <- parseIdentifier
+ indices <- option [] (lBrackets $ lCommaSep parseIdentifier)
+ return $ IndexedIdentifier identifier indices
+ <?> "indexed identifier"
parseTarget = lReserved "target" >> lIdentifier
parseOFL :: Parsec String OFL OFL
-parseOFL = do { lWhiteSpace;
- many1 parseDeclaration;
- many1 parseAssignment;
- target <- parseTarget;
- many1 anyChar;
- eof;
- getState
- }
+parseOFL = do
+ lWhiteSpace
+ many1 parseDeclaration
+ many1 parseAssignment
+ target <- parseTarget
+ many1 anyChar
+ eof
+ getState
+
parseAsOFL string = runParser parseOFL emptyOFL "(unknown)" string