From ecb82d13a88a0a2725a1be788438ecb5612e2ccd Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Thu, 20 Mar 2008 16:20:14 +0000 Subject: [PATCH] Revamped the ShowCode module, transforming it to use the writer monad --- checks/ArrayUsageCheckTest.hs | 3 +- checks/UsageCheckUtils.hs | 14 +- common/ShowCode.hs | 527 ++++++++++++++++++---------------- 3 files changed, 289 insertions(+), 255 deletions(-) diff --git a/checks/ArrayUsageCheckTest.hs b/checks/ArrayUsageCheckTest.hs index 47e2b68..9884637 100644 --- a/checks/ArrayUsageCheckTest.hs +++ b/checks/ArrayUsageCheckTest.hs @@ -20,6 +20,7 @@ module ArrayUsageCheckTest (ioqcTests) where import Control.Monad.Identity import Control.Monad.State +import Control.Monad.Writer (tell) import Data.Array.IArray import Data.List import qualified Data.Map as Map @@ -894,7 +895,7 @@ translateEquations mp (eq,ineq) ++ " value beforehand was: " ++ show x ++ " mapping was: " ++ show mp instance (ShowOccam a, Show b) => ShowOccam (a,b) where - showOccamM (x,y) = showOccamM x >>* (++ show y) + showOccamM (x,y) = showOccamM x >> tell [show y] type Problem = (((A.Expression, [ModuloCase]), (A.Expression, [ModuloCase])), VarMap, (EqualityProblem, InequalityProblem)) diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index 74f0cfd..bd08560 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -18,6 +18,7 @@ with this program. If not, see . module UsageCheckUtils (Decl(..), emptyVars, flattenParItems, foldUnionVars, getVarActual, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where +import Control.Monad.Writer (tell) import Data.Generics hiding (GT) import Data.List import Data.Maybe @@ -41,14 +42,19 @@ instance Ord Var where instance ShowOccam Var where showOccamM (Var v) = showOccamM v instance ShowRain Var where - showRain (Var v) = showRain v + showRainM (Var v) = showRainM v instance ShowOccam (Set.Set Var) where showOccamM s - = do ss <- mapM showOccamM (Set.toList s) - return $ "{" ++ concat (intersperse ", " ss) ++ "}" + = do tell ["{"] + sequence $ intersperse (tell [", "]) $ map showOccamM (Set.toList s) + tell ["}"] instance ShowRain (Set.Set Var) where - showRain s = "{" ++ concat (intersperse ", " $ map showRain $ Set.toList s) ++ "}" + showRainM s + = do tell ["{"] + sequence $ intersperse (tell [", "]) $ map showRainM (Set.toList s) + tell ["}"] + data Vars = Vars { readVars :: Set.Set Var diff --git a/common/ShowCode.hs b/common/ShowCode.hs index e904536..8a54760 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -31,9 +31,10 @@ with this program. If not, see . -- My plan for testing was to take each of the cgtests, and parse it in to AST_A. Then print AST_A using this -- module, and feed it back in to the parser to get AST_B. Then check if AST_A and AST_B are equal. -module ShowCode (showCode, ShowOccam(..), showOccam, ShowRain(..), formatCode, extCode) where +module ShowCode (showCode, ShowOccam(..), showOccam, ShowRain(..), showRain, formatCode, extCode) where import Control.Monad.State +import Control.Monad.Writer import Data.Generics import Data.List import qualified Data.Map as Map @@ -42,114 +43,135 @@ import Text.Regex import qualified AST as A import CompState hiding (CSM) -- everything here is read-only +import Utils -data ShowOccamState = ShowOccamState { - indentLevel :: Int, -- The indent level in spaces (add two for each indent) +data ShowCodeState = ShowCodeState { + indentLevel :: Int, -- The indent level in spaces (add two for each + -- indent in occam, four in rain) outerItem :: [String], -- What we are currently inside for Structureds, e.g. "IF" or "SEQ". Use the head of the list - useOriginalName :: Bool, -- Whether to use the original proc names + useOriginalName :: Bool, -- Whether to use the original names realCode :: Bool, -- Whether to leave out all helpful hints (e.g. {protocol} on Protocols) originalNames :: Map.Map String String, suppressNextIndent :: Bool, -- Used to pass down variables for input modes, or for subscripts: - tempItem :: OccamWriter String + tempItem :: CodeWriter () } ---TODO use the Writer monad instead, with StateT -type OccamWriter a = State ShowOccamState a +type CodeWriter a = StateT ShowCodeState (Writer [String]) a -initialShowOccamState :: Map.Map String String -> ShowOccamState -initialShowOccamState origNames = ShowOccamState {indentLevel = 0, outerItem = [], useOriginalName = True, realCode = True, - originalNames = origNames,suppressNextIndent = False, tempItem = return ""} +initialShowCodeState :: Map.Map String String -> ShowCodeState +initialShowCodeState origNames = ShowCodeState + {indentLevel = 0, outerItem = [], useOriginalName = True, realCode = True, + originalNames = origNames,suppressNextIndent = False, tempItem = return ()} -showInputModeOccamM :: A.Variable -> A.InputMode -> OccamWriter String +showInputModeOccamM :: A.Variable -> A.InputMode -> CodeWriter () showInputModeOccamM v im = do modify (\s -> s {tempItem = showOccamM v}) showOccamM im -showSubscriptOccamM :: ShowOccam a => a -> A.Subscript -> OccamWriter String +showSubscriptOccamM :: ShowOccam a => a -> A.Subscript -> CodeWriter () showSubscriptOccamM arr s = do modify (\s -> s {tempItem = showOccamM arr}) showOccamM s -suppressIndent :: OccamWriter String +suppressIndent :: CodeWriter () suppressIndent = do st <- get put (st {suppressNextIndent = True}) - return "" -showOccamLine :: OccamWriter String -> OccamWriter String +showOccamLine :: CodeWriter () -> CodeWriter () showOccamLine s = do st <- get - (if (suppressNextIndent st) + if (suppressNextIndent st) then do put (st {suppressNextIndent = False}) - return "" - else return (replicate (indentLevel st) ' ') - ) +>> s +>> return "\n" + else tell [replicate (indentLevel st) ' '] + s + tell ["\n"] +showRainLine :: CodeWriter () -> CodeWriter () +showRainLine s = do st <- get + tell [replicate (indentLevel st) ' '] + s + tell ["\n"] -occamIndent :: OccamWriter String +occamIndent :: CodeWriter () occamIndent = do st <- get put (st { indentLevel = (indentLevel st) + 2} ) - return "" -occamOutdent :: OccamWriter String + +occamOutdent :: CodeWriter () occamOutdent = do st <- get put (st { indentLevel = (indentLevel st) - 2} ) - return "" -occamBlock :: OccamWriter String -> OccamWriter String -occamBlock s = occamIndent +>> s +>> occamOutdent +occamBlock :: CodeWriter () -> CodeWriter () +occamBlock s = occamIndent >> s >> occamOutdent -showName :: A.Name -> OccamWriter String +rainIndent :: CodeWriter () +rainIndent = do st <- get + put (st { indentLevel = (indentLevel st) + 4} ) + +rainOutdent :: CodeWriter () +rainOutdent = do st <- get + put (st { indentLevel = (indentLevel st) - 4} ) + +rainBlock :: CodeWriter () -> CodeWriter () +rainBlock s = rainIndent >> s >> rainOutdent + + +showName :: A.Name -> CodeWriter () showName n = do st <- get - return $ if useOriginalName st then Map.findWithDefault k k (originalNames st) else k + tell [if useOriginalName st then Map.findWithDefault k k (originalNames st) else k] where k = A.nameName n -helper :: String -> OccamWriter String +-- | Displays helper tags, as long as realCode isn't True +helper :: String -> CodeWriter () helper s = do st <- get - return $ if (realCode st) then "" else s + tell $ singleton $ if (realCode st) then "" else s -currentContext :: OccamWriter String +currentContext :: CodeWriter String currentContext = get >>= (return . head . outerItem) -pushContext :: String -> OccamWriter String +pushContext :: String -> CodeWriter String pushContext x = do st <- get put (st {outerItem = (x:(outerItem st))}) return "" -beginStr :: String -> OccamWriter String +beginStr :: String -> CodeWriter () beginStr n = pushContext n >> occamIndent -endStr :: OccamWriter String +endStr :: CodeWriter () endStr = popContext >> occamOutdent -popContext :: OccamWriter String +popContext :: CodeWriter () popContext = do st <- get put (st {outerItem = tail (outerItem st)}) - return "" -doStr :: String -> OccamWriter String -> OccamWriter String -doStr n s = showOccamLine (return n) +>> (beginStr n) +>> s +>> endStr +doStr :: String -> CodeWriter () -> CodeWriter () +doStr n s = showOccamLine (tell [n]) >> (beginStr n) >> s >> endStr ---TODO remove this function? Or at least rename it +--TODO remove these functions? Or at least rename them showOccam :: ShowOccam a => a -> String -showOccam x = evalState (showOccamM x) (initialShowOccamState Map.empty) +showOccam x = concat $ snd $ runWriter $ evalStateT (showOccamM x) (initialShowCodeState Map.empty) -bracket :: OccamWriter String -> OccamWriter String -bracket x = return "(" +>> x +>> return ")" +showRain :: ShowRain a => a -> String +showRain x = concat $ snd $ runWriter $ evalStateT (showRainM x) (initialShowCodeState Map.empty) + + +bracket :: MonadWriter [String] m => m () -> m () +bracket x = tell ["("] >> x >> tell [")"] -- | A type-class that indicates that the data (AST item) is displayable as occam code. class ShowOccam a where --- showOccam :: a -> String --- showOccam = const "" - showOccamM :: a -> OccamWriter String + showOccamM :: a -> CodeWriter () -- | A type-class that indicates that the data (AST item) is displayable as Rain code. class ShowRain a where - showRain :: a -> String + showRainM :: a -> CodeWriter () -- | Shows the given code (AST item) as either occam or Rain code, depending on which frontend was selected showCode :: (CSMR m, ShowOccam a, ShowRain a) => a -> m String showCode o = do st <- getCompState case csFrontend st of - FrontendOccam -> return $ evalState (showOccamM o) (initialShowOccamState $ transformNames $ csNames st) - FrontendRain -> return $ showRain o + FrontendOccam -> return $ concat $ snd $ runWriter $ evalStateT (showOccamM o) + (initialShowCodeState $ transformNames $ csNames st) + FrontendRain -> return $ concat $ snd $ runWriter $ evalStateT (showRainM o) + (initialShowCodeState $ transformNames $ csNames st) where transformNames :: Map.Map String A.NameDef -> Map.Map String String transformNames = Map.map A.ndOrigName @@ -182,242 +204,250 @@ formatCode fmt = chain (splitRegex (mkRegex "%") fmt) [] --Type-class instances follow for ShowOccam and ShowRain: instance ShowOccam A.Type where - showOccamM A.Bool = return "BOOL" - showOccamM A.Byte = return "BYTE" - showOccamM A.UInt16 = return "UINT16" - showOccamM A.UInt32 = return "UINT32" - showOccamM A.UInt64 = return "UINT64" - showOccamM A.Int = return "INT" - showOccamM A.Int8 = return "INT8" - showOccamM A.Int16 = return "INT16" - showOccamM A.Int32 = return "INT32" - showOccamM A.Int64 = return "INT64" - showOccamM A.Real32 = return "REAL32" - showOccamM A.Real64 = return "REAL64" - showOccamM A.Any = return "ANY" - showOccamM A.Timer = return "TIMER" - showOccamM A.Time = return "TIME" + showOccamM A.Bool = tell ["BOOL"] + showOccamM A.Byte = tell ["BYTE"] + showOccamM A.UInt16 = tell ["UINT16"] + showOccamM A.UInt32 = tell ["UINT32"] + showOccamM A.UInt64 = tell ["UINT64"] + showOccamM A.Int = tell ["INT"] + showOccamM A.Int8 = tell ["INT8"] + showOccamM A.Int16 = tell ["INT16"] + showOccamM A.Int32 = tell ["INT32"] + showOccamM A.Int64 = tell ["INT64"] + showOccamM A.Real32 = tell ["REAL32"] + showOccamM A.Real64 = tell ["REAL64"] + showOccamM A.Any = tell ["ANY"] + showOccamM A.Timer = tell ["TIMER"] + showOccamM A.Time = tell ["TIME"] - showOccamM (A.Mobile t) = return "MOBILE " +>> showOccamM t + showOccamM (A.Mobile t) = tell ["MOBILE "] >> showOccamM t showOccamM (A.Array ds t) - = (liftM concat $ sequence dims) +>> showOccamM t + = (sequence dims) >> showOccamM t where dims = [case d of - A.Dimension n -> return "[" +>> showOccamM n +>> return "]" - A.UnknownDimension -> return "[]" + A.Dimension n -> tell ["["] >> showOccamM n >> tell ["]"] + A.UnknownDimension -> tell ["[]"] | d <- ds] - showOccamM (A.Chan _ _ t) = return "CHAN OF " +>> showOccamM t - showOccamM (A.Counted ct et) = showOccamM ct +>> return "::" +>> showOccamM et - showOccamM (A.Port t) = return "PORT OF " +>> showOccamM t - showOccamM (A.UserDataType n) = showName n +>> helper "{data type}" - showOccamM (A.Record n) = showName n +>> helper "{record}" - showOccamM (A.UserProtocol n) = showName n +>> helper "{protocol}" - showOccamM (A.List t) = return "LIST " +>> showOccamM t + showOccamM (A.Chan _ _ t) = tell ["CHAN OF "] >> showOccamM t + showOccamM (A.Counted ct et) = showOccamM ct >> tell ["::"] >> showOccamM et + showOccamM (A.Port t) = tell ["PORT OF "] >> showOccamM t + showOccamM (A.UserDataType n) = showName n >> helper "{data type}" + showOccamM (A.Record n) = showName n >> helper "{record}" + showOccamM (A.UserProtocol n) = showName n >> helper "{protocol}" + showOccamM (A.List t) = tell ["LIST "] >> showOccamM t instance ShowRain A.Type where - showRain A.Bool = "bool" - showRain A.Byte = "uint8" - showRain A.UInt16 = "uint16" - showRain A.UInt32 = "uint32" - showRain A.UInt64 = "uint64" - showRain A.Int8 = "sint8" - showRain A.Int16 = "sint16" - showRain A.Int32 = "sint32" - showRain A.Int64 = "int" - showRain A.Int = "int" - showRain (A.Chan dir attr t) + showRainM A.Bool = tell ["bool"] + showRainM A.Byte = tell ["uint8"] + showRainM A.UInt16 = tell ["uint16"] + showRainM A.UInt32 = tell ["uint32"] + showRainM A.UInt64 = tell ["uint64"] + showRainM A.Int8 = tell ["sint8"] + showRainM A.Int16 = tell ["sint16"] + showRainM A.Int32 = tell ["sint32"] + showRainM A.Int64 = tell ["int"] + showRainM A.Int = tell ["int"] + showRainM (A.Chan dir attr t) = case dir of - A.DirUnknown -> "channel " ++ ao (A.caWritingShared attr) ++ "2" ++ ao (A.caReadingShared attr) ++ " " ++ showRain t - A.DirInput -> (if A.caReadingShared attr then "shared" else "") ++ " ?" ++ showRain t - A.DirOutput -> (if A.caWritingShared attr then "shared" else "") ++ " !" ++ showRain t + A.DirUnknown -> tell ["channel ", ao (A.caWritingShared attr), + "2", ao (A.caReadingShared attr)," "] >> showRainM t + A.DirInput -> tell [if A.caReadingShared attr then "shared" else "", " ?"] >> showRainM t + A.DirOutput -> tell [if A.caWritingShared attr then "shared" else "", " !"] >> showRainM t where ao :: Bool -> String ao b = if b then "any" else "one" - showRain A.Time = "time" + showRainM A.Time = tell ["time"] -- Mobility is not explicit in Rain: - showRain (A.Mobile t) = showRain t - showRain (A.List t) = "[" ++ showRain t ++ "]" - showRain x = "" + showRainM (A.Mobile t) = showRainM t + showRainM (A.List t) = tell ["["] >> showRainM t >> tell ["]"] + showRainM x = tell [""] instance ShowOccam A.DyadicOp where - showOccamM A.Add = return "+" - showOccamM A.Subtr = return "-" - showOccamM A.Mul = return "*" - showOccamM A.Div = return "/" - showOccamM A.Rem = return "REM" - showOccamM A.Plus = return "PLUS" - showOccamM A.Minus = return "MINUS" - showOccamM A.Times = return "TIMES" - showOccamM A.BitAnd = return "/\\" - showOccamM A.BitOr = return "\\/" - showOccamM A.BitXor = return "><" - showOccamM A.LeftShift = return "<<" - showOccamM A.RightShift = return ">>" - showOccamM A.And = return "AND" - showOccamM A.Or = return "OR" - showOccamM A.Eq = return "=" - showOccamM A.NotEq = return "<>" - showOccamM A.Less = return "<" - showOccamM A.More = return ">" - showOccamM A.LessEq = return "<=" - showOccamM A.MoreEq = return ">=" - showOccamM A.After = return "AFTER" + showOccamM A.Add = tell ["+"] + showOccamM A.Subtr = tell ["-"] + showOccamM A.Mul = tell ["*"] + showOccamM A.Div = tell ["/"] + showOccamM A.Rem = tell ["REM"] + showOccamM A.Plus = tell ["PLUS"] + showOccamM A.Minus = tell ["MINUS"] + showOccamM A.Times = tell ["TIMES"] + showOccamM A.BitAnd = tell ["/\\"] + showOccamM A.BitOr = tell ["\\/"] + showOccamM A.BitXor = tell ["><"] + showOccamM A.LeftShift = tell ["<<"] + showOccamM A.RightShift = tell [">>"] + showOccamM A.And = tell ["AND"] + showOccamM A.Or = tell ["OR"] + showOccamM A.Eq = tell ["="] + showOccamM A.NotEq = tell ["<>"] + showOccamM A.Less = tell ["<"] + showOccamM A.More = tell [">"] + showOccamM A.LessEq = tell ["<="] + showOccamM A.MoreEq = tell [">="] + showOccamM A.After = tell ["AFTER"] instance ShowRain A.DyadicOp where - showRain A.Div = "/" - showRain A.Rem = "%" - showRain A.Plus = "+" - showRain A.Minus = "-" - showRain A.Times = "*" - showRain A.And = "and" - showRain A.Or = "or" - showRain A.Eq = "==" - showRain A.NotEq = "<>" - showRain A.Less = "<" - showRain A.More = ">" - showRain A.LessEq = "<=" - showRain A.MoreEq = ">=" - showRain x = "" + showRainM A.Div = tell ["/"] + showRainM A.Rem = tell ["%"] + showRainM A.Plus = tell ["+"] + showRainM A.Minus = tell ["-"] + showRainM A.Times = tell ["*"] + showRainM A.And = tell ["and"] + showRainM A.Or = tell ["or"] + showRainM A.Eq = tell ["=="] + showRainM A.NotEq = tell ["<>"] + showRainM A.Less = tell ["<"] + showRainM A.More = tell [">"] + showRainM A.LessEq = tell ["<="] + showRainM A.MoreEq = tell [">="] + showRainM x = tell [""] instance ShowOccam A.MonadicOp where - showOccamM A.MonadicSubtr = return "-" - showOccamM A.MonadicMinus = return "MINUS" - showOccamM A.MonadicBitNot = return "~" - showOccamM A.MonadicNot = return "NOT" + showOccamM A.MonadicSubtr = tell ["-"] + showOccamM A.MonadicMinus = tell ["MINUS"] + showOccamM A.MonadicBitNot = tell ["~"] + showOccamM A.MonadicNot = tell ["NOT"] instance ShowOccam A.Variable where showOccamM (A.Variable _ n) = showName n showOccamM (A.SubscriptedVariable _ s v) = showSubscriptOccamM v s showOccamM (A.DirectedVariable _ A.DirUnknown v) = showOccamM v - showOccamM (A.DirectedVariable _ A.DirInput v) = showOccamM v +>> return "?" - showOccamM (A.DirectedVariable _ A.DirOutput v) = showOccamM v +>> return "!" + showOccamM (A.DirectedVariable _ A.DirInput v) = showOccamM v >> tell ["?"] + showOccamM (A.DirectedVariable _ A.DirOutput v) = showOccamM v >> tell ["!"] instance ShowRain A.Variable where - showRain (A.Variable _ n) = show n - showRain (A.DirectedVariable _ A.DirInput v) = "?" ++ showRain v - showRain (A.DirectedVariable _ A.DirOutput v) = "!" ++ showRain v - showRain x = "" + showRainM (A.Variable _ n) = tell [show n] + showRainM (A.DirectedVariable _ A.DirInput v) = tell ["?"] >> showRainM v + showRainM (A.DirectedVariable _ A.DirOutput v) = tell ["!"] >> showRainM v + showRainM x = tell [""] instance ShowOccam A.ArrayElem where - showOccamM (A.ArrayElemArray elems) = return "[" +>> showWithCommas elems +>> return "]" + showOccamM (A.ArrayElemArray elems) = tell ["["] >> showWithCommas elems >> tell ["]"] showOccamM (A.ArrayElemExpr e) = showOccamM e instance ShowOccam A.LiteralRepr where - showOccamM (A.RealLiteral _ s) = return s - showOccamM (A.IntLiteral _ s) = return s - showOccamM (A.HexLiteral _ s) = return ("#" ++ s) - showOccamM (A.ByteLiteral _ s) = return ("'" ++ s ++ "'") - showOccamM (A.ArrayLiteral _ elems) = return "[" +>> showWithCommas elems +>> return "]" + showOccamM (A.RealLiteral _ s) = tell [s] + showOccamM (A.IntLiteral _ s) = tell [s] + showOccamM (A.HexLiteral _ s) = tell ["#", s] + showOccamM (A.ByteLiteral _ s) = tell ["'", s, "'"] + showOccamM (A.ArrayLiteral _ elems) = tell ["["] >> showWithCommas elems >> tell ["]"] --TODO record literals instance ShowOccam A.Subscript where - showOccamM (A.Subscript _ _ e) = getTempItem +>> return "[" +>> showOccamM e +>> return "]" - showOccamM (A.SubscriptField _ n) = getTempItem +>> return "[" +>> showName n +>> return "]" + showOccamM (A.Subscript _ _ e) = getTempItem >> tell ["["] >> showOccamM e >> tell ["]"] + showOccamM (A.SubscriptField _ n) = getTempItem >> tell ["["] >> showName n >> tell ["]"] showOccamM (A.SubscriptFromFor _ start count) - = return "[" +>> getTempItem +>> return " FROM " +>> showOccamM start +>> return " FOR " +>> showOccamM count +>> return "]" + = tell ["["] >> getTempItem >> tell [" FROM "] >> showOccamM start >> tell [" FOR "] >> showOccamM count >> tell ["]"] showOccamM (A.SubscriptFor _ count) - = return "[" +>> getTempItem +>> return " FOR " +>> showOccamM count +>> return "]" + = tell ["["] >> getTempItem >> tell [" FOR "] >> showOccamM count >> tell ["]"] showOccamM (A.SubscriptFrom _ start) - = return "[" +>> getTempItem +>> return " FROM " +>> showOccamM start +>> return "]" + = tell ["["] >> getTempItem >> tell [" FROM "] >> showOccamM start >> tell ["]"] -convOrSpace :: A.ConversionMode -> OccamWriter String +convOrSpace :: A.ConversionMode -> CodeWriter () convOrSpace A.DefaultConversion = space -convOrSpace A.Round = return " ROUND " -convOrSpace A.Trunc = return " TRUNC " +convOrSpace A.Round = tell [" ROUND "] +convOrSpace A.Trunc = tell [" TRUNC "] instance ShowOccam A.Expression where - showOccamM (A.Monadic _ op e) = bracket $ showOccamM op +>> space +>> showOccamM e - showOccamM (A.Dyadic _ op lhs rhs) = bracket $ showOccamM lhs +>> space +>> showOccamM op +>> space +>> showOccamM rhs - showOccamM (A.MostPos _ t) = bracket $ return "MOSTPOS " +>> showOccamM t - showOccamM (A.MostNeg _ t) = bracket $ return "MOSTNEG " +>> showOccamM t - showOccamM (A.SizeType _ t) = bracket $ return "SIZE " +>> showOccamM t - showOccamM (A.SizeExpr _ e) = bracket $ return "SIZE " +>> showOccamM e - showOccamM (A.SizeVariable _ v) = bracket $ return "SIZE " +>> showOccamM v - showOccamM (A.Conversion _ cm t e) = bracket $ showOccamM t +>> convOrSpace cm +>> showOccamM e + showOccamM (A.Monadic _ op e) = bracket $ showOccamM op >> space >> showOccamM e + showOccamM (A.Dyadic _ op lhs rhs) = bracket $ showOccamM lhs >> space >> showOccamM op >> space >> showOccamM rhs + showOccamM (A.MostPos _ t) = bracket $ tell ["MOSTPOS "] >> showOccamM t + showOccamM (A.MostNeg _ t) = bracket $ tell ["MOSTNEG "] >> showOccamM t + showOccamM (A.SizeType _ t) = bracket $ tell ["SIZE "] >> showOccamM t + showOccamM (A.SizeExpr _ e) = bracket $ tell ["SIZE "] >> showOccamM e + showOccamM (A.SizeVariable _ v) = bracket $ tell ["SIZE "] >> showOccamM v + showOccamM (A.Conversion _ cm t e) = bracket $ showOccamM t >> convOrSpace cm >> showOccamM e showOccamM (A.ExprVariable _ v) = showOccamM v showOccamM (A.Literal _ _ lit) = showOccamM lit - showOccamM (A.True _) = return "TRUE" - showOccamM (A.False _) = return "FALSE" - showOccamM (A.FunctionCall _ n es) = showName n +>> return "(" +>> showWithCommas es +>> return ")" + showOccamM (A.True _) = tell ["TRUE"] + showOccamM (A.False _) = tell ["FALSE"] + showOccamM (A.FunctionCall _ n es) = showName n >> tell ["("] >> showWithCommas es >> tell [")"] showOccamM (A.SubscriptedExpr _ s e) = showSubscriptOccamM e s - showOccamM (A.BytesInExpr _ e) = bracket $ return "BYTESIN " +>> showOccamM e - showOccamM (A.BytesInType _ t) = bracket $ return "BYTESIN " +>> showOccamM t - showOccamM (A.OffsetOf _ t n) = return "OFFSETOF(" +>> showOccamM t +>> return " , " +>> showName n +>> return ")" + showOccamM (A.BytesInExpr _ e) = bracket $ tell ["BYTESIN "] >> showOccamM e + showOccamM (A.BytesInType _ t) = bracket $ tell ["BYTESIN "] >> showOccamM t + showOccamM (A.OffsetOf _ t n) = tell ["OFFSETOF("] >> showOccamM t >> tell [" , "] >> showName n >> tell [")"] --TODO exprconstr instance ShowOccam A.Formal where showOccamM (A.Formal am t n) = (maybeVal am) - +>> (showOccamM t) - +>> space - +>> (showName n) + >> (showOccamM t) + >> space + >> (showName n) -space :: OccamWriter String -space = return " " +space :: CodeWriter () +space = tell [" "] -colon :: OccamWriter String -colon = return ":" +colon :: CodeWriter () +colon = tell [":"] -maybeVal :: A.AbbrevMode -> OccamWriter String -maybeVal am = return $ if (am == A.ValAbbrev) then "VAL " else "" +maybeVal :: A.AbbrevMode -> CodeWriter () +maybeVal am = tell [if (am == A.ValAbbrev) then "VAL " else ""] instance ShowOccam A.Specification where -- TODO add specmode to the output showOccamM (A.Specification _ n (A.Proc _ sm params body)) - = do n' <- showName n - params' <- showAll (intersperse (return ",") $ map showOccamM params) - --TODO use the occamdoc setting - showOccamLine (return $ "PROC " ++ n' ++ "(" ++ params' ++ ")") +>> occamIndent +>> showOccamM body +>> occamOutdent +>> showOccamLine (return ":") + = do let params' = intersperse (tell [","]) $ map showOccamM params + showOccamLine $ do tell ["PROC "] + showName n + tell ["("] + sequence_ params' + tell [")"] + occamIndent + showOccamM body + occamOutdent + showOccamLine (tell [":"]) showOccamM (A.Specification _ n (A.Declaration _ t)) - = showOccamLine $ showOccamM t +>> space +>> showName n +>> colon + = showOccamLine $ showOccamM t >> space >> showName n >> colon showOccamM (A.Specification _ n (A.Is _ am t v)) - = showOccamLine $ (maybeVal am) +>> showOccamM t +>> space +>> showName n +>> return " IS " +>> showOccamM v +>> colon + = showOccamLine $ (maybeVal am) >> showOccamM t >> space >> showName n >> tell [" IS "] >> showOccamM v >> colon showOccamM (A.Specification _ n (A.IsExpr _ am t e)) - = showOccamLine $ (maybeVal am) +>> showOccamM t +>> space +>> showName n +>> return " IS " +>> showOccamM e +>> colon + = showOccamLine $ (maybeVal am) >> showOccamM t >> space >> showName n >> tell [" IS "] >> showOccamM e >> colon showOccamM (A.Specification _ n (A.IsChannelArray _ t vs)) - = showOccamLine $ showOccamM t +>> space +>> showName n +>> return " IS [" +>> showWithCommas vs +>> return "]:" + = showOccamLine $ showOccamM t >> space >> showName n >> tell [" IS ["] >> showWithCommas vs >> tell ["]:"] showOccamM (A.Specification _ n (A.DataType _ t)) - = showOccamLine $ return "DATA TYPE " +>> showName n +>> return " IS " +>> showOccamM t +>> colon + = showOccamLine $ tell ["DATA TYPE "] >> showName n >> tell [" IS "] >> showOccamM t >> colon showOccamM (A.Specification _ n (A.RecordType _ packed fields)) - = (showOccamLine $ return "DATA TYPE " +>> showName n) - +>> occamIndent - +>> (showOccamLine $ return (if packed then "PACKED RECORD" else "RECORD")) - +>> occamIndent - +>> (showAll (map (\(n,t) -> showOccamLine $ showOccamM t +>> space +>> showName n +>> colon) fields)) - +>> occamOutdent - +>> occamOutdent - +>> (showOccamLine colon) + = do (showOccamLine $ tell ["DATA TYPE "] >> showName n) + occamIndent + (showOccamLine $ tell [if packed then "PACKED RECORD" else "RECORD"]) + occamIndent + (sequence_ (map (\(n,t) -> showOccamLine $ showOccamM t >> space >> showName n >> colon) fields)) + occamOutdent + occamOutdent + (showOccamLine colon) --TODO use the specmode showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left el@(A.Only {})))) = showOccamLine $ - showWithCommas retTypes +>> (return " FUNCTION ") +>> showName n +>> return "(" +>> showWithCommas params +>> return ")" - +>> return " IS " +>> showOccamM el +>> colon + showWithCommas retTypes >> (tell [" FUNCTION "]) >> showName n >> tell ["("] >> showWithCommas params >> tell [")"] + >> tell [" IS "] >> showOccamM el >> colon showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left body))) - = (showOccamLine $ showWithCommas retTypes +>> (return " FUNCTION ") +>> showName n +>> return "(" +>> showWithCommas params +>> return ")") - +>> occamIndent - +>> showOccamM body - +>> occamOutdent - +>> showOccamLine colon + = (showOccamLine $ showWithCommas retTypes >> (tell [" FUNCTION "]) >> showName n >> tell ["("] >> showWithCommas params >> tell [")"]) + >> occamIndent + >> showOccamM body + >> occamOutdent + >> showOccamLine colon showOccamM (A.Specification _ n (A.Protocol _ ts)) - = showOccamLine $ return "PROTOCOL " +>> showName n +>> return " IS " +>> showWithSemis ts +>> colon + = showOccamLine $ tell ["PROTOCOL "] >> showName n >> tell [" IS "] >> showWithSemis ts >> colon showOccamM (A.Specification _ n (A.ProtocolCase _ nts)) - = (showOccamLine $ return "PROTOCOL " +>> showName n) +>> occamBlock - (showOccamLine (return "CASE") +>> occamBlock - (showAll $ map (showOccamLine . showProtocolItem) nts) - ) +>> colon + = (showOccamLine $ tell ["PROTOCOL "] >> showName n) >> occamBlock + (showOccamLine (tell ["CASE"]) >> occamBlock + (sequence_ $ map (showOccamLine . showProtocolItem) nts) + ) >> colon showOccamM (A.Specification _ n (A.Retypes _ am t v)) - = showOccamLine $ maybeVal am +>> showOccamM t +>> space +>> showName n +>> return " RETYPES " +>> showOccamM v +>> colon + = showOccamLine $ maybeVal am >> showOccamM t >> space >> showName n >> tell [" RETYPES "] >> showOccamM v >> colon showOccamM (A.Specification _ n (A.RetypesExpr _ am t e)) - = showOccamLine $ maybeVal am +>> showOccamM t +>> space +>> showName n +>> return " RETYPES " +>> showOccamM e +>> colon + = showOccamLine $ maybeVal am >> showOccamM t >> space >> showName n >> tell [" RETYPES "] >> showOccamM e >> colon -showProtocolItem :: (A.Name, [A.Type]) -> OccamWriter String -showProtocolItem (n,ts) = showAll $ intersperse (return " ; ") $ [showName n] ++ (map showOccamM ts) +showProtocolItem :: (A.Name, [A.Type]) -> CodeWriter () +showProtocolItem (n,ts) = sequence_ $ intersperse (tell [" ; "]) $ + showName n : (map showOccamM ts) instance ShowOccam A.Variant where showOccamM (A.Variant _ n iis p) - = (showOccamLine (showAll $ intersperse (return " ; ") $ [showName n] ++ (map showOccamM iis))) - +>> occamIndent +>> showOccamM p +>> occamOutdent + = (showOccamLine (sequence_ $ intersperse (tell [" ; "]) $ [showName n] ++ (map showOccamM iis))) + >> occamIndent >> showOccamM p >> occamOutdent instance ShowOccam A.Actual where showOccamM (A.ActualVariable _ _ v) = showOccamM v @@ -425,78 +455,82 @@ instance ShowOccam A.Actual where instance ShowOccam A.OutputItem where showOccamM (A.OutExpression _ e) = showOccamM e - showOccamM (A.OutCounted _ ce ae) = showOccamM ce +>> return " :: " +>> showOccamM ae + showOccamM (A.OutCounted _ ce ae) = showOccamM ce >> tell [" :: "] >> showOccamM ae -getTempItem :: OccamWriter String +getTempItem :: CodeWriter () getTempItem = get >>= tempItem instance ShowOccam A.InputItem where showOccamM (A.InVariable _ v) = showOccamM v - showOccamM (A.InCounted _ cv av) = showOccamM cv +>> return " :: " +>> showOccamM av + showOccamM (A.InCounted _ cv av) = showOccamM cv >> tell [" :: "] >> showOccamM av instance ShowOccam A.InputMode where showOccamM (A.InputSimple _ iis) - = showOccamLine $ getTempItem +>> return " ? " +>> (showWithSemis iis) + = showOccamLine $ getTempItem >> tell [" ? "] >> (showWithSemis iis) showOccamM (A.InputCase _ str) - = (showOccamLine $ getTempItem +>> return " ? CASE") +>> occamIndent +>> showOccamM str +>> occamOutdent + = (showOccamLine $ getTempItem >> tell [" ? CASE"]) >> occamIndent >> showOccamM str >> occamOutdent showOccamM (A.InputTimerRead _ ii) - = showOccamLine $ getTempItem +>> return " ? " +>> showOccamM ii + = showOccamLine $ getTempItem >> tell [" ? "] >> showOccamM ii showOccamM (A.InputTimerAfter _ e) - = showOccamLine $ getTempItem +>> return " ? AFTER " +>> showOccamM e + = showOccamLine $ getTempItem >> tell [" ? AFTER "] >> showOccamM e instance ShowOccam A.Alternative where - showOccamM (A.Alternative _ v im p) = showInputModeOccamM v im +>> occamIndent +>> showOccamM p +>> occamOutdent - showOccamM (A.AlternativeCond _ e v im p) = showOccamM e +>> return " & " +>> suppressIndent +>> showOccamM (A.Alternative undefined v im p) + showOccamM (A.Alternative _ v im p) = showInputModeOccamM v im >> occamIndent >> showOccamM p >> occamOutdent + showOccamM (A.AlternativeCond _ e v im p) = showOccamM e >> tell [" & "] >> suppressIndent >> showOccamM (A.Alternative undefined v im p) instance ShowOccam A.Replicator where - showOccamM (A.For _ n start count) = return " " +>> showName n +>> return " = " +>> showOccamM start +>> return " FOR " +>> showOccamM count - showOccamM (A.ForEach _ n e) = return " " +>> showName n +>> return " IN " +>> showOccamM e + showOccamM (A.For _ n start count) = tell [" "] >> showName n >> tell [" = "] >> showOccamM start >> tell [" FOR "] >> showOccamM count + showOccamM (A.ForEach _ n e) = tell [" "] >> showName n >> tell [" IN "] >> showOccamM e instance ShowOccam A.Choice where - showOccamM (A.Choice _ e p) = showOccamLine (showOccamM e) +>> occamBlock (showOccamM p) + showOccamM (A.Choice _ e p) = showOccamLine (showOccamM e) >> occamBlock (showOccamM p) instance ShowOccam A.Option where - showOccamM (A.Option _ es p) = showOccamLine (showAll $ intersperse (return " , ") $ map showOccamM es) +>> occamBlock (showOccamM p) - showOccamM (A.Else _ p) = showOccamLine (return "ELSE") +>> occamBlock (showOccamM p) + showOccamM (A.Option _ es p) = showOccamLine (sequence_ $ intersperse (tell [" , "]) $ map showOccamM es) >> occamBlock (showOccamM p) + showOccamM (A.Else _ p) = showOccamLine (tell ["ELSE"]) >> occamBlock (showOccamM p) instance (Data a, ShowOccam a) => ShowOccam (A.Structured a) where - showOccamM (A.Spec _ spec str) = showOccamM spec +>> showOccamM str + showOccamM (A.Spec _ spec str) = showOccamM spec >> showOccamM str showOccamM (A.Rep _ rep str) = do item <- currentContext - (showOccamLine (return (item ++ " ") +>> showOccamM rep)) +>> occamIndent +>> showOccamM str +>> occamOutdent + (showOccamLine (return (item ++ " ") >> showOccamM rep)) >> occamIndent >> showOccamM str >> occamOutdent showOccamM (A.Only _ p) = showOccamM p - showOccamM (A.Several _ ss) = showAll $ map showOccamM ss - showOccamM (A.ProcThen _ p str) = showOccamLine (return "VALOF") +>> occamBlock (showOccamM p +>> showOccamLine (return "RESULT " +>> showOccamM str)) + showOccamM (A.Several _ ss) = sequence_ $ map showOccamM ss + showOccamM (A.ProcThen _ p str) = showOccamLine (tell ["VALOF"]) >> occamBlock (showOccamM p >> showOccamLine (tell ["RESULT "] >> showOccamM str)) -showWithCommas :: ShowOccam a => [a] -> OccamWriter String -showWithCommas ss = showAll $ intersperse (return " , ") $ map showOccamM ss +showWithCommas :: ShowOccam a => [a] -> CodeWriter () +showWithCommas ss = sequence_ $ intersperse (tell [" , "]) $ map showOccamM ss -showWithSemis :: ShowOccam a => [a] -> OccamWriter String -showWithSemis ss = showAll $ intersperse (return " ; ") $ map showOccamM ss +showWithSemis :: ShowOccam a => [a] -> CodeWriter () +showWithSemis ss = sequence_ $ intersperse (tell [" ; "]) $ map showOccamM ss instance ShowOccam A.ExpressionList where showOccamM (A.ExpressionList _ es) = showWithCommas es --TODO functioncalllist -outer :: (Data a, ShowOccam a) => String -> A.Structured a -> OccamWriter String -outer keyword (A.Rep _ rep str) = showOccamLine (return keyword +>> showOccamM rep) +>> beginStr keyword +>> showOccamM str +>> endStr +outer :: (Data a, ShowOccam a) => String -> A.Structured a -> CodeWriter () +outer keyword (A.Rep _ rep str) + = do showOccamLine (tell [keyword] >> showOccamM rep) + beginStr keyword + showOccamM str + endStr outer keyword str = doStr keyword (showOccamM str) instance ShowOccam A.Process where - showOccamM (A.Assign _ vs el) = showOccamLine (showWithCommas vs +>> return ":=" +>> showOccamM el) - showOccamM (A.Skip _) = showOccamLine $ return "SKIP" - showOccamM (A.Stop _) = showOccamLine $ return "STOP" + showOccamM (A.Assign _ vs el) = showOccamLine (showWithCommas vs >> tell [":="] >> showOccamM el) + showOccamM (A.Skip _) = showOccamLine $ tell ["SKIP"] + showOccamM (A.Stop _) = showOccamLine $ tell ["STOP"] showOccamM (A.Input _ v im) = showInputModeOccamM v im - showOccamM (A.Output _ v ois) = showOccamLine $ showOccamM v +>> return " ! " +>> (showWithSemis ois) - showOccamM (A.OutputCase _ v n ois) = showOccamLine $ showOccamM v +>> return " ! " +>> - (showAll $ intersperse (return " ; ") $ [showName n] ++ (map showOccamM ois)) + showOccamM (A.Output _ v ois) = showOccamLine $ showOccamM v >> tell [" ! "] >> (showWithSemis ois) + showOccamM (A.OutputCase _ v n ois) = showOccamLine $ showOccamM v >> tell [" ! "] >> + (sequence_ $ intersperse (tell [" ; "]) $ [showName n] ++ (map showOccamM ois)) --TODO gettime and wait ? --TODO proccall - showOccamM (A.ProcCall _ n params) = showOccamLine $ showName n +>> return " ( " +>> showWithCommas params +>> return " ) " - showOccamM (A.While _ e p) = (showOccamLine $ return "WHILE " +>> showOccamM e) +>> occamIndent +>> showOccamM p +>> occamOutdent - showOccamM (A.Case _ e s) = (showOccamLine $ return "CASE " +>> showOccamM e) +>> occamBlock (showOccamM s) + showOccamM (A.ProcCall _ n params) = showOccamLine $ showName n >> tell [" ( "] >> showWithCommas params >> tell [" ) "] + showOccamM (A.While _ e p) = (showOccamLine $ tell ["WHILE "] >> showOccamM e) >> occamIndent >> showOccamM p >> occamOutdent + showOccamM (A.Case _ e s) = (showOccamLine $ tell ["CASE "] >> showOccamM e) >> occamBlock (showOccamM s) showOccamM (A.If _ str) = outer "IF" str showOccamM (A.Alt _ False str) = outer "ALT" str showOccamM (A.Alt _ True str) = outer "PRI ALT" str @@ -508,7 +542,7 @@ instance ShowOccam A.Process where --TEMP: instance ShowRain a where - showRain = const "" + showRainM = const $ return () -- | Extends an existing (probably generic) function with cases for everything that has a specific ShowOccam and ShowRain instance -- This is a bit of manual wiring. Because we can't generically deduce whether or not @@ -532,10 +566,3 @@ extCode q f = q --TODO -- `ext1Q` (text . (f :: (Data c, ShowOccam c) => A.Structured c -> String)) -(+>>) :: State s [a] -> State s [a] -> State s [a] -(+>>) x y = do x' <- x - y' <- y - return (x' ++ y') - -showAll :: [State s [a]] -> State s [a] -showAll = foldl (+>>) (return [])