suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Include metadata in the AST

Browse Source
This commit is contained in:
Adam Sampson 2006-10-18 17:09:35 +00:00
parent 996f64702a
commit f7114b6c84
6 changed files with 294 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
fco/AST.hs
View File

@ -5,11 +5,12 @@
module AST where module AST where
import Data.Generics import Data.Generics
import Metadata
data Name = Name String data Name = Name Meta String
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Tag = Tag String data Tag = Tag Meta String
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Type = data Type =
@ -26,7 +27,7 @@ data Type =
| Timer | Timer
| Port Type | Port Type
| Val Type | Val Type
| Infer -- for where the type is not given but can be worked out (e.g. "x IS y:") | Infer -- for where the type is not given but can be worked out (e.g. "x IS y:")
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data ConversionMode = data ConversionMode =
@ -36,51 +37,51 @@ data ConversionMode =
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Subscript = data Subscript =
Subscript Expression Subscript Meta Expression
| SubscriptTag Tag | SubscriptTag Meta Tag
| SubFromFor Expression Expression | SubFromFor Meta Expression Expression
| SubFrom Expression | SubFrom Meta Expression
| SubFor Expression | SubFor Meta Expression
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data LiteralRepr = data LiteralRepr =
RealLiteral String RealLiteral Meta String
| IntLiteral String | IntLiteral Meta String
| HexLiteral String | HexLiteral Meta String
| ByteLiteral String | ByteLiteral Meta String
| StringLiteral String | StringLiteral Meta String
| ArrayLiteral [Expression] | ArrayLiteral Meta [Expression]
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Literal = data Literal =
Literal Type LiteralRepr Literal Meta Type LiteralRepr
| SubscriptedLiteral Subscript Literal | SubscriptedLiteral Meta Subscript Literal
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Variable = data Variable =
Variable Name Variable Meta Name
| SubscriptedVariable Subscript Variable | SubscriptedVariable Meta Subscript Variable
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Expression = data Expression =
Monadic MonadicOp Expression Monadic Meta MonadicOp Expression
| Dyadic DyadicOp Expression Expression | Dyadic Meta DyadicOp Expression Expression
| MostPos Type | MostPos Meta Type
| MostNeg Type | MostNeg Meta Type
| Size Type | Size Meta Type
| Conversion ConversionMode Type Expression | Conversion Meta ConversionMode Type Expression
| ExprVariable Variable | ExprVariable Meta Variable
| ExprLiteral Literal | ExprLiteral Meta Literal
| True | True Meta
| False | False Meta
| FunctionCall Name [Expression] | FunctionCall Meta Name [Expression]
| BytesInType Type | BytesInType Meta Type
| OffsetOf Type Tag | OffsetOf Meta Type Tag
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data ExpressionList = data ExpressionList =
FunctionCallList Name [Expression] FunctionCallList Meta Name [Expression]
| ExpressionList [Expression] | ExpressionList Meta [Expression]
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data MonadicOp = data MonadicOp =
@ -101,99 +102,98 @@ data DyadicOp =
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data InputItem = data InputItem =
InCounted Variable Variable InCounted Meta Variable Variable
| InVariable Variable | InVariable Meta Variable
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data OutputItem = data OutputItem =
OutCounted Expression Expression OutCounted Meta Expression Expression
| OutExpression Expression | OutExpression Meta Expression
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Replicator = For Name Expression Expression data Replicator = For Meta Name Expression Expression
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Choice = Choice Expression Process data Choice = Choice Meta Expression Process
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Alternative = data Alternative =
Alternative Variable InputMode Process Alternative Meta Variable InputMode Process
| AlternativeCond Expression Variable InputMode Process | AlternativeCond Meta Expression Variable InputMode Process
| AlternativeSkip Expression Process | AlternativeSkip Meta Expression Process
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Option = data Option =
Option [Expression] Process Option Meta [Expression] Process
| Else Process | Else Meta Process
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Variant = Variant Tag [InputItem] Process data Variant = Variant Meta Tag [InputItem] Process
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
-- This represents something that can contain local replicators and specifications. -- This represents something that can contain local replicators and specifications.
-- (This ought to be a parametric type, "Structured Variant" etc., but doing so -- (This ought to be a parametric type, "Structured Variant" etc., but doing so
-- makes using generic functions across it hard.) -- makes using generic functions across it hard.)
data Structured = data Structured =
Rep Replicator Structured Rep Meta Replicator Structured
| Spec Specification Structured | Spec Meta Specification Structured
| OnlyV Variant | OnlyV Meta Variant
| OnlyC Choice | OnlyC Meta Choice
| OnlyO Option | OnlyO Meta Option
| OnlyP Process | OnlyP Meta Process
| OnlyA Alternative | OnlyA Meta Alternative
| Several [Structured] | Several Meta [Structured]
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data InputMode = data InputMode =
InputSimple [InputItem] InputSimple Meta [InputItem]
| InputCase Structured | InputCase Meta Structured
| InputAfter Expression | InputAfter Meta Expression
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
type Formals = [(Type, Name)] type Formals = [(Type, Name)]
type Specification = (Name, SpecType) type Specification = (Name, SpecType)
data SpecType = data SpecType =
Place Expression Place Meta Expression
| Declaration Type | Declaration Meta Type
| Is Type Variable | Is Meta Type Variable
| ValIs Type Expression | ValIs Meta Type Expression
| DataTypeIs Type | DataTypeIs Meta Type
| DataTypeRecord Bool [(Type, Tag)] | DataTypeRecord Meta Bool [(Type, Tag)]
| ProtocolIs [Type] | ProtocolIs Meta [Type]
| ProtocolCase [(Tag, [Type])] | ProtocolCase Meta [(Tag, [Type])]
| Proc Formals Process | Proc Meta Formals Process
| Function [Type] Formals ValueProcess | Function Meta [Type] Formals ValueProcess
| Retypes Type Variable | Retypes Meta Type Variable
| Reshapes Type Variable | Reshapes Meta Type Variable
| ValRetypes Type Variable | ValRetypes Meta Type Variable
| ValReshapes Type Variable | ValReshapes Meta Type Variable
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data ValueProcess = data ValueProcess =
ValOfSpec Specification ValueProcess ValOfSpec Meta Specification ValueProcess
| ValOf Process ExpressionList | ValOf Meta Process ExpressionList
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data Process = data Process =
ProcSpec Specification Process ProcSpec Meta Specification Process
| Assign [Variable] ExpressionList | Assign Meta [Variable] ExpressionList
| Input Variable InputMode | Input Meta Variable InputMode
| Output Variable [OutputItem] | Output Meta Variable [OutputItem]
| OutputCase Variable Tag [OutputItem] | OutputCase Meta Variable Tag [OutputItem]
| Skip | Skip Meta
| Stop | Stop Meta
| Main | Main Meta
| Seq [Process] | Seq Meta [Process]
| SeqRep Replicator Process | SeqRep Meta Replicator Process
| If Structured | If Meta Structured
| Case Expression Structured | Case Meta Expression Structured
| While Expression Process | While Meta Expression Process
| Par Bool [Process] | Par Meta Bool [Process]
| ParRep Bool Replicator Process | ParRep Meta Bool Replicator Process
| PlacedPar Structured | PlacedPar Meta Structured
| Processor Expression Process | Processor Meta Expression Process
| Alt Bool Structured | Alt Meta Bool Structured
| ProcCall Name [Expression] | ProcCall Meta Name [Expression]
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)

