From 7c0de6e3b280b4c89fec6859ca8b39227c3287f9 Mon Sep 17 00:00:00 2001
From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Sun, 16 Sep 2012 21:29:04 +0100
Subject: [PATCH] Parse output function specification.

---
 src/HighLevel.hs     | 12 +++++++++---
 src/Parser.hs        | 24 +++++++++++++++++++++++-
 src/TargetMapping.hs | 17 +++++++++++++----
 3 files changed, 45 insertions(+), 8 deletions(-)

diff --git a/src/HighLevel.hs b/src/HighLevel.hs
index a1bbd00..5f46280 100644
--- a/src/HighLevel.hs
+++ b/src/HighLevel.hs
@@ -40,11 +40,12 @@ type MappingTable = Map String TargetType
 data OFL = OFL {
   symbols :: SymbolTable,
   assignments :: [Assignment],
-  targetMappings :: MappingTable
+  targetMappings :: MappingTable,
+  outputFunction :: FortranFunction
 }
 
 toDoc :: OFL -> Doc
-toDoc ofl = symbolDoc $$ assignmentsDoc $$ targetMappingsDoc
+toDoc ofl = symbolDoc $$ assignmentsDoc $$ targetMappingsDoc $$ outputFunctionDoc
   where
   symbolDoc = text "Symbol table:"
     $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [text $ show x | x <- assocs $ symbols ofl])
@@ -52,6 +53,8 @@ toDoc ofl = symbolDoc $$ assignmentsDoc $$ targetMappingsDoc
     $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [text $ show x | x <- assignments ofl])
   targetMappingsDoc = text "Target properties: "
     $$ nest 1 (foldl' ($$) Text.PrettyPrint.empty [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
@@ -76,6 +79,9 @@ addAssignment ofl lhs rhs =
     Right () -> ofl { assignments = (Assign lhs rhs):(assignments ofl) } 
     Left reason -> error $ show reason
 
+setOutputFunction :: OFL -> FortranFunction -> OFL
+setOutputFunction ofl function = ofl { outputFunction = function }
+
 errorOnDuplicate :: Show k => k -> a -> a -> a
 errorOnDuplicate key _ _ = error $ "Attempted redefinition of symbol " ++ show key
 
@@ -128,7 +134,7 @@ 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 }
+emptyOFL = OFL { assignments = [], symbols = Map.empty, targetMappings = Map.empty, outputFunction = undefined}
 
 -- Validation
 data ValidationError = Message String deriving Show
diff --git a/src/Parser.hs b/src/Parser.hs
index 68937ed..4ca63d3 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -129,10 +129,32 @@ parseOFL = do
   _ <- many1 parseAssignment
   _ <- parseTarget
   _ <- many parseBinding
-  _ <- many anyChar
+  _ <- parseOutputFunction
   eof
   getState
 
+parseOutputFunction = do
+  _ <- lSymbol "OutputFunction"
+  ident <- parseIdentifier
+  _ <- lSymbol "="
+  _ <- lSymbol "fortran_function"
+  _ <- lSymbol "with"
+  properties <- lCommaSep parseFortranFunctionProperty
+  modifyState(\x -> setOutputFunction x $ FortranFunction ident properties)
+  <?> "output function specification"
+
+parseFortranFunctionProperty = do
+  parseFortranFunctionNameProperty <|> parseFortranFunctionParamsProperty
+  where
+  parseFortranFunctionNameProperty = do 
+    _ <- lSymbol "name"
+    name <- lParens lStringLiteral
+    return $ FortranFunctionName name
+  parseFortranFunctionParamsProperty = do 
+    _ <- lSymbol "params"
+    idents <- lParens $ lCommaSep lIdentifier
+    return $ FortranFunctionParams idents
+
 parseBinding = do
   _ <- lSymbol "Variable" <|> lSymbol "Parameter"
   ident <- parseIdentifier
diff --git a/src/TargetMapping.hs b/src/TargetMapping.hs
index 5669283..6fc4b03 100644
--- a/src/TargetMapping.hs
+++ b/src/TargetMapping.hs
@@ -1,8 +1,8 @@
 module TargetMapping where
 
 data TargetType = 
-  FortranParameter [FortranParameterProperties] |
-  PPDFunctionSet [PPDFunctionSetProperties]
+  FortranParameter [FortranParameterProperty] |
+  PPDFunctionSet [PPDFunctionSetProperty]
   deriving Show
 
 data FortranType = 
@@ -23,14 +23,23 @@ data SpaceInfo =
   FinePsinc [String]
   deriving Show
 
-data FortranParameterProperties =
+data FortranParameterProperty =
   ParamName String |
   ParamType FortranType |
   Space SpaceInfo |
   Indexed [String]
   deriving Show
 
-data PPDFunctionSetProperties =
+data PPDFunctionSetProperty =
   PPDData String |
   PPDBasis String
   deriving Show
+
+data FortranFunction =
+  FortranFunction String [FortranFunctionProperty]
+  deriving Show
+
+data FortranFunctionProperty =
+  FortranFunctionName String |
+  FortranFunctionParams [String]
+  deriving Show
-- 
2.47.3