Commit 5b963923 authored by marton bognar's avatar marton bognar
Browse files

Minor improvements

parent ab9c7053
......@@ -10,42 +10,44 @@ type IdenName = String
type HaskellTypeName = String
type InstanceName = String
--the inherited or synthesised contexts
-- | Definition of an inherited or a synthesized context
data Context
= INH { xinst :: InstanceName, xnamespace :: NamespaceName }
| SYN { xinst :: InstanceName, xnamespace :: NamespaceName }
deriving (Show, Eq)
--the left part of an expression like t1.ctx=lhs.ctx
-- | The left side of an attribute definition
data LeftExpr
= LeftLHS { linst :: InstanceName }
| LeftSub { _liden :: IdenName, linst :: InstanceName }
deriving (Show, Eq)
-- | Returns the identifier on the left side of the attribute definition
-- or an empty string if it is a LHS definition
liden :: LeftExpr -> IdenName
liden left@LeftSub{} = _liden left
liden _ = ""
--the right part of an expression like t1.ctx=lhs.ctx
-- | The right side of an attribute definition
data RightExpr
= RightLHS { rinst :: InstanceName }
| RightSub { riden :: IdenName, rinst :: InstanceName }
| RightAdd { rexp :: RightExpr, riden :: IdenName }
deriving (Show, Eq)
--the complete expression of like t1.ctx=lhs.ctx
-- | Attribute definition (e.g. t1.ctx = lhs.ctx, T)
type AttributeDef = (LeftExpr, RightExpr)
--the definition of a namespace declaration
-- | Namespace declaration
data NamespaceDef
= MkNameSpace {
nname :: NamespaceName,
nsort :: SortName,
nenv :: [String] -- TODO: what are the envs for?
nenv :: [String]
}
deriving (Show, Eq)
--definition of a sort
-- | Sort declaration
data SortDef
= MkDefSort {
sname :: SortName,
......@@ -55,7 +57,7 @@ data SortDef
}
deriving (Show, Eq)
--definition of a constructor
-- | Constructor declaration
data ConstructorDef
= MkDefConstructor {
cname :: ConstructorName,
......@@ -80,6 +82,8 @@ data ConstructorDef
}
deriving (Show, Eq)
-- | Returns the binder of a constructor or Nothing if it is not a bind
-- constructor
cbinder :: ConstructorDef -> Maybe (IdenName, NamespaceName)
cbinder ctor@MkBindConstructor{} = Just (_cbinder ctor)
cbinder _ = Nothing
......@@ -89,4 +93,5 @@ isBind :: ConstructorDef -> Bool
isBind MkBindConstructor{} = True
isBind _ = False
-- | Complete definition of a language
type Language = ([NamespaceDef], [SortDef], [(String, [String])], [String])
......@@ -111,7 +111,7 @@ pNameSpaceName = pIdentifier
pSortName :: Parser SortName
pSortName = pIdentifier
-- | TODO: ???
pEnvAdd :: Parser [String]
pEnvAdd =
many $ do
......
......@@ -65,7 +65,7 @@ filterCtxsByNamespace namespace contextsBySortName = [
(sortName, [ctx' | ctx' <- ctxs, xnamespace ctx' == namespace])
| (sortName, ctxs) <- contextsBySortName]
-- TODO
-- Get the sort's name and contexts as a tuple
snameAndCtxs :: SortDef -> (SortName, [Context])
snameAndCtxs s = (sname s, sctxs s)
......
......@@ -31,70 +31,60 @@ getEnvType (nsd, _, _, _) =
-- | ??
getEnvFunctions :: Language -> [Function]
getEnvFunctions (nsd, sd, _, _) = let table = map snameAndCtxs sd
in concatMap (\s ->
let nsi = [SYN x y | SYN x y <- sctxs s]
in if null nsi then [] else
map (\c ->
generateSortSynSystemOneConstructor (sname s) nsd table c (head nsi)
) (sctors s)
) sd
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
generateSortSynSystemOneConstructor :: SortName -> [NamespaceDef] -> [(SortName, [Context])] -> ConstructorDef -> Context -> Function
generateSortSynSystemOneConstructor sname _ _ (MkVarConstructor consName _) _ =
Fn ("addToEnvironment" ++ sname) [([ConstrParam consName [VarParam "var"], VarParam "c"], VarExpr "c")]
generateSortSynSystemOneConstructor sname namespaces table ctor ctx =
Fn ("addToEnvironment" ++ sname ++ xinst ctx) [([ConstrParam consName (firstToVarParams listSorts ++ [VarParam "_" | _ <- hTypes]), VarParam "c"], getEnvFunctionGenerate sname ctx namespaces newtable listSorts rules)]
where
newtable = filterCtxsByNamespace (xnamespace ctx) table
consName = cname ctor
listSorts = csorts ctor
hTypes = cnatives ctor
rules = 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))
)
getEnvFunctionGenerate :: SortName -> Context -> [NamespaceDef] -> [(SortName, [Context])] -> [(IdenName, SortName)] -> [AttributeDef] -> Expression
getEnvFunctionGenerate sname ctx namespaces table listSorts rules
| null $ fromJust (lookup "lhs" allrules) = VarExpr "c"
| otherwise = navigateRules sname ctx namespaces table listSorts rules start
where
allrules = collectRulesSyn rules listSorts
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)
collectRulesSyn :: [AttributeDef] -> [(IdenName, SortName)] -> [(IdenName, [AttributeDef])]
collectRulesSyn rules ids =
foldl
(++)
[("lhs", [(LeftLHS c, r) | (LeftLHS c, r) <- rules])]
(map (\(iden, _) -> [collectRulesOfIdSyn rules iden]) ids)
where
collectRulesOfIdSyn :: [AttributeDef] -> IdenName -> (IdenName, [AttributeDef])
collectRulesOfIdSyn nsr i = (i, filter (\(LeftSub fieldname _, RightSub _ _) -> fieldname == i) nsr)
navigateRules :: SortName -> Context -> [NamespaceDef] -> [(SortName, [Context])] -> [(IdenName, SortName)] -> [AttributeDef] -> AttributeDef -> Expression
navigateRules sname ctx namespaces table listSorts rules (l, RightAdd expr _) =
FnCall ("S" ++ xnamespace ctx) [navigateRules sname ctx namespaces table listSorts rules (l, expr)]
navigateRules _ _ _ _ _ _ (LeftLHS _, RightLHS _) =
VarExpr "c"
navigateRules sname ctx namespaces table listSorts rules (LeftLHS _, RightSub iden _)
| isJust newrule =
FnCall functionName [VarExpr iden, navigateRules sname ctx namespaces table listSorts rules (fromJust newrule)]
| otherwise = FnCall functionName [VarExpr iden, VarExpr "c"]
where
newrule = find (\(l, _) -> liden l == iden) rules
functionName = "addToEnvironment" ++ fromJust (lookup iden listSorts) ++ xinst ctx -- TODO: iden was included in function name with a space?? included here both, below once + twice!!
navigateRules _ _ _ _ _ _ (LeftSub _ _, RightLHS _) =
VarExpr "c"
navigateRules sname ctx namespaces table listSorts rules (LeftSub _ _, RightSub iden _)
| isJust newrule =
FnCall functionName [VarExpr iden, navigateRules sname ctx namespaces table listSorts rules (fromJust newrule)]
| otherwise = FnCall functionName [VarExpr iden, VarExpr "c"]
where
newrule = find (\(l, _) -> liden l == iden) rules
functionName = "addToEnvironment" ++ fromJust (lookup iden listSorts) ++ xinst ctx
navigateAttrs :: AttributeDef -> Expression
navigateAttrs (l, RightAdd expr _) = FnCall ("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
-- ----------------------------------------------------------------------------
......
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