Commit 211bac59 authored by marton bognar's avatar marton bognar
Browse files

Make env functions De Bruijn only

parent 5cbcd602
......@@ -10,7 +10,6 @@ data ConvertFunctions = VF {
userTypes :: Language -> [(Type, [Constructor])],
variableInstances :: (Type, [Constructor]) -> [(Type, Type, [Function])],
variableFunctions :: Language -> (Type, [Constructor]) -> [Function],
envFunctions :: Language -> [Function],
nativeCode :: Language -> (Type, [Constructor])-> [String]
}
......@@ -22,7 +21,6 @@ convert lan@(nsd, sd, imp, cd) vf =
imports = imp,
types = var : (userTypes vf) lan,
instances = (variableInstances vf) var,
functions = (variableFunctions vf) lan var ++
(envFunctions vf) lan,
functions = (variableFunctions vf) lan var,
code = (nativeCode vf) lan var ++ cd
}
{-# OPTIONS_GHC -Wall #-}
module Variable.Common (getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs, inhCtxsForSortName) where
module Variable.Common (freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs, inhCtxsForSortName) where
import Data.List
import Data.Maybe
......@@ -16,66 +16,6 @@ data ExternalFunctions = EF {
includeBinders :: Bool
}
-- * Types
-- ----------------------------------------------------------------------------
-- | ??
getEnvFunctions :: Language -> [Function]
getEnvFunctions (nsd, sd, _, _)
= let ctxsBySname = map snameAndCtxs sd
in concatMap (\sort ->
let synCtxs = [SYN x y | SYN x y <- sctxs sort]
in if null synCtxs then [] else
map (\ctor ->
generateSortSynSystemOneConstructor (sname sort) nsd ctxsBySname ctor (head synCtxs)
) (sctors sort)
) sd
where
generateSortSynSystemOneConstructor :: SortName -> [NamespaceDef] -> [(SortName, [Context])] -> ConstructorDef -> Context -> Function
generateSortSynSystemOneConstructor sname _ _ (MkVarConstructor ctorName _) _
= Fn ("addToEnvironment" ++ sname) [([ConstrParam ctorName [VarParam "var"], VarParam "c"], VarExpr "c")]
generateSortSynSystemOneConstructor sname nsd ctxsBySname ctor ctx
= Fn ("addToEnvironment" ++ sname ++ xinst ctx) [([ConstrParam ctorName (firstToVarParams sorts ++ [VarParam "_" | _ <- hTypes]), VarParam "c"], getEnvFunctionGenerate)]
where
filteredSnameAndCtxs = filterCtxsByNamespace (xnamespace ctx) ctxsBySname
ctorName = cname ctor
sorts = csorts ctor
hTypes = cnatives ctor
attrs = cattrs ctor
getEnvFunctionGenerate :: Expression
getEnvFunctionGenerate
| null $ fromJust (lookup "lhs" allrules) = VarExpr "c"
| otherwise = navigateAttrs start
where
allrules = collectRulesSyn
start = fromJust (
find
(\x -> linst (fst x) == xinst ctx)
(fromJust (lookup "lhs" allrules))
)
collectRulesSyn :: [(IdenName, [AttributeDef])]
collectRulesSyn =
foldl
(++)
[("lhs", [(LeftLHS c, r) | (LeftLHS c, r) <- attrs])]
(map (\(iden, _) -> [collectRulesOfIdSyn iden]) sorts)
where
collectRulesOfIdSyn :: IdenName -> (IdenName, [AttributeDef])
collectRulesOfIdSyn iden = (iden, filter (\(LeftSub fieldname _, RightSub _ _) -> fieldname == iden) attrs)
navigateAttrs :: AttributeDef -> Expression
navigateAttrs (l, RightAdd expr _) = ConstrInst ("S" ++ xnamespace ctx) [navigateAttrs (l, expr)]
navigateAttrs (LeftLHS _, RightLHS _) = VarExpr "c"
navigateAttrs (LeftSub _ _, RightLHS _) = VarExpr "c"
navigateAttrs (_, RightSub iden _)
| isJust newrule = FnCall functionName [VarExpr iden, navigateAttrs (fromJust newrule)]
| otherwise = FnCall functionName [VarExpr iden, VarExpr "c"]
where
newrule = find (\(l, _) -> liden l == iden) attrs
functionName = "addToEnvironment" ++ fromJust (lookup iden sorts) ++ xinst ctx
-- * Free variables
-- ----------------------------------------------------------------------------
......
......@@ -16,7 +16,6 @@ getFunctions
userTypes = getTypes,
variableInstances = getVariableInstances,
variableFunctions = getVariableFunctions,
envFunctions = getEnvFunctions,
nativeCode = (\_ _ -> [])
}
......@@ -51,7 +50,7 @@ getVariableInstances (_, hnatc) =
| otherwise = ([ConstrParam n1 [VarParam "h1"], ConstrParam n2 [VarParam "h2"]], FnCall "error" [StringExpr "differing namespace found in compare"])
getVariableFunctions :: Language -> (Type, [Constructor]) -> [Function]
getVariableFunctions lan@(nsd, _, _, _) varT = getHNatModifiers varT ++ getGenerators nsd ++ getShift lan ++ mappingFunctions lan ef ++ substFunctions lan ++ freeVarFunctions lan ef
getVariableFunctions lan@(nsd, _, _, _) varT = getHNatModifiers varT ++ getGenerators nsd ++ getShift lan ++ mappingFunctions lan ef ++ substFunctions lan ++ freeVarFunctions lan ef ++ getEnvFunctions lan
getHNatModifiers :: (Type, [Constructor]) -> [Function]
getHNatModifiers (_, hnatc) =
......@@ -130,6 +129,62 @@ getShiftFunctions sd defs opName varAccessTable = let filtered = filter (\s -> i
FnCall (sortNameForNamespaceName namespaceName nsd ++ "shiftHelp" ++ op) [VarExpr "d"]
) filtered
getEnvFunctions :: Language -> [Function]
getEnvFunctions (nsd, sd, _, _)
= let ctxsBySname = map snameAndCtxs sd
in concatMap (\sort ->
let synCtxs = [SYN x y | SYN x y <- sctxs sort]
in if null synCtxs then [] else
map (\ctor ->
generateSortSynSystemOneConstructor (sname sort) nsd ctxsBySname ctor (head synCtxs)
) (sctors sort)
) sd
where
generateSortSynSystemOneConstructor :: SortName -> [NamespaceDef] -> [(SortName, [Context])] -> ConstructorDef -> Context -> Function
generateSortSynSystemOneConstructor sname _ _ (MkVarConstructor ctorName _) _
= Fn ("addToEnvironment" ++ sname) [([ConstrParam ctorName [VarParam "var"], VarParam "c"], VarExpr "c")]
generateSortSynSystemOneConstructor sname nsd ctxsBySname ctor ctx
= Fn ("addToEnvironment" ++ sname ++ xinst ctx) [([ConstrParam ctorName (firstToVarParams sorts ++ [VarParam "_" | _ <- hTypes]), VarParam "c"], getEnvFunctionGenerate)]
where
filteredSnameAndCtxs = filterCtxsByNamespace (xnamespace ctx) ctxsBySname
ctorName = cname ctor
sorts = csorts ctor
hTypes = cnatives ctor
attrs = cattrs ctor
getEnvFunctionGenerate :: Expression
getEnvFunctionGenerate
| null $ fromJust (lookup "lhs" allrules) = VarExpr "c"
| otherwise = navigateAttrs start
where
allrules = collectRulesSyn
start = fromJust (
find
(\x -> linst (fst x) == xinst ctx)
(fromJust (lookup "lhs" allrules))
)
collectRulesSyn :: [(IdenName, [AttributeDef])]
collectRulesSyn =
foldl
(++)
[("lhs", [(LeftLHS c, r) | (LeftLHS c, r) <- attrs])]
(map (\(iden, _) -> [collectRulesOfIdSyn iden]) sorts)
where
collectRulesOfIdSyn :: IdenName -> (IdenName, [AttributeDef])
collectRulesOfIdSyn iden = (iden, filter (\(LeftSub fieldname _, RightSub _ _) -> fieldname == iden) attrs)
navigateAttrs :: AttributeDef -> Expression
navigateAttrs (l, RightAdd expr _) = ConstrInst ("S" ++ xnamespace ctx) [navigateAttrs (l, expr)]
navigateAttrs (LeftLHS _, RightLHS _) = VarExpr "c"
navigateAttrs (LeftSub _ _, RightLHS _) = VarExpr "c"
navigateAttrs (_, RightSub iden _)
| isJust newrule = FnCall functionName [VarExpr iden, navigateAttrs (fromJust newrule)]
| otherwise = FnCall functionName [VarExpr iden, VarExpr "c"]
where
newrule = find (\(l, _) -> liden l == iden) attrs
functionName = "addToEnvironment" ++ fromJust (lookup iden sorts) ++ xinst ctx
-- | Generates the following for sorts with variable access:
-- * Substitute helper functions for variable constructors
-- * Substitute functions for every sort that is related to the given sort by
......
......@@ -16,7 +16,6 @@ getFunctions
userTypes = getTypes,
variableInstances = getVariableInstances,
variableFunctions = getVariableFunctions,
envFunctions = getEnvFunctions,
nativeCode = freshVarFunctions
}
......
Supports Markdown
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