Commit 7f4c069b authored by marton bognar's avatar marton bognar
Browse files

Move capitalization changes to printing

parent d16fd7fb
......@@ -4,20 +4,21 @@ module Printer.Haskell where
import Data.Text.Prettyprint.Doc
import Program
import Utility
instance Pretty Constructor where
pretty (Constr n ts) = hsep (pretty n : map pretty ts)
pretty (Constr n ts) = hsep (pretty (upperFirst n) : map pretty ts)
instance Pretty Parameter where
pretty (VarParam n) = pretty n
pretty (ConstrParam n ps) = parens (hsep (pretty n : map pretty ps))
pretty (VarParam n) = pretty (lowerFirst n)
pretty (ConstrParam n ps) = parens (hsep (pretty (upperFirst n) : map pretty ps))
pretty (StringParam s) = pretty "\"" <> pretty s <> pretty "\""
pretty (IntParam i) = pretty i
instance Pretty Expression where
pretty (FnCall n ps) = parens $ hsep (pretty n : map pretty ps)
pretty (ConstrInst n ps) = parens $ hsep (pretty n : map pretty ps)
pretty (VarExpr x) = pretty x
pretty (FnCall n ps) = parens $ hsep (pretty (lowerFirst n) : map pretty ps)
pretty (ConstrInst n ps) = parens $ hsep (pretty (upperFirst n) : map pretty ps)
pretty (VarExpr x) = pretty (lowerFirst x)
pretty (Minus a b) = parens (pretty a <+> pretty "-" <+> pretty b)
pretty (IntExpr i) = pretty i
pretty (StringExpr s) = pretty "\"" <> pretty s <> pretty "\""
......@@ -30,7 +31,7 @@ instance Pretty Expression where
instance Pretty Function where
pretty (Fn n lns) = intoLines (map oneLine lns) where
oneLine :: ([Parameter], Expression) -> Doc a
oneLine (ps, ex) = hsep $ (pretty n : map pretty ps) ++ [pretty "=", pretty ex]
oneLine (ps, ex) = hsep $ (pretty (lowerFirst n) : map pretty ps) ++ [pretty "=", pretty ex]
nl :: Doc a
nl = pretty "\n"
......
......@@ -19,7 +19,7 @@ upperFirst (first:rest) = toUpper first : rest
-- | Return the sort name for a given namespace name in a list of namespace
-- definitions
sortNameForNamespaceName :: NamespaceName -> [NamespaceDef] -> SortName
sortNameForNamespaceName name nsd = head [lowerFirst $ nsort ns | ns <- nsd, nname ns == name]
sortNameForNamespaceName name nsd = head [nsort ns | ns <- nsd, nname ns == name]
-- | Return a list of tuples with sort names and a boolean value indicating
-- whether they access variables
......
......@@ -42,9 +42,9 @@ getEnvFunctions (nsd, sd, _, _) = let table = map snameAndCtxs sd
generateSortSynSystemOneConstructor :: SortName -> [NamespaceDef] -> [(SortName, [Context])] -> ConstructorDef -> Context -> Function
generateSortSynSystemOneConstructor sname _ _ (MkVarConstructor consName _) _ =
Fn ("addToEnvironment" ++ sname) [([ConstrParam (upperFirst consName) [VarParam "var"], VarParam "c"], VarExpr "c")]
Fn ("addToEnvironment" ++ sname) [([ConstrParam consName [VarParam "var"], VarParam "c"], VarExpr "c")]
generateSortSynSystemOneConstructor sname namespaces table ctor ctx =
Fn ("addToEnvironment" ++ sname ++ xinst ctx) [([ConstrParam (upperFirst consName) (firstToVarParams listSorts ++ [VarParam "_" | _ <- hTypes]), VarParam "c"], getEnvFunctionGenerate sname ctx namespaces newtable listSorts rules)]
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
......@@ -139,10 +139,10 @@ freeVarFunctions (_, sd, _, _) ef =
in
if fromJust (lookup sortNameOfIden varAccessBySname)
then if iden `elem` map fst folds
then [FnCall "foldMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr (lowerFirst iden)]]
then [FnCall "foldMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr iden]]
else if iden `elem` map fst lists
then [FnCall "concatMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr (lowerFirst iden)]]
else [FnCall ("freeVariables" ++ sortNameOfIden) (addedBinders : [VarExpr (lowerFirst iden)])]
then [FnCall "concatMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr iden]]
else [FnCall ("freeVariables" ++ sortNameOfIden) (addedBinders : [VarExpr iden])]
else []
) idensAndAttrs
in if null callList then [ListExpr []] else callList
......@@ -173,7 +173,7 @@ mappingFunctions (_, sd, _, _) ef =
where
-- | Return the name of the mapping function for the given sort name
mapFnForSortName :: SortName -> String
mapFnForSortName sname = lowerFirst sname ++ "map"
mapFnForSortName sname = sname ++ "map"
-- | Generate the map function's body for a given contructor in the sort
-- (a function call to the namespace's processing function in case of a variable,
......@@ -182,17 +182,17 @@ mappingFunctions (_, sd, _, _) ef =
mappingExprForCtor sortName (MkVarConstructor ctorName _) ctxsBySname _ =
FnCall ("on" ++ xnamespace (head (fromJust (lookup sortName ctxsBySname)))) [ -- TODO: this is a suspicious head call
VarExpr "c",
ConstrInst (upperFirst ctorName) [VarExpr "var"]
ConstrInst ctorName [VarExpr "var"]
]
mappingExprForCtor sortName ctor ctxsBySname varAccessBySname =
let binder = if includeBinders ef && isBind ctor then [VarExpr "b"] else []
in
ConstrInst
(upperFirst (cname ctor))
(cname ctor)
(
binder
++ map mapFnCallForIden idensAndAttrs
++ [VarExpr (lowerFirst x ++ show n) | (x, n) <- zip (cnatives ctor) [1 :: Int ..]]
++ [VarExpr (x ++ show n) | (x, n) <- zip (cnatives ctor) [1 :: Int ..]]
)
where
idensAndAttrs = attrsByIden ctor
......@@ -209,11 +209,11 @@ mappingFunctions (_, sd, _, _) ef =
mapFnCallForIden (iden, idenAttrs)
= if fromJust (lookup sortNameOfIden varAccessBySname)
then if iden `elem` map fst folds
then FnCall "fmap" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr (lowerFirst iden)]
then FnCall "fmap" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr iden]
else if iden `elem` map fst lists
then FnCall "map" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr (lowerFirst iden)]
else FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders ++ [VarExpr (lowerFirst iden)])
else VarExpr (lowerFirst iden)
then FnCall "map" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr iden]
else FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders ++ [VarExpr iden])
else VarExpr iden
where
addedBinders = [applyInhCtxsToAttrs ef sortName ctor (iden, idenAttrs) ctxsBySname]
sortNameOfIden = sortNameForIden iden ctor
......@@ -238,10 +238,10 @@ substFunctions (nsd, sd, _, _) ef =
let inhCtxs = [INH x y | INH x y <- ctxs]
in
[
Fn (lowerFirst sortName ++ "SubstituteHelp")
Fn (sortName ++ "SubstituteHelp")
[
(
[VarParam "sub", VarParam "c", ConstrParam (upperFirst ctorName) [VarParam "var"]],
[VarParam "sub", VarParam "c", ConstrParam ctorName [VarParam "var"]],
substHelperExprForVarCtor ef sortName ctorName
)
]
......@@ -258,9 +258,9 @@ substFunctions (nsd, sd, _, _) ef =
substFunctionForCtx :: SortName -> Context -> [Context] -> [NamespaceDef] -> Bool -> Function
substFunctionForCtx sortName ctx ctxs nsd rewrite
= let sortOfCtxNamespace = sortNameForNamespaceName (xnamespace ctx) nsd
mapCall = FnCall (lowerFirst sortName ++ "map") (paramFnCallsForCtxs ctx ctxs nsd ++ [VarExpr "orig", VarExpr "t"])
mapCall = FnCall (sortName ++ "map") (paramFnCallsForCtxs ctx ctxs nsd ++ [VarExpr "orig", VarExpr "t"])
in Fn
(lowerFirst sortName ++ sortOfCtxNamespace ++ "Substitute")
(sortName ++ sortOfCtxNamespace ++ "Substitute")
[
(
[VarParam "sub", VarParam "orig", VarParam "t"],
......@@ -290,7 +290,7 @@ 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 . lowerFirst . fst)
firstToVarParams = map (VarParam . fst)
-- | For every inherited context of a sort, apply nested modifiers to the
-- returned "c" variable
......
......@@ -100,13 +100,13 @@ getShiftHelpers sd opName varAccessTable = let filtered = filter (\(MkDefSort sn
where
constructorsToCheckShift :: [ConstructorDef] -> SortName -> String -> [Function]
constructorsToCheckShift cdefs sname op = [
Fn (lowerFirst sname ++ "shiftHelp" ++ op)
Fn (sname ++ "shiftHelp" ++ op)
[
([VarParam "d", VarParam "c", ConstrParam (upperFirst consName) [VarParam "var"]],
([VarParam "d", VarParam "c", ConstrParam consName [VarParam "var"]],
IfExpr
(GTEExpr (VarExpr "var") (VarExpr "c"))
(ConstrInst (upperFirst consName) [FnCall op [VarExpr "var", VarExpr "d"]])
(ConstrInst (upperFirst consName) [VarExpr "var"])
(ConstrInst consName [FnCall op [VarExpr "var", VarExpr "d"]])
(ConstrInst consName [VarExpr "var"])
)
] | MkVarConstructor consName _ <- cdefs]
......@@ -114,11 +114,11 @@ getShiftFunctions :: [SortDef] -> [NamespaceDef] -> String -> [(SortName, Bool)]
getShiftFunctions sd defs opName varAccessTable = let filtered = filter (\s -> isJust (lookup (sname s) varAccessTable)) sd
in map (\(MkDefSort sname namespaceDecl _ _) ->
Fn
(lowerFirst sname ++ "shift" ++ opName)
(sname ++ "shift" ++ opName)
[
([VarParam "d", VarParam "t"],
FnCall
(lowerFirst sname ++ "map")
(sname ++ "map")
(declarationsToFunctions namespaceDecl defs opName ++ [ConstrInst "Z" [], VarExpr "t"])
)
]
......@@ -131,8 +131,8 @@ getShiftFunctions sd defs opName varAccessTable = let filtered = filter (\s -> i
) filtered
_getCtorParams :: ConstructorDef -> [Parameter]
_getCtorParams (MkVarConstructor consName _) = [ConstrParam (upperFirst consName) [VarParam "var"]]
_getCtorParams cons = [ConstrParam (upperFirst consName) (firstToVarParams (dropFold folds ++ lists ++ sorts) ++ [VarParam (lowerFirst x ++ show n) | (x, n) <- zip hTypes [1 :: Int ..]])]
_getCtorParams (MkVarConstructor consName _) = [ConstrParam consName [VarParam "var"]]
_getCtorParams cons = [ConstrParam consName (firstToVarParams (dropFold folds ++ lists ++ sorts) ++ [VarParam (x ++ show n) | (x, n) <- zip hTypes [1 :: Int ..]])]
where
consName = cname cons
folds = cfolds cons
......@@ -147,8 +147,8 @@ _oneDeeper namespace expr = ConstrInst ("S" ++ namespace) expr
_substExpr sname consName =
IfExpr (EQExpr (VarExpr "var") (VarExpr "c"))
(FnCall (lowerFirst sname ++ "shiftplus") [VarExpr "c", VarExpr "sub"])
(ConstrInst (upperFirst consName) [VarExpr "var"])
(FnCall (sname ++ "shiftplus") [VarExpr "c", VarExpr "sub"])
(ConstrInst consName [VarExpr "var"])
ef = EF {
paramForCtor = _getCtorParams,
......
......@@ -42,8 +42,8 @@ getVariableFunctions :: Language -> (Type, [Constructor]) -> [Function]
getVariableFunctions lan _ = mappingFunctions lan ef ++ freeVarFunctions lan ef ++ substFunctionsC lan
_getCtorParams :: ConstructorDef -> [Parameter]
_getCtorParams (MkVarConstructor consName _) = [ConstrParam (upperFirst consName) [VarParam "var"]]
_getCtorParams cons = [ConstrParam (upperFirst consName) ((map (\_ -> VarParam "b") (maybeToList (cbinder cons))) ++ firstToVarParams (dropFold folds ++ lists ++ sorts) ++ [VarParam (lowerFirst x ++ show n) | (x, n) <- zip hTypes [1 :: Int ..]])]
_getCtorParams (MkVarConstructor consName _) = [ConstrParam consName [VarParam "var"]]
_getCtorParams cons = [ConstrParam consName ((map (\_ -> VarParam "b") (maybeToList (cbinder cons))) ++ firstToVarParams (dropFold folds ++ lists ++ sorts) ++ [VarParam (x ++ show n) | (x, n) <- zip hTypes [1 :: Int ..]])]
where
consName = cname cons
folds = cfolds cons
......@@ -57,7 +57,7 @@ _varCtorFreeVar name = IfExpr (FnCall "elem" [VarExpr "var", VarExpr "c"]) (List
_substExpr sname consName =
IfExpr (EQExpr (VarExpr "var") (VarExpr "c"))
(VarExpr "sub")
(ConstrInst (upperFirst consName) [VarExpr "var"])
(ConstrInst consName [VarExpr "var"])
ef = EF {
paramForCtor = _getCtorParams,
......@@ -78,7 +78,7 @@ substFunctionsC (nsd, sd, _, _) =
let inhCtxs = [INH x y | INH x y <- ctxs]
in (map (\ctx ->
let sortOfCtxNamespace = sortNameForNamespaceName (xnamespace ctx) nsd
in Fn (lowerFirst sortName ++ sortOfCtxNamespace ++ "Substitute")
in Fn (sortName ++ sortOfCtxNamespace ++ "Substitute")
(map (\ctor -> substFunctionForCtx sortName sortOfCtxNamespace ctor ctx ctxs nsd rewrite) ctors)
) inhCtxs)
) sortsWithVarAccess
......@@ -105,17 +105,21 @@ substFunctionsC (nsd, sd, _, _) =
substExprForCtor (MkVarConstructor ctorName _) =
IfExpr (EQExpr (VarExpr "var") (VarExpr "orig"))
(VarExpr "sub")
(ConstrInst (upperFirst ctorName) [VarExpr "var"])
(ConstrInst ctorName [VarExpr "var"])
substExprForCtor ctor =
ConstrInst
(upperFirst (cname ctor))
(cname ctor)
(
binder
++ map substCallForIden idensAndAttrs
++ [VarExpr (lowerFirst x ++ show n) | (x, n) <- zip (cnatives ctor) [1 :: Int ..]]
++ [VarExpr (x ++ show n) | (x, n) <- zip (cnatives ctor) [1 :: Int ..]]
)
where
binder = if isBind ctor then [FnCall ("fresh" ++ snd (fromJust (cbinder ctor))) [VarExpr "b", FnCall "concat" [ListExpr (map (\(iden, namespace) -> FnCall ("freeVariables" ++ namespace) [ListExpr [], VarExpr iden]) (dropFold (cfolds ctor) ++ clists ctor ++ csorts ctor))]]] else []
binder = if isBind ctor
then [FnCall
("fresh" ++ snd (fromJust (cbinder ctor)))
[VarExpr "b", FnCall "concat" [ListExpr (map (\(iden, namespace) -> FnCall ("freeVariables" ++ namespace) [ListExpr [], VarExpr iden]) (dropFold (cfolds ctor) ++ clists ctor ++ csorts ctor))]]]
else []
idensAndAttrs = attrsByIden ctor
folds = dropFold (cfolds ctor)
lists = clists ctor
......@@ -136,7 +140,11 @@ substFunctionsC (nsd, sd, _, _) =
else FnCall fnName (substParams ++ [idenExpr])
else idenExpr
where
fnName = lowerFirst (sortNameForIden iden ctor) ++ sortOfCtxNamespace ++ "Substitute"
idenExpr = if null binder then VarExpr (lowerFirst iden) else FnCall (lowerFirst (sortNameForIden iden ctor) ++ lowerFirst (sortName) ++ "Substitute") [VarExpr "b", head binder, VarExpr (lowerFirst iden)]
fnName = sortNameForIden iden ctor ++ sortOfCtxNamespace ++ "Substitute"
idenExpr = if null binder
then VarExpr iden
else FnCall
(sortNameForIden iden ctor ++ sortName ++ "Substitute")
[VarExpr "b", head binder, VarExpr iden]
substParams = [VarExpr "orig", VarExpr "sub"]
sortNameOfIden = sortNameForIden iden ctor
......@@ -140,7 +140,7 @@ wellFormedConstructor cons xinst = do
(getIdentifiersWithoutBinding cons)
g <-
helpWellFormedIdentifiers
(map lowerFirst (getIdentifiersWithoutBinding cons))
(getIdentifiersWithoutBinding cons)
return True
where
--get the Identifiers of the arguments of a constructor (including the binder)
......
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