46
fco/ASTPasses.hs
View File

@ -45,7 +45,7 @@ uniqueNamesPass p = evalState (doAny p) (0, [])
withNames :: Data t => [A.Name] -> t -> UniqueM ([A.Name], t) withNames :: Data t => [A.Name] -> t -> UniqueM ([A.Name], t)
withNames ns b = do withNames ns b = do
(count, vars) <- get (count, vars) <- get
let names = [s | A.Name s <- ns] let (ms, names) = unzip [(m, s) | A.Name m s <- ns]
let names' = [n ++ "." ++ show (count + i) | (n, i) <- zip names [0..]] let names' = [n ++ "." ++ show (count + i) | (n, i) <- zip names [0..]]
put (count + length ns, (zip names names') ++ vars) put (count + length ns, (zip names names') ++ vars)
@ -54,7 +54,7 @@ uniqueNamesPass p = evalState (doAny p) (0, [])
(count', _) <- get (count', _) <- get
put (count', vars) put (count', vars)
return (map A.Name names', b') return ([A.Name m n | (m, n) <- zip ms names'], b')
withName :: Data t => A.Name -> t -> UniqueM (A.Name, t) withName :: Data t => A.Name -> t -> UniqueM (A.Name, t)
withName n b = do withName n b = do
@ -70,57 +70,57 @@ uniqueNamesPass p = evalState (doAny p) (0, [])
withSpec :: Data t => A.Specification -> t -> UniqueM (A.Specification, t) withSpec :: Data t => A.Specification -> t -> UniqueM (A.Specification, t)
withSpec (n, st) b = do withSpec (n, st) b = do
st' <- case st of st' <- case st of
A.Proc fs pp -> do (fs', pp') <- withFormals fs pp A.Proc m fs pp -> do (fs', pp') <- withFormals fs pp
return $ A.Proc fs' pp' return $ A.Proc m fs' pp'
A.Function rt fs pp -> do (fs', pp') <- withFormals fs pp A.Function m rt fs pp -> do (fs', pp') <- withFormals fs pp
return $ A.Function rt fs' pp' return $ A.Function m rt fs' pp'
otherwise -> doAny st otherwise -> doAny st
(n', b') <- withName n b (n', b') <- withName n b
return ((n', st'), b') return ((n', st'), b')
withRep :: Data t => A.Replicator -> t -> UniqueM (A.Replicator, t) withRep :: Data t => A.Replicator -> t -> UniqueM (A.Replicator, t)
withRep (A.For n f1 f2) b = do withRep (A.For m n f1 f2) b = do
(n', b') <- withName n b (n', b') <- withName n b
f1' <- doAny f1 f1' <- doAny f1
f2' <- doAny f2 f2' <- doAny f2
return $ (A.For n' f1' f2', b') return $ (A.For m n' f1' f2', b')
doProcess :: A.Process -> UniqueM A.Process doProcess :: A.Process -> UniqueM A.Process
doProcess p = case p of doProcess p = case p of
A.ProcSpec s b -> do (s', b') <- withSpec s b A.ProcSpec m s b -> do (s', b') <- withSpec s b
return $ A.ProcSpec s' b' return $ A.ProcSpec m s' b'
A.SeqRep r b -> do (r', b') <- withRep r b A.SeqRep m r b -> do (r', b') <- withRep r b
return $ A.SeqRep r' b' return $ A.SeqRep m r' b'
A.ParRep pri r b -> do (r', b') <- withRep r b A.ParRep m pri r b -> do (r', b') <- withRep r b
return $ A.ParRep pri r' b' return $ A.ParRep m pri r' b'
otherwise -> doGeneric p otherwise -> doGeneric p
doValueProcess :: A.ValueProcess -> UniqueM A.ValueProcess doValueProcess :: A.ValueProcess -> UniqueM A.ValueProcess
doValueProcess p = case p of doValueProcess p = case p of
A.ValOfSpec s b -> do (s', b') <- withSpec s b A.ValOfSpec m s b -> do (s', b') <- withSpec s b
return $ A.ValOfSpec s' b' return $ A.ValOfSpec m s' b'
otherwise -> doGeneric p otherwise -> doGeneric p
doStructured :: A.Structured -> UniqueM A.Structured doStructured :: A.Structured -> UniqueM A.Structured
doStructured p = case p of doStructured p = case p of
A.Rep r b -> do (r', b') <- withRep r b A.Rep m r b -> do (r', b') <- withRep r b
return $ A.Rep r' b' return $ A.Rep m r' b'
A.Spec s b -> do (s', b') <- withSpec s b A.Spec m s b -> do (s', b') <- withSpec s b
return $ A.Spec s' b' return $ A.Spec m s' b'
otherwise -> doGeneric p otherwise -> doGeneric p
doName :: A.Name -> UniqueM A.Name doName :: A.Name -> UniqueM A.Name
doName (A.Name s) = do doName (A.Name m s) = do
(_, vars) <- get (_, vars) <- get
let s' = case lookup s vars of let s' = case lookup s vars of
Just n -> n Just n -> n
Nothing -> "(not-declared-" ++ s ++ ")" Nothing -> "(not-declared-" ++ s ++ ")"
--Nothing -> error $ "Name " ++ s ++ " not declared before use" --Nothing -> error $ "Name " ++ s ++ " not declared before use"
return $ A.Name s' return $ A.Name m s'
cStyleNamesPass :: A.Process -> A.Process cStyleNamesPass :: A.Process -> A.Process
cStyleNamesPass = everywhere (mkT doName) cStyleNamesPass = everywhere (mkT doName)
where where
doName :: A.Name -> A.Name doName :: A.Name -> A.Name
doName (A.Name s) = A.Name [if c == '.' then '_' else c | c <- s] doName (A.Name m s) = A.Name m [if c == '.' then '_' else c | c <- s]

56
fco/COutput.hs
View File

@ -4,13 +4,14 @@ module COutput where
import List import List
import Data.Generics import Data.Generics
import Metadata
import qualified AST as A import qualified AST as A
concatWith x l = concat $ intersperse x l concatWith x l = concat $ intersperse x l
bracketed s = "(" ++ s ++ ")" bracketed s = "(" ++ s ++ ")"
unimp :: Data a => a -> String unimp :: Data a => a -> String
unimp = unimpG `extQ` unimpS unimp = unimpG `extQ` unimpS `extQ` unimpM
where where
unimpG :: Data a => a -> String unimpG :: Data a => a -> String
unimpG t = rep unimpG t = rep
@ -22,16 +23,19 @@ unimp = unimpG `extQ` unimpS
unimpS :: String -> String unimpS :: String -> String
unimpS s = show s unimpS s = show s
unimpM :: Meta -> String
unimpM m = formatSourcePos m
writeC :: A.Process -> String writeC :: A.Process -> String
writeC p = header ++ doProcess p writeC p = header ++ doProcess p
where where
header = "#include <stdint.h>\n" header = "#include <stdint.h>\n"
doName :: A.Name -> String doName :: A.Name -> String
doName (A.Name n) = n doName (A.Name _ n) = n
doUserType :: A.Type -> String doUserType :: A.Type -> String
doUserType (A.UserType (A.Name n)) = "usertype_" ++ n doUserType (A.UserType (A.Name _ n)) = "usertype_" ++ n
doType :: A.Type -> String doType :: A.Type -> String
doType (A.Val t) = "const " ++ (doType t) doType (A.Val t) = "const " ++ (doType t)
@ -47,18 +51,18 @@ writeC p = header ++ doProcess p
doType t = unimp t doType t = unimp t
doVariable :: A.Variable -> String doVariable :: A.Variable -> String
doVariable (A.Variable n) = doName n doVariable (A.Variable _ n) = doName n
doLiteralRepr :: A.LiteralRepr -> String doLiteralRepr :: A.LiteralRepr -> String
doLiteralRepr r = case r of doLiteralRepr r = case r of
A.IntLiteral s -> s A.IntLiteral _ s -> s
doLiteral :: A.Literal -> String doLiteral :: A.Literal -> String
doLiteral (A.Literal t r) = doLiteralRepr r doLiteral (A.Literal _ t r) = doLiteralRepr r
doFunction :: A.ValueProcess -> String doFunction :: A.ValueProcess -> String
doFunction (A.ValOfSpec s p) = doSpecification s ++ doFunction p doFunction (A.ValOfSpec _ s p) = doSpecification s ++ doFunction p
doFunction (A.ValOf p el) = doProcess p ++ "return " ++ doExpressionListOne el ++ ";\n" doFunction (A.ValOf _ p el) = doProcess p ++ "return " ++ doExpressionListOne el ++ ";\n"
-- FIXME handle multi-value return -- FIXME handle multi-value return
makeDecl :: A.Type -> A.Name -> String makeDecl :: A.Type -> A.Name -> String
@ -69,16 +73,16 @@ writeC p = header ++ doProcess p
doSpecification :: A.Specification -> String doSpecification :: A.Specification -> String
doSpecification s@(n, st) = case st of doSpecification s@(n, st) = case st of
A.Declaration t -> makeDecl t n ++ ";\n" A.Declaration _ t -> makeDecl t n ++ ";\n"
A.Proc fs p -> "void " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doProcess p ++ "}\n" A.Proc _ fs p -> "void " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doProcess p ++ "}\n"
A.Function [r] fs vp -> doType r ++ " " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doFunction vp ++ "}\n" A.Function _ [r] fs vp -> doType r ++ " " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doFunction vp ++ "}\n"
_ -> unimp s _ -> unimp s
doProcSpec :: A.Process -> String doProcSpec :: A.Process -> String
doProcSpec p = doP [] p doProcSpec p = doP [] p
where where
doP :: [A.Specification] -> A.Process -> String doP :: [A.Specification] -> A.Process -> String
doP ss (A.ProcSpec s p) = doP (ss ++ [s]) p doP ss (A.ProcSpec _ s p) = doP (ss ++ [s]) p
doP ss p = "{\n" ++ concat (map doSpecification ss) ++ doProcess p ++ "}\n" doP ss p = "{\n" ++ concat (map doSpecification ss) ++ doProcess p ++ "}\n"
doActuals :: [A.Expression] -> String doActuals :: [A.Expression] -> String
@ -101,27 +105,27 @@ writeC p = header ++ doProcess p
doExpression :: A.Expression -> String doExpression :: A.Expression -> String
doExpression e = case e of doExpression e = case e of
A.Monadic o a -> doMonadic o a A.Monadic _ o a -> doMonadic o a
A.Dyadic o a b -> doDyadic o a b A.Dyadic _ o a b -> doDyadic o a b
A.ExprVariable v -> doVariable v A.ExprVariable _ v -> doVariable v
A.ExprLiteral l -> doLiteral l A.ExprLiteral _ l -> doLiteral l
doExpressionListOne :: A.ExpressionList -> String doExpressionListOne :: A.ExpressionList -> String
doExpressionListOne e = case e of doExpressionListOne e = case e of
A.FunctionCallList n as -> doFunctionCall n as A.FunctionCallList _ n as -> doFunctionCall n as
A.ExpressionList [e] -> doExpression e A.ExpressionList _ [e] -> doExpression e
doAssign :: A.Process -> String doAssign :: A.Process -> String
doAssign a = case a of doAssign a = case a of
A.Assign [v] el -> (doVariable v) ++ " = " ++ (doExpressionListOne el) ++ ";\n" A.Assign _ [v] el -> (doVariable v) ++ " = " ++ (doExpressionListOne el) ++ ";\n"
doProcess :: A.Process -> String doProcess :: A.Process -> String
doProcess s@(A.ProcSpec _ _) = doProcSpec s doProcess s@(A.ProcSpec _ _ _) = doProcSpec s
doProcess a@(A.Assign _ _) = doAssign a doProcess a@(A.Assign _ _ _) = doAssign a
doProcess A.Skip = "/* SKIP */;\n" doProcess (A.Skip _) = "/* SKIP */;\n"
doProcess A.Stop = "SetErr ();\n" doProcess (A.Stop _) = "SetErr ();\n"
doProcess A.Main = "/* MAIN-PROCESS */\n"; doProcess (A.Main _) = "/* MAIN-PROCESS */\n";
doProcess (A.Seq ps) = concatWith "" (map doProcess ps) doProcess (A.Seq _ ps) = concatWith "" (map doProcess ps)
doProcess (A.ProcCall n as) = doName n ++ " " ++ doActuals as ++ ";\n" doProcess (A.ProcCall _ n as) = doName n ++ " " ++ doActuals as ++ ";\n"
doProcess n = unimp n doProcess n = unimp n

10
fco/Metadata.hs
View File

@ -3,6 +3,7 @@
module Metadata where module Metadata where
import Data.Generics import Data.Generics
import Data.List
type Meta = [Metadatum] type Meta = [Metadatum]
@ -10,3 +11,12 @@ data Metadatum =
SourcePos String Int Int SourcePos String Int Int
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
findSourcePos :: Meta -> Maybe Metadatum
findSourcePos ms = find (\x -> case x of SourcePos _ _ _ -> True
otherwise -> False) ms
formatSourcePos :: Meta -> String
formatSourcePos m = case findSourcePos m of
Just (SourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">"
Nothing -> "<?>"

261
fco/PTToAST.hs
View File

@ -2,15 +2,16 @@
module PTToAST (ptToAST) where module PTToAST (ptToAST) where
import Metadata
import qualified PT as N import qualified PT as N
import qualified AST as O import qualified AST as O
doName :: N.Node -> O.Name doName :: N.Node -> O.Name
doName (N.Node _ (N.Name s)) = O.Name s doName (N.Node m (N.Name s)) = O.Name m s
doName n = error $ "Failed to translate to Name: " ++ (show n) doName n = error $ "Failed to translate to Name: " ++ (show n)
doTag :: N.Node -> O.Tag doTag :: N.Node -> O.Tag
doTag (N.Node _ (N.Name s)) = O.Tag s doTag (N.Node m (N.Name s)) = O.Tag m s
doType :: N.Node -> O.Type doType :: N.Node -> O.Type
doType n@(N.Node _ nt) = case nt of doType n@(N.Node _ nt) = case nt of
@ -63,61 +64,61 @@ doDyadicOp n@(N.Node _ nt) = case nt of
N.After -> O.After N.After -> O.After
doSubscript :: N.Node -> O.Subscript doSubscript :: N.Node -> O.Subscript
doSubscript n@(N.Node _ nt) = case nt of doSubscript n@(N.Node m nt) = case nt of
N.SubPlain e -> O.Subscript (doExpression e) N.SubPlain e -> O.Subscript m (doExpression e)
N.SubFromFor e f -> O.SubFromFor (doExpression e) (doExpression f) N.SubFromFor e f -> O.SubFromFor m (doExpression e) (doExpression f)
N.SubFrom e -> O.SubFrom (doExpression e) N.SubFrom e -> O.SubFrom m (doExpression e)
N.SubFor f -> O.SubFor (doExpression f) N.SubFor f -> O.SubFor m (doExpression f)
doLiteral :: N.Node -> O.Literal doLiteral :: N.Node -> O.Literal
doLiteral n@(N.Node _ nt) = case nt of doLiteral n@(N.Node m nt) = case nt of
N.TypedLit t l -> O.Literal (doType t) rep where (O.Literal _ rep) = doLiteral l N.TypedLit t l -> O.Literal m (doType t) rep where (O.Literal _ _ rep) = doLiteral l
N.LitReal s -> O.Literal O.Real32 (O.RealLiteral s) N.LitReal s -> O.Literal m O.Real32 (O.RealLiteral m s)
N.LitInt s -> O.Literal O.Int (O.IntLiteral s) N.LitInt s -> O.Literal m O.Int (O.IntLiteral m s)
N.LitHex s -> O.Literal O.Int (O.HexLiteral s) N.LitHex s -> O.Literal m O.Int (O.HexLiteral m s)
N.LitByte s -> O.Literal O.Byte (O.ByteLiteral s) N.LitByte s -> O.Literal m O.Byte (O.ByteLiteral m s)
N.LitString s -> O.Literal (O.ArrayUnsized O.Byte) (O.StringLiteral s) N.LitString s -> O.Literal m (O.ArrayUnsized O.Byte) (O.StringLiteral m s)
N.LitArray ns -> O.Literal O.Infer (O.ArrayLiteral (map doExpression ns)) N.LitArray ns -> O.Literal m O.Infer (O.ArrayLiteral m (map doExpression ns))
N.Sub s l -> O.SubscriptedLiteral (doSubscript s) (doLiteral l) N.Sub s l -> O.SubscriptedLiteral m (doSubscript s) (doLiteral l)
doVariable :: N.Node -> O.Variable doVariable :: N.Node -> O.Variable
doVariable n@(N.Node _ nt) = case nt of doVariable n@(N.Node m nt) = case nt of
N.Name _ -> O.Variable (doName n) N.Name _ -> O.Variable m (doName n)
N.Sub s v -> O.SubscriptedVariable (doSubscript s) (doVariable v) N.Sub s v -> O.SubscriptedVariable m (doSubscript s) (doVariable v)
_ -> error $ "Failed to translate to Variable: " ++ (show n) _ -> error $ "Failed to translate to Variable: " ++ (show n)
doExpression :: N.Node -> O.Expression doExpression :: N.Node -> O.Expression
doExpression n@(N.Node _ nt) = case nt of doExpression n@(N.Node m nt) = case nt of
N.MonadicOp o a -> O.Monadic (doMonadicOp o) (doExpression a) N.MonadicOp o a -> O.Monadic m (doMonadicOp o) (doExpression a)
N.DyadicOp o a b -> O.Dyadic (doDyadicOp o) (doExpression a) (doExpression b) N.DyadicOp o a b -> O.Dyadic m (doDyadicOp o) (doExpression a) (doExpression b)
N.MostPos t -> O.MostPos (doType t) N.MostPos t -> O.MostPos m (doType t)
N.MostNeg t -> O.MostNeg (doType t) N.MostNeg t -> O.MostNeg m (doType t)
N.Size t -> O.Size (doType t) N.Size t -> O.Size m (doType t)
N.Conv t e -> O.Conversion O.DefaultConversion (doType t) (doExpression e) N.Conv t e -> O.Conversion m O.DefaultConversion (doType t) (doExpression e)
N.Round t e -> O.Conversion O.Round (doType t) (doExpression e) N.Round t e -> O.Conversion m O.Round (doType t) (doExpression e)
N.Trunc t e -> O.Conversion O.Trunc (doType t) (doExpression e) N.Trunc t e -> O.Conversion m O.Trunc (doType t) (doExpression e)
N.TypedLit _ _ -> O.ExprLiteral $ doLiteral n N.TypedLit _ _ -> O.ExprLiteral m $ doLiteral n
N.LitReal _ -> O.ExprLiteral $ doLiteral n N.LitReal _ -> O.ExprLiteral m $ doLiteral n
N.LitInt _ -> O.ExprLiteral $ doLiteral n N.LitInt _ -> O.ExprLiteral m $ doLiteral n
N.LitHex _ -> O.ExprLiteral $ doLiteral n N.LitHex _ -> O.ExprLiteral m $ doLiteral n
N.LitByte _ -> O.ExprLiteral $ doLiteral n N.LitByte _ -> O.ExprLiteral m $ doLiteral n
N.LitString _ -> O.ExprLiteral $ doLiteral n N.LitString _ -> O.ExprLiteral m $ doLiteral n
N.LitArray _ -> O.ExprLiteral $ doLiteral n N.LitArray _ -> O.ExprLiteral m $ doLiteral n
N.True -> O.True N.True -> O.True m
N.False -> O.False N.False -> O.False m
N.Call f es -> O.FunctionCall (doName f) (map doExpression es) N.Call f es -> O.FunctionCall m (doName f) (map doExpression es)
N.BytesIn t -> O.BytesInType (doType t) N.BytesIn t -> O.BytesInType m (doType t)
N.OffsetOf t g -> O.OffsetOf (doType t) (doTag g) N.OffsetOf t g -> O.OffsetOf m (doType t) (doTag g)
otherwise -> O.ExprVariable (doVariable n) otherwise -> O.ExprVariable m (doVariable n)
doExpressionList :: N.Node -> O.ExpressionList doExpressionList :: N.Node -> O.ExpressionList
doExpressionList n@(N.Node _ nt) = case nt of doExpressionList n@(N.Node m nt) = case nt of
N.Call f es -> O.FunctionCallList (doName f) (map doExpression es) N.Call f es -> O.FunctionCallList m (doName f) (map doExpression es)
N.ExpList es -> O.ExpressionList (map doExpression es) N.ExpList es -> O.ExpressionList m (map doExpression es)
doReplicator :: N.Node -> O.Replicator doReplicator :: N.Node -> O.Replicator
doReplicator n@(N.Node _ nt) = case nt of doReplicator n@(N.Node m nt) = case nt of
N.For v f t -> O.For (doName v) (doExpression f) (doExpression t) N.For v f t -> O.For m (doName v) (doExpression f) (doExpression t)
doFields :: [N.Node] -> [(O.Type, O.Tag)] doFields :: [N.Node] -> [(O.Type, O.Tag)]
doFields ns = concat $ [[(doType t, doTag f) | f <- fs] | (N.Node _ (N.Fields t fs)) <- ns] doFields ns = concat $ [[(doType t, doTag f) | f <- fs] | (N.Node _ (N.Fields t fs)) <- ns]
@ -126,125 +127,125 @@ doFormals :: [N.Node] -> [(O.Type, O.Name)]
doFormals fs = concat $ [[(doType t, doName n) | n <- ns] | (N.Node _ (N.Formals t ns)) <- fs] doFormals fs = concat $ [[(doType t, doName n) | n <- ns] | (N.Node _ (N.Formals t ns)) <- fs]
doVariant :: N.Node -> O.Structured doVariant :: N.Node -> O.Structured
doVariant n@(N.Node _ nt) = case nt of doVariant n@(N.Node m nt) = case nt of
N.Variant (N.Node _ (N.Tag t is)) p -> O.OnlyV $ O.Variant (doTag t) (map doInputItem is) (doProcess p) N.Variant (N.Node _ (N.Tag t is)) p -> O.OnlyV m $ O.Variant m (doTag t) (map doInputItem is) (doProcess p)
N.Decl s v -> doSpecifications s O.Spec (doVariant v) N.Decl s v -> doSpecifications s O.Spec (doVariant v)
doChoice :: N.Node -> O.Structured doChoice :: N.Node -> O.Structured
doChoice n@(N.Node _ nt) = case nt of doChoice n@(N.Node m nt) = case nt of
N.If cs -> O.Several $ map doChoice cs N.If cs -> O.Several m $ map doChoice cs
N.IfRep r c -> O.Rep (doReplicator r) (doChoice c) N.IfRep r c -> O.Rep m (doReplicator r) (doChoice c)
N.Choice b p -> O.OnlyC $ O.Choice (doExpression b) (doProcess p) N.Choice b p -> O.OnlyC m $ O.Choice m (doExpression b) (doProcess p)
N.Decl s c -> doSpecifications s O.Spec (doChoice c) N.Decl s c -> doSpecifications s O.Spec (doChoice c)
doOption :: N.Node -> O.Structured doOption :: N.Node -> O.Structured
doOption n@(N.Node _ nt) = case nt of doOption n@(N.Node m nt) = case nt of
N.CaseExps cs p -> O.OnlyO $ O.Option (map doExpression cs) (doProcess p) N.CaseExps cs p -> O.OnlyO m $ O.Option m (map doExpression cs) (doProcess p)
N.Else p -> O.OnlyO $ O.Else (doProcess p) N.Else p -> O.OnlyO m $ O.Else m (doProcess p)
N.Decl s o -> doSpecifications s O.Spec (doOption o) N.Decl s o -> doSpecifications s O.Spec (doOption o)
doInputItem :: N.Node -> O.InputItem doInputItem :: N.Node -> O.InputItem
doInputItem n@(N.Node _ nt) = case nt of doInputItem n@(N.Node m nt) = case nt of
N.Counted c d -> O.InCounted (doVariable c) (doVariable d) N.Counted c d -> O.InCounted m (doVariable c) (doVariable d)
otherwise -> O.InVariable (doVariable n) otherwise -> O.InVariable m (doVariable n)
doOutputItem :: N.Node -> O.OutputItem doOutputItem :: N.Node -> O.OutputItem
doOutputItem n@(N.Node _ nt) = case nt of doOutputItem n@(N.Node m nt) = case nt of
N.Counted c d -> O.OutCounted (doExpression c) (doExpression d) N.Counted c d -> O.OutCounted m (doExpression c) (doExpression d)
otherwise -> O.OutExpression (doExpression n) otherwise -> O.OutExpression m (doExpression n)
doInputMode :: N.Node -> O.InputMode doInputMode :: N.Node -> O.InputMode
doInputMode n@(N.Node _ nt) = case nt of doInputMode n@(N.Node m nt) = case nt of
N.InSimple is -> O.InputSimple (map doInputItem is) N.InSimple is -> O.InputSimple m (map doInputItem is)
N.InCase vs -> O.InputCase (O.Several $ map doVariant vs) N.InCase vs -> O.InputCase m (O.Several m $ map doVariant vs)
N.InTag (N.Node _ (N.Tag t is)) -> O.InputCase (O.OnlyV $ O.Variant (doTag t) (map doInputItem is) O.Skip) N.InTag (N.Node _ (N.Tag t is)) -> O.InputCase m (O.OnlyV m $ O.Variant m (doTag t) (map doInputItem is) (O.Skip m))
N.InAfter e -> O.InputAfter (doExpression e) N.InAfter e -> O.InputAfter m (doExpression e)
doSimpleSpec :: N.Node -> O.Specification doSimpleSpec :: N.Node -> O.Specification
doSimpleSpec n@(N.Node _ nt) = case nt of doSimpleSpec n@(N.Node m nt) = case nt of
N.Is d v -> (doName d, O.Is O.Infer (doVariable v)) N.Is d v -> (doName d, O.Is m O.Infer (doVariable v))
N.IsType t d v -> (doName d, O.Is (doType t) (doVariable v)) N.IsType t d v -> (doName d, O.Is m (doType t) (doVariable v))
N.ValIs d e -> (doName d, O.ValIs O.Infer (doExpression e)) N.ValIs d e -> (doName d, O.ValIs m O.Infer (doExpression e))
N.ValIsType t d e -> (doName d, O.ValIs (doType t) (doExpression e)) N.ValIsType t d e -> (doName d, O.ValIs m (doType t) (doExpression e))
N.Place v e -> (doName v, O.Place (doExpression e)) N.Place v e -> (doName v, O.Place m (doExpression e))
N.DataType n (N.Node _ (N.Record fs)) -> (doName n, O.DataTypeRecord False (doFields fs)) N.DataType n (N.Node _ (N.Record fs)) -> (doName n, O.DataTypeRecord m False (doFields fs))
N.DataType n (N.Node _ (N.PackedRecord fs)) -> (doName n, O.DataTypeRecord True (doFields fs)) N.DataType n (N.Node _ (N.PackedRecord fs)) -> (doName n, O.DataTypeRecord m True (doFields fs))
N.DataType n t -> (doName n, O.DataTypeIs (doType t)) N.DataType n t -> (doName n, O.DataTypeIs m (doType t))
N.Protocol n is -> (doName n, O.ProtocolIs (map doType is)) N.Protocol n is -> (doName n, O.ProtocolIs m (map doType is))
N.TaggedProtocol n ts -> (doName n, O.ProtocolCase [(doTag tn, map doType tts) | (N.Node _ (N.Tag tn tts)) <- ts]) N.TaggedProtocol n ts -> (doName n, O.ProtocolCase m [(doTag tn, map doType tts) | (N.Node _ (N.Tag tn tts)) <- ts])
N.Proc n fs p -> (doName n, O.Proc (doFormals fs) (doProcess p)) N.Proc n fs p -> (doName n, O.Proc m (doFormals fs) (doProcess p))
N.Func n rs fs vp -> (doName n, O.Function (map doType rs) (doFormals fs) (doValueProcess vp)) N.Func n rs fs vp -> (doName n, O.Function m (map doType rs) (doFormals fs) (doValueProcess vp))
N.FuncIs n rs fs el -> (doName n, O.Function (map doType rs) (doFormals fs) (O.ValOf O.Skip (doExpressionList el))) N.FuncIs n rs fs el -> (doName n, O.Function m (map doType rs) (doFormals fs) (O.ValOf m (O.Skip m) (doExpressionList el)))
N.Retypes t d s -> (doName d, O.Retypes (doType t) (doVariable s)) N.Retypes t d s -> (doName d, O.Retypes m (doType t) (doVariable s))
N.ValRetypes t d s -> (doName d, O.ValRetypes (doType t) (doVariable s)) N.ValRetypes t d s -> (doName d, O.ValRetypes m (doType t) (doVariable s))
N.Reshapes t d s -> (doName d, O.Reshapes (doType t) (doVariable s)) N.Reshapes t d s -> (doName d, O.Reshapes m (doType t) (doVariable s))
N.ValReshapes t d s -> (doName d, O.ValReshapes (doType t) (doVariable s)) N.ValReshapes t d s -> (doName d, O.ValReshapes m (doType t) (doVariable s))
doSpecifications :: N.Node -> (O.Specification -> a -> a) -> a -> a doSpecifications :: N.Node -> (Meta -> O.Specification -> a -> a) -> a -> a
doSpecifications n@(N.Node m nt) comb arg = case nt of doSpecifications n@(N.Node m nt) comb arg = case nt of
N.Vars t [] -> arg N.Vars t [] -> arg
N.Vars t (v:vs) -> comb (doName v, O.Declaration (doType t)) (doSpecifications (N.Node m (N.Vars t vs)) comb arg) N.Vars t (v:vs) -> comb m (doName v, O.Declaration m (doType t)) (doSpecifications (N.Node m (N.Vars t vs)) comb arg)
otherwise -> comb (doSimpleSpec n) arg otherwise -> comb m (doSimpleSpec n) arg
doAlternative :: N.Node -> O.Alternative doAlternative :: N.Node -> O.Alternative
doAlternative n@(N.Node _ nt) = case nt of doAlternative n@(N.Node m nt) = case nt of
N.Guard (N.Node _ (N.In c m)) p -> O.Alternative (doVariable c) (doInputMode m) (doProcess p) N.Guard (N.Node _ (N.In c md)) p -> O.Alternative m (doVariable c) (doInputMode md) (doProcess p)
N.Guard (N.Node _ (N.CondGuard b (N.Node _ (N.In c m)))) p -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) (doProcess p) N.Guard (N.Node _ (N.CondGuard b (N.Node _ (N.In c md)))) p -> O.AlternativeCond m (doExpression b) (doVariable c) (doInputMode md) (doProcess p)
N.Guard (N.Node _ (N.CondGuard b (N.Node _ N.Skip))) p -> O.AlternativeSkip (doExpression b) (doProcess p) N.Guard (N.Node _ (N.CondGuard b (N.Node _ N.Skip))) p -> O.AlternativeSkip m (doExpression b) (doProcess p)
-- ALT over "? CASE": the O.Skip that gets inserted here doesn't correspond -- ALT over "? CASE": the O.Skip that gets inserted here doesn't correspond
-- to anything in real occam; it's just there to let us handle these the same -- to anything in real occam; it's just there to let us handle these the same
-- way as the regular ALT inputs. -- way as the regular ALT inputs.
N.In c m@(N.Node _ (N.InCase _)) -> O.Alternative (doVariable c) (doInputMode m) O.Skip N.In c md@(N.Node _ (N.InCase _)) -> O.Alternative m (doVariable c) (doInputMode md) (O.Skip m)
N.CondGuard b (N.Node _ (N.In c m@(N.Node _ (N.InCase _)))) -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) O.Skip N.CondGuard b (N.Node _ (N.In c md@(N.Node _ (N.InCase _)))) -> O.AlternativeCond m (doExpression b) (doVariable c) (doInputMode md) (O.Skip m)
doAlt :: N.Node -> O.Structured doAlt :: N.Node -> O.Structured
doAlt n@(N.Node _ nt) = case nt of doAlt n@(N.Node m nt) = case nt of
N.Alt ns -> O.Several $ map doAlt ns N.Alt ns -> O.Several m $ map doAlt ns
N.PriAlt ns -> O.Several $ map doAlt ns N.PriAlt ns -> O.Several m $ map doAlt ns
N.AltRep r n -> O.Rep (doReplicator r) (doAlt n) N.AltRep r n -> O.Rep m (doReplicator r) (doAlt n)
N.PriAltRep r n -> O.Rep (doReplicator r) (doAlt n) N.PriAltRep r n -> O.Rep m (doReplicator r) (doAlt n)
N.Decl s n -> doSpecifications s O.Spec (doAlt n) N.Decl s n -> doSpecifications s O.Spec (doAlt n)
otherwise -> O.OnlyA $ doAlternative n otherwise -> O.OnlyA m $ doAlternative n
doValueProcess :: N.Node -> O.ValueProcess doValueProcess :: N.Node -> O.ValueProcess
doValueProcess n@(N.Node _ nt) = case nt of doValueProcess n@(N.Node m nt) = case nt of
N.Decl s n -> doSpecifications s O.ValOfSpec (doValueProcess n) N.Decl s n -> doSpecifications s O.ValOfSpec (doValueProcess n)
N.ValOf p el -> O.ValOf (doProcess p) (doExpressionList el) N.ValOf p el -> O.ValOf m (doProcess p) (doExpressionList el)
doPlacedPar :: N.Node -> O.Structured doPlacedPar :: N.Node -> O.Structured
doPlacedPar n@(N.Node _ nt) = case nt of doPlacedPar n@(N.Node m nt) = case nt of
N.PlacedPar ps -> O.Several $ map doPlacedPar ps N.PlacedPar ps -> O.Several m $ map doPlacedPar ps
N.PlacedParRep r p -> O.Rep (doReplicator r) (doPlacedPar p) N.PlacedParRep r p -> O.Rep m (doReplicator r) (doPlacedPar p)
N.Processor e p -> O.OnlyP $ O.Processor (doExpression e) (doProcess p) N.Processor e p -> O.OnlyP m $ O.Processor m (doExpression e) (doProcess p)
N.Decl s p -> doSpecifications s O.Spec (doPlacedPar p) N.Decl s p -> doSpecifications s O.Spec (doPlacedPar p)
doProcess :: N.Node -> O.Process doProcess :: N.Node -> O.Process
doProcess n@(N.Node _ nt) = case nt of doProcess n@(N.Node m nt) = case nt of
N.Decl s p -> doSpecifications s O.ProcSpec (doProcess p) N.Decl s p -> doSpecifications s O.ProcSpec (doProcess p)
N.Assign vs el -> O.Assign (map doVariable vs) (doExpressionList el) N.Assign vs el -> O.Assign m (map doVariable vs) (doExpressionList el)
N.In c m -> O.Input (doVariable c) (doInputMode m) N.In c md -> O.Input m (doVariable c) (doInputMode md)
N.Out c os -> O.Output (doVariable c) (map doOutputItem os) N.Out c os -> O.Output m (doVariable c) (map doOutputItem os)
N.OutCase c t os -> O.OutputCase (doVariable c) (doTag t) (map doOutputItem os) N.OutCase c t os -> O.OutputCase m (doVariable c) (doTag t) (map doOutputItem os)
N.Skip -> O.Skip N.Skip -> O.Skip m
N.Stop -> O.Stop N.Stop -> O.Stop m
N.MainProcess -> O.Main N.MainProcess -> O.Main m
N.Seq ps -> O.Seq (map doProcess ps) N.Seq ps -> O.Seq m (map doProcess ps)
N.SeqRep r p -> O.SeqRep (doReplicator r) (doProcess p) N.SeqRep r p -> O.SeqRep m (doReplicator r) (doProcess p)
N.If _ -> O.If $ doChoice n N.If _ -> O.If m $ doChoice n
N.Case e os -> O.Case (doExpression e) (O.Several $ map doOption os) N.Case e os -> O.Case m (doExpression e) (O.Several m $ map doOption os)
N.While e p -> O.While (doExpression e) (doProcess p) N.While e p -> O.While m (doExpression e) (doProcess p)
N.Par ns -> O.Par False (map doProcess ns) N.Par ns -> O.Par m False (map doProcess ns)
N.PriPar ns -> O.Par True (map doProcess ns) N.PriPar ns -> O.Par m True (map doProcess ns)
N.ParRep r p -> O.ParRep False (doReplicator r) (doProcess p) N.ParRep r p -> O.ParRep m False (doReplicator r) (doProcess p)
N.PriParRep r p -> O.ParRep True (doReplicator r) (doProcess p) N.PriParRep r p -> O.ParRep m True (doReplicator r) (doProcess p)
N.PlacedPar _ -> O.PlacedPar $ doPlacedPar n N.PlacedPar _ -> O.PlacedPar m $ doPlacedPar n
N.PlacedParRep _ _ -> O.PlacedPar $ doPlacedPar n N.PlacedParRep _ _ -> O.PlacedPar m $ doPlacedPar n
N.Processor _ _ -> O.PlacedPar $ doPlacedPar n N.Processor _ _ -> O.PlacedPar m $ doPlacedPar n
N.Alt _ -> O.Alt False $ doAlt n N.Alt _ -> O.Alt m False $ doAlt n
N.AltRep _ _ -> O.Alt False $ doAlt n N.AltRep _ _ -> O.Alt m False $ doAlt n
N.PriAlt _ -> O.Alt True $ doAlt n N.PriAlt _ -> O.Alt m True $ doAlt n
N.PriAltRep _ _ -> O.Alt True $ doAlt n N.PriAltRep _ _ -> O.Alt m True $ doAlt n
N.ProcCall p es -> O.ProcCall (doName p) (map doExpression es) N.ProcCall p es -> O.ProcCall m (doName p) (map doExpression es)
ptToAST :: N.Node -> O.Process ptToAST :: N.Node -> O.Process
ptToAST = doProcess ptToAST = doProcess

