Commit 42d02357 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai

add capability to parse typed SAPL

parent c6917dc5
......@@ -78,7 +78,7 @@ read_line (lmap, startfn, id) line
= (lmap, startfn, id+1)
(TIdentifier name)
# lmap = case skip_arguments next of
# lmap = case skip_to_definition next of
[TAssignmentOp, (TIdentifier "StdMisc.undef"):_] // skip functions which are undefined
= lmap
[TAssignmentOp: ts]
......@@ -92,9 +92,10 @@ read_line (lmap, startfn, id) line
_ = (lmap, startfn, id+1) // skip line. e.g. comment
where
skip_arguments [TIdentifier _:ts] = skip_arguments ts
skip_arguments [TStrictIdentifier _:ts] = skip_arguments ts
skip_arguments ts = ts
skip_to_definition [TIdentifier _:ts] = skip_to_definition ts
skip_to_definition [TStrictIdentifier _:ts] = skip_to_definition ts
skip_to_definition [TTypeDef:ts] = skip_to_definition ts
skip_to_definition ts = ts
macroBody ts = toString (macroBody_ (filter macroTokens ts) newAppender)
where
......
......@@ -37,8 +37,8 @@ where
(ds, nbody) = (propBody ps flavour newSet body)
nargs = map addStrictness args
addStrictness var=:(StrictVar _ _) = var
addStrictness var=:(NormalVar vn _) = if (member vn ds) (toStrictVar var) var
addStrictness var=:(TypedVar (StrictVar _ _) _) = var
addStrictness var=:(TypedVar (NormalVar vn _) _) = if (member vn ds) (toStrictVar var) var
propFunc ps _ f = (f, ps)
......@@ -90,8 +90,8 @@ where
vn = unpackVar (unpackBindVar bnd)
// Delete itself, it dosn't need any more
walkbnd sd (SaplLetDef (StrictVar vn _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
walkbnd sd (SaplLetDef (NormalVar vn _) body) = delete vn sd
walkbnd sd (SaplLetDef (TypedVar (StrictVar vn _) _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
walkbnd sd (SaplLetDef (TypedVar (NormalVar vn _) _) body) = delete vn sd
walk sd t = (sd, t)
......@@ -7,7 +7,7 @@ from Data.Map import :: Map
// Cannot be abstract because code generator uses it
:: ParserState = { ps_level :: Int
, ps_constructors :: Map String ConstructorDef
, ps_functions :: Map String [SaplVar]
, ps_functions :: Map String [SaplTypedVar]
, ps_CAFs :: Map String Void
, ps_genFuns :: [FuncType] // generated functions during parsing
}
......@@ -15,7 +15,7 @@ from Data.Map import :: Map
:: ConstructorDef = { index :: !Int
, nr_cons :: !Int
, nr_args :: !Int // for efficiency
, args :: [SaplVar]
, args :: [SaplTypedVar]
}
:: ErrorMsg :== String
......
......@@ -58,8 +58,8 @@ where
genadt nrargs s = FTADT (NormalVar name 0) [SaplConstructor (NormalVar name 0) 0 [genarg i s \\ i <- [1..nrargs]]]
genarg i s | s bitand (1 << (i-1)) > 0
= StrictVar "_" 0
= NormalVar "_" 0
= TypedVar (StrictVar "_" 0) NoType
= TypedVar (NormalVar "_" 0) NoType
addTupleCons _ = returnS Void
......@@ -116,14 +116,22 @@ mainexpr ts = selectexpr ts
letdefinitions ts = letdef_1 ts []
where
letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
letdef_1 [TIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (NormalVar name level) t:as]
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]
letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (StrictVar name level) t:as]
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
letdef_2 [TColon: ts] as = letdef_1 ts as
letdef_2 ts as = returnS (reverse as, ts)
......@@ -195,14 +203,18 @@ where
args_annotated ts = args_ ts []
where
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as]
args_ [TStrictIdentifier name:ts] as = args_ ts [StrictVar name 0:as]
args_ [TIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) (Type type):as]
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) NoType:as]
args_ [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = args_ ts [TypedVar (StrictVar name 0) (Type type):as]
args_ [TStrictIdentifier name:ts] as = args_ ts [TypedVar (StrictVar name 0) NoType:as]
args_ ts as = returnS (reverse as, ts)
args_record ts = args_1 ts []
where
args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [NormalVar name level:as]
args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [StrictVar name level:as]
args_1 [TIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) (Type type):as]
args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) NoType:as]
args_1 [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) (Type type):as]
args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) NoType:as]
args_1 ts as = returnE (ts, "Missing argument")
args_2 [TColon:ts] as = args_1 ts as
args_2 ts as = returnS (reverse as, ts)
......@@ -236,12 +248,20 @@ constr [TTypeDef, TIdentifier name, TAssignmentOp: ts] =
constr [TTypeDef:ts] = returnE (ts, "Invalid type definition")
constr ts = returnE (ts, "Not a type definition")
func [TIdentifier name, TCAFAssignmentOp:ts] =
func [TIdentifier name, TTypeDef, TIdentifier type, TCAFAssignmentOp:ts] = typed_caf name (Type type) ts
func [TIdentifier name, TCAFAssignmentOp:ts] = typed_caf name NoType ts
func [TIdentifier name, TTypeDef, TIdentifier type:ts] = typed_fun name (Type type) ts
func [TIdentifier name:ts] = typed_fun name NoType ts
func ts=:[TTypeDef:_] = constr ts >>= \(f,ts) = returnS (f, ts)
func ts = returnE (ts, "Not a function or type definition")
typed_caf name type ts =
getLevel
>>= \level = body ts
>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF tname t, ts)
func [TIdentifier name:ts] =
>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)
typed_fun name type ts =
getLevel
>>= \level = args_annotated ts
>>= \(as, ts) = case hd ts of
......@@ -250,11 +270,8 @@ func [TIdentifier name:ts] =
= returnE (ts, "Missing assignment operator")
>>= \(func, ts) = body ts
>>= \(t, ts) = if func
(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc tname t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro tname t as, ts))
func ts=:[TTypeDef:_] = constr ts >>= \(f,ts) = returnS (f, ts)
func ts = returnE (ts, "Not a function or type definition")
(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))
skip_newlines [TEndOfLine:ts] = skip_newlines ts
skip_newlines ts = returnS ts
......
......@@ -7,13 +7,13 @@ import Data.Maybe
/**
* Possible function types and language constructs.
*/
:: FuncType = FTRecord SaplVar [SaplVar]
:: FuncType = FTRecord SaplVar [SaplTypedVar]
| FTADT SaplVar [SaplConstructor]
| FTCAF SaplVar SaplTerm
| FTMacro SaplVar SaplTerm [SaplVar]
| FTFunc SaplVar SaplTerm [SaplVar]
| FTCAF SaplTypedVar SaplTerm
| FTMacro SaplTypedVar SaplTerm [SaplTypedVar]
| FTFunc SaplTypedVar SaplTerm [SaplTypedVar]
:: SaplConstructor = SaplConstructor SaplVar Int [SaplVar]
:: SaplConstructor = SaplConstructor SaplVar Int [SaplTypedVar]
:: SaplTerm = SLit Literal
| SVar SaplVar
......@@ -24,15 +24,21 @@ import Data.Maybe
| SLet SaplTerm [SaplLetDef]
| SAbortBody
:: SaplLetDef = SaplLetDef SaplVar SaplTerm
:: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm
:: SaplVar = NormalVar String Int
| StrictVar String Int
:: SaplName :== String
:: SaplVar = NormalVar SaplName Int
| StrictVar SaplName Int
:: SaplTypedVar = TypedVar SaplVar SaplType
:: SaplPattern = PCons String [SaplVar]
| PLit Literal
| PDefault
:: SaplType = Type String | NoType
instance toString SaplVar
// I don't provide instances of (==) and (<) here because multiple good way can be imagined...
......@@ -41,13 +47,26 @@ ltVarByName :: !SaplVar !SaplVar -> Bool
eqVarByNameLevel :: !SaplVar !SaplVar -> Bool
ltVarByNameLevel :: !SaplVar !SaplVar -> Bool
eqStrictVar :: !String !SaplVar -> Bool
isStrictVar :: !SaplVar -> Bool
toNormalVar :: !SaplVar -> SaplVar
toStrictVar :: !SaplVar -> SaplVar
removeTypeInfo :: !SaplTypedVar -> SaplVar
class eqStrictVar v :: !String !v -> Bool
class isStrictVar v :: !v -> Bool
class toNormalVar v :: !v -> v
class toStrictVar v :: !v -> v
class unpackVar v :: !v -> String
instance eqStrictVar SaplVar
instance eqStrictVar SaplTypedVar
instance isStrictVar SaplVar
instance isStrictVar SaplTypedVar
instance toNormalVar SaplVar
instance toNormalVar SaplTypedVar
instance toStrictVar SaplVar
instance toStrictVar SaplTypedVar
instance unpackVar SaplVar
instance unpackVar SaplTypedVar
unpackVar :: !SaplVar -> String
unpackBindVar :: !SaplLetDef -> SaplVar
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackConsName :: !SaplPattern -> Maybe String
toStrictBind :: !SaplLetDef -> SaplLetDef
......
......@@ -25,35 +25,73 @@ where
toString (StrictVar name 0) = "!" +++ name
toString (StrictVar name level) = "!" +++ name +++ "_" +++ toString level
isStrictVar :: !SaplVar -> Bool
isStrictVar (StrictVar _ _) = True
isStrictVar _ = False
removeTypeInfo :: !SaplTypedVar -> SaplVar
removeTypeInfo (TypedVar var _) = var
eqStrictVar :: !String !SaplVar -> Bool
eqStrictVar name1 (StrictVar name2 _) = name1 == name2
eqStrictVar _ _ = False
instance eqStrictVar SaplVar
where
eqStrictVar :: !String !SaplVar -> Bool
eqStrictVar name1 (StrictVar name2 _) = name1 == name2
eqStrictVar _ _ = False
instance eqStrictVar SaplTypedVar
where
eqStrictVar :: !String !SaplTypedVar -> Bool
eqStrictVar name (TypedVar var _) = eqStrictVar name var
instance isStrictVar SaplVar
where
isStrictVar :: !SaplVar -> Bool
isStrictVar (StrictVar _ _) = True
isStrictVar _ = False
instance isStrictVar SaplTypedVar
where
isStrictVar :: !SaplTypedVar -> Bool
isStrictVar (TypedVar var _) = isStrictVar var
instance toNormalVar SaplVar
where
toNormalVar :: !SaplVar -> SaplVar
toNormalVar (StrictVar name level) = (NormalVar name level)
toNormalVar v = v
instance toNormalVar SaplTypedVar
where
toNormalVar :: !SaplTypedVar -> SaplTypedVar
toNormalVar (TypedVar var type) = TypedVar (toNormalVar var) type
instance toStrictVar SaplVar
where
toStrictVar :: !SaplVar -> SaplVar
toStrictVar (NormalVar name level) = (StrictVar name level)
toStrictVar v = v
toNormalVar :: !SaplVar -> SaplVar
toNormalVar (StrictVar name level) = (NormalVar name level)
toNormalVar v = v
instance toStrictVar SaplTypedVar
where
toStrictVar :: !SaplTypedVar -> SaplTypedVar
toStrictVar (TypedVar var type) = TypedVar (toStrictVar var) type
toStrictVar :: !SaplVar -> SaplVar
toStrictVar (NormalVar name level) = (StrictVar name level)
toStrictVar v = v
instance unpackVar SaplVar
where
unpackVar :: !SaplVar -> String
unpackVar (NormalVar name _) = name
unpackVar (StrictVar name _) = name
unpackVar :: !SaplVar -> String
unpackVar (NormalVar name _) = name
unpackVar (StrictVar name _) = name
instance unpackVar SaplTypedVar
where
unpackVar :: !SaplTypedVar -> String
unpackVar (TypedVar var _) = unpackVar var
unpackBindVar :: !SaplLetDef -> SaplVar
unpackBindVar (SaplLetDef var _) = var
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackBindVar (SaplLetDef typedVar _) = typedVar
unpackConsName :: !SaplPattern -> Maybe String
unpackConsName (PCons cons _) = Just cons
unpackConsName _ = Nothing
toStrictBind :: !SaplLetDef -> SaplLetDef
toStrictBind (SaplLetDef var body) = SaplLetDef (toStrictVar var) body
toStrictBind (SaplLetDef (TypedVar var type) body) = SaplLetDef (TypedVar (toStrictVar var) type) body
isConsPattern :: !SaplPattern -> Bool
isConsPattern (PCons _ _) = True
......
......@@ -18,13 +18,13 @@ import Sapl.Transform.AddSelectors
from Data.List import elem_by, partition
:: CoderState = { cs_inbody :: !Maybe SaplVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: !Maybe SaplVar // The name of the currently generated function if it is tail recursive
, cs_futuredefs :: ![SaplVar] // for finding out about let-rec and let bindings defined later
:: CoderState = { cs_inbody :: !Maybe SaplTypedVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: !Maybe SaplTypedVar // The name of the currently generated function if it is tail recursive
, cs_futuredefs :: ![SaplTypedVar] // for finding out about let-rec and let bindings defined later
, cs_incaseexpr :: !Bool
, cs_current_vars :: ![SaplVar] // Strict, Normal
, cs_current_vars :: ![SaplTypedVar]
, cs_constructors :: !Map String ConstructorDef
, cs_functions :: !Map String [SaplVar]
, cs_functions :: !Map String [SaplTypedVar]
, cs_CAFs :: !Map String Void
, cs_builtins :: !Map String (String, Int)
, cs_inlinefuncs :: !Map String InlineFunDef
......@@ -55,7 +55,7 @@ inline (SSelect _ _) = False
inline (SIf _ _ _) = False
inline _ = True
pushArgs :: !CoderState ![SaplVar] -> CoderState
pushArgs :: !CoderState ![SaplTypedVar] -> CoderState
pushArgs s [t:ts] = pushArgs {s & cs_current_vars = [t:s.cs_current_vars]} ts
pushArgs s [] = s
......@@ -105,7 +105,7 @@ callWrapper t s a
= a <++ "return " <++ trampolineCoder t s <++ ";"
= a <++ "return " <++ forceTermCoder t s <++ ";"
isTailRecursive :: !SaplVar !SaplTerm -> Bool
isTailRecursive :: !SaplTypedVar !SaplTerm -> Bool
isTailRecursive var (SSelect _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SIf pred lhs rhs) = isTailRecursive var lhs || isTailRecursive var rhs
isTailRecursive var (SApplication avar _) = unpackVar var == unpackVar avar
......@@ -122,7 +122,7 @@ funcCoder (FTRecord name args) s a
= a <++ termCoder name s <++ ".$f=[" <++ recordFieldCoder args <++ "];"
// Only real constants can be safely encoded as a simple variable...
encodeCAF :: !SaplVar !SaplTerm !CoderState !StringAppender -> StringAppender
encodeCAF :: !SaplTypedVar !SaplTerm !CoderState !StringAppender -> StringAppender
encodeCAF name body=:(SLit _) s a
# a = a <++ "var " <++ termCoder name s <++ " = "
......@@ -148,7 +148,7 @@ encodeCAF name body s a
= a <++ "},[]];";
normalFunc :: !SaplVar !SaplTerm ![SaplVar] !CoderState !StringAppender -> StringAppender
normalFunc :: !SaplTypedVar !SaplTerm ![SaplTypedVar] !CoderState !StringAppender -> StringAppender
normalFunc name body args s a
// Generate $eval function if any of its arguments is annotated as strict
# a = if (any isStrictVar args)
......@@ -157,7 +157,7 @@ normalFunc name body args s a
// Generate function signature
# a = a <++ "function " <++ termCoder name s
<++ "(" <++ termArrayCoder args "," s <++ "){"
// Update coder state with the new local arguments, ...
# s = {s & cs_inbody = Just name
, cs_current_vars = args
......@@ -191,7 +191,7 @@ make_app_args func args s a
= a <++ maa_ [] args 0 s
where
// fargs: formal, aargs: actual
maa_ [(StrictVar _ _):fargs] [aa:aargs] i s a
maa_ [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a
# a = if (i>0) (a <++ ",") a
= a <++ forceTermCoder aa s <++ maa_ fargs aargs (i+1) s
maa_ [_:fargs] [aa:aargs] i s a
......@@ -202,9 +202,9 @@ where
= a <++ termCoder aa s <++ maa_ [] aargs (i+1) s
maa_ _ [] _ _ a = a
recordFieldCoder :: ![SaplVar] !StringAppender -> StringAppender
recordFieldCoder [t] a = a <++ "\"" <++ unpackVar t <++ "\""
recordFieldCoder [t:ts] a
recordFieldCoder :: ![SaplTypedVar] !StringAppender -> StringAppender
recordFieldCoder [TypedVar t _] a = a <++ "\"" <++ unpackVar t <++ "\""
recordFieldCoder [TypedVar t _:ts] a
= a <++ "\"" <++ unpackVar t <++ "\"," <++ recordFieldCoder ts
recordFieldCoder [] a = a
......@@ -226,7 +226,7 @@ where
//----------------------------------------------------------------------------------------
// Data constructor...
constructorCoder :: !SaplVar !Int ![SaplVar] CoderState !StringAppender -> StringAppender
constructorCoder :: !SaplVar !Int ![SaplTypedVar] CoderState !StringAppender -> StringAppender
// A zero argument data constructor is a CAF
constructorCoder name id [] s a
......@@ -261,11 +261,11 @@ constructorInliner name def args s a
= a <++ "]"
where
// Formal arguments, actual arguments
argsCoder [NormalVar _ _] [t] sep s a = termCoder t s a
argsCoder [StrictVar _ _] [t] sep s a = forceTermCoder t s a
argsCoder [NormalVar _ _:fs] [t:ts] sep s a
argsCoder [TypedVar (NormalVar _ _) _] [t] sep s a = termCoder t s a
argsCoder [TypedVar (StrictVar _ _) _] [t] sep s a = forceTermCoder t s a
argsCoder [TypedVar (NormalVar _ _) _:fs] [t:ts] sep s a
= a <++ termCoder t s <++ sep <++ argsCoder fs ts sep s
argsCoder [StrictVar _ _:fs] [t:ts] sep s a
argsCoder [TypedVar (StrictVar _ _) _:fs] [t:ts] sep s a
= a <++ forceTermCoder t s <++ sep <++ argsCoder fs ts sep s
argsCoder [] [] _ s a = a
......@@ -352,8 +352,8 @@ where
get_cons = get_cons_or_die s cons
annotate (StrictVar _ _, arg) = toStrictVar arg
annotate (_, arg) = arg
annotate (TypedVar (StrictVar _ _) type, arg) = TypedVar (toStrictVar arg) type
annotate (TypedVar _ type, arg) = TypedVar arg type
forceTermCoder t s a = termCoder t s a
trampolineCoder t s a = termCoder t s a
......@@ -361,6 +361,12 @@ where
//----------------------------------------------------------------------------------------
// Variables...
instance TermCoder SaplTypedVar
where
forceTermCoder var s a = forceTermCoder (removeTypeInfo var) s a
trampolineCoder var s a = trampolineCoder (removeTypeInfo var) s a
termCoder var s a = termCoder (removeTypeInfo var) s a
instance TermCoder SaplVar
where
forceTermCoder t=:(NormalVar name level) s a
......@@ -410,7 +416,7 @@ where
= a <++ escapeName s.cs_prefix name <++ "$eval"
// else (TODO: probably bogus in tail-recursion...)
| any (eqVarByNameLevel t) s.cs_futuredefs
| any (eqVarByNameLevel t) (map removeTypeInfo s.cs_futuredefs)
= a <++ "[function(){return " <++ force var_name <++ ";},[]]"
// else: use the defined name if its a built-in function, otherwise its a variable...
......@@ -424,10 +430,10 @@ where
mbCAF = 'DM'.get name s.cs_CAFs
// TODO: doc
findLocalVar [(NormalVar cn level):cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [(StrictVar cn level):cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [TypedVar (NormalVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [TypedVar (StrictVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [] = 0
isLocalVar = elem_by eqVarByName t s.cs_current_vars //isMember t s.cs_current_vars
isLocalVar = elem_by eqVarByName t (map removeTypeInfo s.cs_current_vars) //isMember t s.cs_current_vars
isFunction = isJust ('DM'.get t s.cs_functions)
isStrictFunction = a || b
......@@ -543,7 +549,7 @@ where
= a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";"
<++ mta_2 tr_function_args 0 s <++ "continue;"
where
mta_1 [(StrictVar _ _):fargs] [aa:aargs] i s a
mta_1 [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a
# a = if (i>0) (a <++ ",") a
= a <++ "t" <++ i <++ "=" <++ forceTermCoder aa s <++ mta_1 fargs aargs (i+1) s
mta_1 [_:fargs] [aa:aargs] i s a
......@@ -701,7 +707,7 @@ exprGenerateJS f tramp saplsrc mbPst out
= case parseExpr pts of
Ok (body, s) # newpst = mergeParserStates s mbPst
# state = newState f tramp newpst
# a = termCoder body {state & cs_inbody=Just (NormalVar "__dummy" 0)} newAppender
# a = termCoder body {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
# out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
= Ok (toString a, out, newpst)
Error msg = Error msg
......
......@@ -17,7 +17,7 @@ where
// Generate the graph: edges and the start nodes (independent nodes)
genGraph :: !(Set SaplVar) ![SaplLetDef] -> (!Set (SaplVar,SaplVar), !Set SaplVar)
genGraph binds defs = foldl (\s (SaplLetDef bv body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
genGraph binds defs = foldl (\s (SaplLetDef (TypedVar bv _) body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
where
gen vs bv s (SApplication f as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv (es,is) (SVar v)
......@@ -34,8 +34,8 @@ sortBindings defs
= Nothing // cycle is detected
where
(edges, startnodes) = genGraph binds defs
binds = 'Data.Set'.fromList (map (toNormalVar o unpackBindVar) defs)
defmap = 'Data.Map'.fromList (map (\d=:(SaplLetDef bv body) -> (bv,d)) defs)
binds = 'Data.Set'.fromList (map (removeTypeInfo o toNormalVar o unpackBindVar) defs)
defmap = 'Data.Map'.fromList (map (\d=:(SaplLetDef bv body) -> (removeTypeInfo bv,d)) defs)
// Returns the renaming edges (if any) and the ordered list of bind vars (reversed order)
gen edges [] = (edges, [])
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment