Commit 22a22953 authored by marton bognar's avatar marton bognar
Browse files

Separate the function that deals with moving under binders

parent 4a2c8802
{-# OPTIONS_GHC -Wall #-}
module Variable.Common (getEnvType, getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs) where
module Variable.Common (getEnvType, getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs, inhCtxsForSortName) where
import Data.List
import Data.Maybe
......@@ -12,7 +12,7 @@ import Utility
data ExternalFunctions = EF {
paramForCtor :: ConstructorDef -> [Parameter],
freeVarExprForVarCtor :: String -> Expression,
transformForAddAttr :: String -> [Expression] -> Expression,
applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression,
includeBinders :: Bool
}
......@@ -123,7 +123,7 @@ freeVarFunctions (_, sd, _, _) ef =
idensAndAttrs = attrsByIden ctor
callList = concatMap (
\(iden, iattrs) ->
let addedBinders = applyInhCtxsToAttrs ef sname ctor (iden, iattrs) ctxsBySname
let addedBinders = (applyInhCtxsToAttrs ef) sname ctor (iden, iattrs) ctxsBySname
sortNameOfIden = sortNameForIden iden ctor
in
if fromJust (lookup sortNameOfIden varAccessBySname)
......@@ -199,7 +199,7 @@ mappingFunctions (_, sd, _, _) ef =
else FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders ++ [VarExpr iden])
else VarExpr iden
where
addedBinders = [applyInhCtxsToAttrs ef sortName ctor (iden, idenAttrs) ctxsBySname]
addedBinders = [(applyInhCtxsToAttrs ef) sortName ctor (iden, idenAttrs) ctxsBySname]
sortNameOfIden = sortNameForIden iden ctor
-- | Return a function reference for the processing functions
......@@ -219,47 +219,3 @@ inhCtxsForSortName sname ctxsForSortName = [INH x y | INH x y <- ctxs]
-- | In a list of tuples, converts the first elements to a list of variable parameters
firstToVarParams :: [(String, String)] -> [Parameter]
firstToVarParams = map (VarParam . fst)
-- | For every inherited context of a sort, apply nested modifiers to the
-- returned "c" variable
applyInhCtxsToAttrs :: ExternalFunctions -> SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
applyInhCtxsToAttrs ef sname ctor (iden, idenAttrs) ctxsBySname
= let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
where
-- | Runs `applyOneAttr` if the identifier's attribute definitions
-- contain an assignment to an instance of the given context
applyOneCtx :: Context -> Expression -> Maybe Expression
applyOneCtx ctx param
| isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
| otherwise = Nothing
where
attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
-- | Apply the necessary wrap based on the attribute assignment type
applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
applyOneAttr (_, RightLHS _) _ = Nothing
applyOneAttr (l, RightAdd expr _) params
= return (transformForAddAttr ef (xnamespace ctx) (nextStep ++ params))
where
nextStep = maybeToList (applyOneAttr (l, expr) [])
applyOneAttr (_, RightSub iden context) params
= if elem iden (map fst lists) || elem iden (map fst folds)
then if isJust attrsForIden
then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
else if isJust attrsForIden
then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
where
newAttrs = filter (\(left, _) ->
let iden = liden left
ctxsForSort = fromJust (lookup sname ctxsBySname)
ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
) (cattrs ctor)
attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
lists = clists ctor
folds = dropFold $ cfolds ctor
sorts = csorts ctor
......@@ -204,9 +204,53 @@ _substExpr sname consName =
(FnCall (sname ++ "shiftplus") [VarExpr "c", VarExpr "sub"])
(ConstrInst consName [VarExpr "var"])
-- | For every inherited context of a sort, apply nested modifiers to the
-- returned "c" variable
_applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
_applyInhCtxsToAttrs sname ctor (iden, idenAttrs) ctxsBySname
= let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
where
-- | Runs `applyOneAttr` if the identifier's attribute definitions
-- contain an assignment to an instance of the given context
applyOneCtx :: Context -> Expression -> Maybe Expression
applyOneCtx ctx param
| isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
| otherwise = Nothing
where
attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
-- | Apply the necessary wrap based on the attribute assignment type
applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
applyOneAttr (_, RightLHS _) _ = Nothing
applyOneAttr (l, RightAdd expr _) params
= return (_oneDeeper (xnamespace ctx) (nextStep ++ params))
where
nextStep = maybeToList (applyOneAttr (l, expr) [])
applyOneAttr (_, RightSub iden context) params
= if elem iden (map fst lists) || elem iden (map fst folds)
then if isJust attrsForIden
then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
else if isJust attrsForIden
then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
where
newAttrs = filter (\(left, _) ->
let iden = liden left
ctxsForSort = fromJust (lookup sname ctxsBySname)
ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
) (cattrs ctor)
attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
lists = clists ctor
folds = dropFold $ cfolds ctor
sorts = csorts ctor
ef = EF {
paramForCtor = _getCtorParams,
freeVarExprForVarCtor = _varCtorFreeVar,
transformForAddAttr = _oneDeeper,
applyInhCtxsToAttrs = _applyInhCtxsToAttrs,
includeBinders = False
}
......@@ -70,10 +70,52 @@ _substExpr sname consName =
_oneDeeper namespace expr = FnCall "concat" [ListExpr (ListExpr [VarExpr "b"] : expr)]
_applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression
_applyInhCtxsToAttrs sname ctor (iden, idenAttrs) ctxsBySname
= let inhCtxs = (inhCtxsForSortName (sortNameForIden iden ctor) ctxsBySname)
in foldr (\ctx rest -> fromMaybe rest (applyOneCtx ctx rest)) (VarExpr "c") inhCtxs
where
-- | Runs `applyOneAttr` if the identifier's attribute definitions
-- contain an assignment to an instance of the given context
applyOneCtx :: Context -> Expression -> Maybe Expression
applyOneCtx ctx param
| isJust attrForCtx = applyOneAttr (fromJust attrForCtx) [param]
| otherwise = Nothing
where
attrForCtx = find (\(left, _) -> linst left == xinst ctx) idenAttrs
-- | Apply the necessary wrap based on the attribute assignment type
applyOneAttr :: AttributeDef -> [Expression] -> Maybe Expression
applyOneAttr (_, RightLHS _) _ = Nothing
applyOneAttr (l, RightAdd expr _) params
= return (_oneDeeper (xnamespace ctx) (nextStep ++ params))
where
nextStep = maybeToList (applyOneAttr (l, expr) [])
applyOneAttr (_, RightSub iden context) params
= if elem iden (map fst lists) || elem iden (map fst folds)
then if isJust attrsForIden
then return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" (VarExpr iden : nextStep) : params))
else return (FnCall ("generateHnat" ++ xnamespace ctx) (FnCall "length" [VarExpr iden] : params))
else if isJust attrsForIden
then return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) ((VarExpr iden : nextStep) ++ params))
else return (FnCall ("addToEnvironment" ++ fromJust (lookup iden sorts) ++ context) (VarExpr iden : params))
where
newAttrs = filter (\(left, _) ->
let iden = liden left
ctxsForSort = fromJust (lookup sname ctxsBySname)
ctxsForIdenSort = fromJust (lookup (sortNameForIden iden ctor) ctxsBySname)
in (iden == "" && any (\ctx -> linst left == xinst ctx) ctxsForSort) || any (\ctx -> linst left == xinst ctx) ctxsForIdenSort
) (cattrs ctor)
attrsForIden = find (\(left, _) -> liden left == iden) newAttrs
nextStep = maybeToList (applyOneAttr (fromJust attrsForIden) [])
lists = clists ctor
folds = dropFold $ cfolds ctor
sorts = csorts ctor
ef = EF {
paramForCtor = _getCtorParams,
freeVarExprForVarCtor = _varCtorFreeVar,
transformForAddAttr = _oneDeeper,
applyInhCtxsToAttrs = _applyInhCtxsToAttrs,
includeBinders = True
}
......
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