9
fco/PrettyShow.hs
View File

@ -1,9 +1,13 @@
-- A generic show implementation that pretty-prints expressions -- A generic show implementation that pretty-prints expressions
-- This ought to use a class (like show does), so that it can be extended
-- properly without me needing to have FCO-specific cases in here -- see the
-- appropriate SYB paper.
module PrettyShow (pshow) where module PrettyShow (pshow) where
import Data.Generics import Data.Generics
import Text.PrettyPrint.HughesPJ import Text.PrettyPrint.HughesPJ
import Metadata
-- This is ugly -- but it looks like you can't easily define a generic function -- This is ugly -- but it looks like you can't easily define a generic function
-- even for a single tuple type, since it has to parameterise over multiple Data -- even for a single tuple type, since it has to parameterise over multiple Data
@ -34,8 +38,11 @@ doList t = brackets $ sep $ punctuate (text ",") (map doAny t)
doString :: String -> Doc doString :: String -> Doc
doString s = text $ show s doString s = text $ show s
doMeta :: Meta -> Doc
doMeta m = text $ formatSourcePos m
doAny :: Data a => a -> Doc doAny :: Data a => a -> Doc
doAny = doGeneral `ext1Q` doList `extQ` doString doAny = doGeneral `ext1Q` doList `extQ` doString `extQ` doMeta
pshow :: Data a => a -> String pshow :: Data a => a -> String
pshow x = render $ doAny x pshow x = render $ doAny x