rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-09-11 15:05:41 +03:00
Code Issues Projects Releases Wiki Activity

Update to lts-8.23. Changes in Translate.hs due to changes in haskell-src-exts.

Browse Source
This commit is contained in:
Robbie Gleichman 2017-07-18 23:47:28 -07:00
parent b6171533c5
commit 8267305950
3 changed files with 189 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/Main.hs
View File

@ -25,10 +25,10 @@ data CmdLineOptions = CmdLineOptions {
optionParser :: Parser CmdLineOptions optionParser :: Parser CmdLineOptions
optionParser = CmdLineOptions optionParser = CmdLineOptions
<$> argument str (metavar "INPUT_FILE" <> help "Input .hs filename") <$> argument str (metavar "INPUT_FILE" Dia.<> help "Input .hs filename")
<*> argument str (metavar "OUTPUT_FILE" <> help "Output .svg filename") <*> argument str (metavar "OUTPUT_FILE" Dia.<> help "Output .svg filename")
<*> argument auto (metavar "IMAGE_WIDTH" <> help "Output image width") <*> argument auto (metavar "IMAGE_WIDTH" Dia.<> help "Output image width")
<*> switch (short 'c' <> help "Include comments between top level declarations.") <*> switch (short 'c' Dia.<> help "Include comments between top level declarations.")
renderFile :: CmdLineOptions -> IO () renderFile :: CmdLineOptions -> IO ()
renderFile (CmdLineOptions inputFilename outputFilename imageWidth includeComments) = do renderFile (CmdLineOptions inputFilename outputFilename imageWidth includeComments) = do
@ -67,8 +67,8 @@ translateFileMain = customExecParser parserPrefs opts >>= renderFile where
opts = info (helper <*> optionParser) opts = info (helper <*> optionParser)
(fullDesc (fullDesc
<> progDesc "Translate a Haskell source file (.hs) into an SVG image." Dia.<> progDesc "Translate a Haskell source file (.hs) into an SVG image."
<> header "Glance - a visual representation of Haskell") Dia.<> header "Glance - a visual representation of Haskell")
main :: IO () main :: IO ()
main = translateFileMain main = translateFileMain

364
app/Translate.hs
View File

@ -42,15 +42,15 @@ import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
-- BEGIN Helper Functions -- -- BEGIN Helper Functions --
makeVarExp :: String -> Exp makeVarExp :: l -> String -> Exp l
makeVarExp = Var . UnQual . Ident makeVarExp l = Var l . UnQual l . Ident l
makeQVarOp :: String -> QOp makeQVarOp :: l -> String -> QOp l
makeQVarOp = QVarOp . UnQual . Ident makeQVarOp l = QVarOp l . UnQual l . Ident l
qOpToExp :: QOp -> Exp qOpToExp :: QOp l -> Exp l
qOpToExp (QVarOp n) = Var n qOpToExp (QVarOp l n) = Var l n
qOpToExp (QConOp n) = Con n qOpToExp (QConOp l n) = Con l n
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names. -- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names.
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
@ -63,7 +63,7 @@ grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef
grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np) grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np)
bindOrAltHelper :: bindOrAltHelper ::
EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState ((GraphAndRef, Maybe String), GraphAndRef) Show l => EvalContext -> Pat l -> Rhs l -> Maybe (Binds l) -> State IDState ((GraphAndRef, Maybe String), GraphAndRef)
bindOrAltHelper c pat rhs maybeWhereBinds = do bindOrAltHelper c pat rhs maybeWhereBinds = do
patGraphAndRef <- evalPattern pat patGraphAndRef <- evalPattern pat
let let
@ -83,20 +83,20 @@ patternName (GraphAndRef _ ref, mStr) = fromMaybe
-- BEGIN Names helper functions -- -- BEGIN Names helper functions --
nameToString :: Exts.Name -> String nameToString :: Exts.Name l -> String
nameToString (Ident s) = s nameToString (Ident _ s) = s
nameToString (Symbol s) = s nameToString (Symbol _ s) = s
qNameToString :: QName -> String qNameToString :: QName l -> String
qNameToString (Qual (Exts.ModuleName modName) name) = modName ++ "." ++ nameToString name qNameToString (Qual _ (Exts.ModuleName _ modName) name) = modName ++ "." ++ nameToString name
qNameToString (UnQual name) = nameToString name qNameToString (UnQual _ name) = nameToString name
qNameToString (Special UnitCon) = "()" qNameToString (Special _ (UnitCon _)) = "()"
qNameToString (Special ListCon) = "[]" qNameToString (Special _ (ListCon _)) = "[]"
qNameToString (Special FunCon) = "(->)" qNameToString (Special _ (FunCon _)) = "(->)"
qNameToString (Special (TupleCon _ n)) = nTupleString n qNameToString (Special _ (TupleCon _ _ n)) = nTupleString n
qNameToString (Special Cons) = "(:)" qNameToString (Special _ (Cons _)) = "(:)"
-- unboxed singleton tuple constructor -- unboxed singleton tuple constructor
qNameToString (Special UnboxedSingleCon) = "(# #)" qNameToString (Special _ (UnboxedSingleCon _)) = "(# #)"
-- END Names helper functions -- END Names helper functions
@ -106,19 +106,19 @@ qNameToString (Special UnboxedSingleCon) = "(# #)"
makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort) makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort)
makeLiteral = makeBox . show makeLiteral = makeBox . show
evalLit :: Exts.Literal -> State IDState (SyntaxGraph, NameAndPort) evalLit :: Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort)
evalLit (Exts.Int x) = makeLiteral x evalLit (Exts.Int _ x _) = makeLiteral x
evalLit (Exts.Char x) = makeLiteral x evalLit (Exts.Char _ x _) = makeLiteral x
evalLit (Exts.String x) = makeLiteral x evalLit (Exts.String _ x _) = makeLiteral x
-- TODO: Print the Rational as a floating point. -- TODO: Print the Rational as a floating point.
evalLit (Exts.Frac x) = makeLiteral x evalLit (Exts.Frac _ x _) = makeLiteral x
-- TODO: Test the unboxed literals -- TODO: Test the unboxed literals
evalLit (Exts.PrimInt x) = makeLiteral x evalLit (Exts.PrimInt _ x _) = makeLiteral x
evalLit (Exts.PrimWord x) = makeLiteral x evalLit (Exts.PrimWord _ x _) = makeLiteral x
evalLit (Exts.PrimFloat x) = makeLiteral x evalLit (Exts.PrimFloat _ x _) = makeLiteral x
evalLit (Exts.PrimDouble x) = makeLiteral x evalLit (Exts.PrimDouble _ x _) = makeLiteral x
evalLit (Exts.PrimChar x) = makeLiteral x evalLit (Exts.PrimChar _ x _) = makeLiteral x
evalLit (Exts.PrimString x) = makeLiteral x evalLit (Exts.PrimString _ x _) = makeLiteral x
-- END evalLit -- END evalLit
@ -189,7 +189,7 @@ makePatternGraph' applyIconName funStr argVals = (newGraph <> combinedGraph, nam
icons = [SgNamedNode applyIconName pAppNode] icons = [SgNamedNode applyIconName pAppNode]
newGraph = syntaxGraphFromNodes icons newGraph = syntaxGraphFromNodes icons
evalPApp :: QName -> [Pat] -> State IDState (SyntaxGraph, NameAndPort) evalPApp :: Show l => QName l -> [Pat l] -> State IDState (SyntaxGraph, NameAndPort)
evalPApp name patterns = case patterns of evalPApp name patterns = case patterns of
[] -> makeBox constructorName [] -> makeBox constructorName
_ -> do _ -> do
@ -201,27 +201,27 @@ evalPApp name patterns = case patterns of
-- END evalPApp -- END evalPApp
-- BEGIN evalPLit -- BEGIN evalPLit
showLiteral :: Exts.Literal -> String showLiteral :: Exts.Literal l -> String
showLiteral (Exts.Int x) = show x showLiteral (Exts.Int _ x _) = show x
showLiteral (Exts.Char x) = show x showLiteral (Exts.Char _ x _) = show x
showLiteral (Exts.String x) = show x showLiteral (Exts.String _ x _) = show x
-- TODO: Print the Rational as a floating point. -- TODO: Print the Rational as a floating point.
showLiteral (Exts.Frac x) = show x showLiteral (Exts.Frac _ x _) = show x
-- TODO: Test the unboxed literals -- TODO: Test the unboxed literals
showLiteral (Exts.PrimInt x) = show x showLiteral (Exts.PrimInt _ x _) = show x
showLiteral (Exts.PrimWord x) = show x showLiteral (Exts.PrimWord _ x _) = show x
showLiteral (Exts.PrimFloat x) = show x showLiteral (Exts.PrimFloat _ x _) = show x
showLiteral (Exts.PrimDouble x) = show x showLiteral (Exts.PrimDouble _ x _) = show x
showLiteral (Exts.PrimChar x) = show x showLiteral (Exts.PrimChar _ x _) = show x
showLiteral (Exts.PrimString x) = show x showLiteral (Exts.PrimString _ x _) = show x
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (SyntaxGraph, NameAndPort) evalPLit :: Exts.Sign l -> Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort)
evalPLit sign l = case sign of evalPLit sign l = case sign of
Exts.Signless -> evalLit l Exts.Signless _ -> evalLit l
Exts.Negative -> makeBox ('-' : showLiteral l) Exts.Negative _ -> makeBox ('-' : showLiteral l)
-- END evalPLit -- END evalPLit
evalPAsPat :: Name -> Pat -> State IDState (GraphAndRef, Maybe String) evalPAsPat :: Show l => Name l -> Pat l -> State IDState (GraphAndRef, Maybe String)
evalPAsPat n p = do evalPAsPat n p = do
(GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p (GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p
let let
@ -232,20 +232,20 @@ evalPAsPat n p = do
makePatternResult :: Functor f => f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String) makePatternResult :: Functor f => f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String)
makePatternResult = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) makePatternResult = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
evalPattern :: Pat -> State IDState (GraphAndRef, Maybe String) evalPattern :: Show l => Pat l -> State IDState (GraphAndRef, Maybe String)
evalPattern p = case p of evalPattern p = case p of
PVar n -> pure (GraphAndRef mempty (Left $ nameToString n), Nothing) PVar _ n -> pure (GraphAndRef mempty (Left $ nameToString n), Nothing)
PLit s l -> makePatternResult $ evalPLit s l PLit _ s l -> makePatternResult $ evalPLit s l
PInfixApp p1 qName p2 -> evalPattern (PApp qName [p1, p2]) PInfixApp l p1 qName p2 -> evalPattern (PApp l qName [p1, p2])
PApp name patterns -> makePatternResult $ evalPApp name patterns PApp _ name patterns -> makePatternResult $ evalPApp name patterns
-- TODO special tuple handling. -- TODO special tuple handling.
PTuple _ patterns -> PTuple l _ patterns ->
makePatternResult $ evalPApp (Exts.UnQual . Ident . nTupleString . length $ patterns) patterns makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nTupleString . length $ patterns) patterns
PList patterns -> PList l patterns ->
makePatternResult $ evalPApp (Exts.UnQual . Ident . nListString . length $ patterns) patterns makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nListString . length $ patterns) patterns
PParen pat -> evalPattern pat PParen _ pat -> evalPattern pat
PAsPat n subPat -> evalPAsPat n subPat PAsPat _ n subPat -> evalPAsPat n subPat
PWildCard -> makePatternResult $ makeBox "_" PWildCard _ -> makePatternResult $ makeBox "_"
_ -> error $ "evalPattern: No pattern in case for " ++ show p _ -> error $ "evalPattern: No pattern in case for " ++ show p
-- TODO: Other cases -- TODO: Other cases
@ -260,10 +260,10 @@ strToGraphRef c str = fmap mapper (makeBox str) where
then GraphAndRef mempty (Left str) then GraphAndRef mempty (Left str)
else grNamePortToGrRef gr else grNamePortToGrRef gr
evalQName :: QName -> EvalContext -> State IDState GraphAndRef evalQName :: QName l -> EvalContext -> State IDState GraphAndRef
evalQName qName c = case qName of evalQName qName c = case qName of
UnQual _ -> graphRef UnQual _ _ -> graphRef
Qual _ _ -> graphRef Qual _ _ _ -> graphRef
_ -> grNamePortToGrRef <$> makeBox qNameString _ -> grNamePortToGrRef <$> makeBox qNameString
where where
qNameString = qNameToString qName qNameString = qNameToString qName
@ -272,11 +272,11 @@ evalQName qName c = case qName of
-- END evalQName -- END evalQName
-- evalQOp :: QOp -> EvalContext -> State IDState GraphAndRef -- evalQOp :: QOp l -> EvalContext -> State IDState GraphAndRef
-- evalQOp (QVarOp n) = evalQName n -- evalQOp (QVarOp n) = evalQName n
-- evalQOp (QConOp n) = evalQName n -- evalQOp (QConOp n) = evalQName n
-- qOpToString :: QOp -> String -- qOpToString :: QOp l -> String
-- qOpToString (QVarOp n) = qNameToString n -- qOpToString (QVarOp n) = qNameToString n
-- qOpToString (QConOp n) = qNameToString n -- qOpToString (QConOp n) = qNameToString n
@ -288,12 +288,12 @@ evalQName qName c = case qName of
-- BEGIN apply and compose helper functions -- BEGIN apply and compose helper functions
removeParen :: Exp -> Exp removeParen :: Exp l -> Exp l
removeParen e = case e of removeParen e = case e of
Paren x -> removeParen x Paren _ x -> removeParen x
_ -> e _ -> e
evalFunExpAndArgs :: EvalContext -> LikeApplyFlavor -> (Exp, [Exp]) -> State IDState (SyntaxGraph, NameAndPort) evalFunExpAndArgs :: Show l => EvalContext -> LikeApplyFlavor -> (Exp l, [Exp l]) -> State IDState (SyntaxGraph, NameAndPort)
evalFunExpAndArgs c flavor (funExp, argExps) = do evalFunExpAndArgs c flavor (funExp, argExps) = do
funVal <- evalExp c funExp funVal <- evalExp c funExp
argVals <- mapM (evalExp c) argExps argVals <- mapM (evalExp c) argExps
@ -304,7 +304,7 @@ evalFunExpAndArgs c flavor (funExp, argExps) = do
-- BEGIN evalInfixApp -- BEGIN evalInfixApp
evalFunctionComposition :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort) evalFunctionComposition :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
evalFunctionComposition c functions = do evalFunctionComposition c functions = do
let reversedFunctios = reverse functions let reversedFunctios = reverse functions
evaluatedFunctions <- mapM (evalExp c) reversedFunctios evaluatedFunctions <- mapM (evalExp c) reversedFunctios
@ -314,43 +314,43 @@ evalFunctionComposition c functions = do
(GraphAndRef mempty neverUsedPort) evaluatedFunctions (GraphAndRef mempty neverUsedPort) evaluatedFunctions
-- | Turn (a . b . c) into [a, b, c] -- | Turn (a . b . c) into [a, b, c]
compositionToList :: Exp -> [Exp] compositionToList :: Exp l -> [Exp l]
compositionToList e = case removeParen e of compositionToList e = case removeParen e of
(InfixApp exp1 (QVarOp (UnQual (Symbol "."))) exp2) -> exp1 : compositionToList exp2 (InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2) -> exp1 : compositionToList exp2
x -> [x] x -> [x]
-- | In the general case, infix is converted to prefix. -- | In the general case, infix is converted to prefix.
-- Special cases: -- Special cases:
-- a $ b is converted to (a b) -- a $ b is converted to (a b)
-- (a . b . c) uses the compose apply icon with no argument -- (a . b . c) uses the compose apply icon with no argument
evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState GraphAndRef evalInfixApp :: Show l => l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef
evalInfixApp c e1 op e2 = case op of evalInfixApp l c e1 op e2 = case op of
QVarOp (UnQual (Symbol sym)) -> case sym of QVarOp _ (UnQual _ (Symbol _ sym)) -> case sym of
"$" -> evalExp c (App e1 e2) "$" -> evalExp c (App l e1 e2)
"." -> grNamePortToGrRef <$> evalFunctionComposition c (e1 : compositionToList e2) "." -> grNamePortToGrRef <$> evalFunctionComposition c (e1 : compositionToList e2)
_ -> defaultCase _ -> defaultCase
_ -> defaultCase _ -> defaultCase
where where
defaultCase = evalExp c $ App (App (qOpToExp op) e1) e2 defaultCase = evalExp c $ App l (App l (qOpToExp op) e1) e2
-- END evalInfixApp -- END evalInfixApp
-- BEGIN evaluateAppExpression -- BEGIN evaluateAppExpression
simplifyExp :: Exp -> Exp simplifyExp :: Exp l -> Exp l
simplifyExp e = case removeParen e of simplifyExp e = case removeParen e of
InfixApp exp1 (QVarOp (UnQual (Symbol "$"))) exp2 -> App exp1 exp2 InfixApp l exp1 (QVarOp _ (UnQual _ (Symbol _ "$"))) exp2 -> App l exp1 exp2
-- Don't convert compose to apply -- Don't convert compose to apply
InfixApp _ (QVarOp (UnQual (Symbol "."))) _ -> e InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "."))) _ -> e
App (Var (UnQual (Symbol "<$>"))) arg -> App (makeVarExp "fmap") arg App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg -> App l (makeVarExp l "fmap") arg
InfixApp exp1 op exp2 -> App (App (qOpToExp op) exp1) exp2 InfixApp l exp1 op exp2 -> App l (App l (qOpToExp op) exp1) exp2
LeftSection exp1 op -> App (qOpToExp op) exp1 LeftSection l exp1 op -> App l (qOpToExp op) exp1
x -> x x -> x
-- | Given two expressions f and x, where f is applied to x, -- | Given two expressions f and x, where f is applied to x,
-- return the nesting depth if (f x) is rendered with -- return the nesting depth if (f x) is rendered with
-- the (normal apply icon, compose apply icon) -- the (normal apply icon, compose apply icon)
applyComposeScoreHelper :: Exp -> Exp -> (Int, Int) applyComposeScoreHelper :: Exp l -> Exp l -> (Int, Int)
applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
(e1App, e1Comp) = applyComposeScore exp1 (e1App, e1Comp) = applyComposeScore exp1
(e2App, e2Comp) = applyComposeScore exp2 (e2App, e2Comp) = applyComposeScore exp2
@ -367,47 +367,47 @@ applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
-- TODO Consider putting this logic in a separate "simplifyExpression" function. -- TODO Consider putting this logic in a separate "simplifyExpression" function.
-- | Returns the amount of nesting if the App is converted to (applyNode, composeNode) -- | Returns the amount of nesting if the App is converted to (applyNode, composeNode)
applyComposeScore :: Exp -> (Int, Int) applyComposeScore :: Exp l -> (Int, Int)
applyComposeScore e = case simplifyExp e of applyComposeScore e = case simplifyExp e of
App exp1 exp2 -> applyComposeScoreHelper exp1 exp2 App _ exp1 exp2 -> applyComposeScoreHelper exp1 exp2
_ -> (0, 0) _ -> (0, 0)
-- Todo add test for this function -- Todo add test for this function
-- | Given an App expression, return -- | Given an App expression, return
-- (function, list of arguments) -- (function, list of arguments)
appExpToFuncArgs :: Exp -> (Exp, [Exp]) appExpToFuncArgs :: Exp l -> (Exp l, [Exp l])
appExpToFuncArgs e = case simplifyExp e of appExpToFuncArgs e = case simplifyExp e of
App exp1 exp2 -> (funExp, args <> [exp2]) App _ exp1 exp2 -> (funExp, args <> [exp2])
where where
(funExp, args) = appExpToFuncArgs exp1 (funExp, args) = appExpToFuncArgs exp1
x -> (x, []) x -> (x, [])
-- | Given and App expression, return -- | Given and App expression, return
-- (argument, list composed functions) -- (argument, list composed functions)
appExpToArgFuncs :: Exp -> (Exp, [Exp]) appExpToArgFuncs :: Exp l -> (Exp l, [Exp l])
appExpToArgFuncs e = case simplifyExp e of appExpToArgFuncs e = case simplifyExp e of
App exp1 exp2 -> (argExp, funcs <> [exp1]) App _ exp1 exp2 -> (argExp, funcs <> [exp1])
where where
(argExp, funcs) = appExpToArgFuncs exp2 (argExp, funcs) = appExpToArgFuncs exp2
simpleExp -> (simpleExp, []) simpleExp -> (simpleExp, [])
removeCompose :: Exp -> Exp -> Exp removeCompose :: l -> Exp l -> Exp l -> Exp l
removeCompose f x = case removeParen f of removeCompose l f x = case removeParen f of
(InfixApp f1 (QVarOp (UnQual (Symbol "."))) f2) -> App f1 $ removeCompose f2 x (InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2) -> App l f1 $ removeCompose l f2 x
_ -> App f x _ -> App l f x
-- TODO Refactor this and all sub-expressions -- TODO Refactor this and all sub-expressions
evalApp :: EvalContext -> Exp -> Exp -> State IDState (SyntaxGraph, NameAndPort) evalApp :: Show l => l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
evalApp c f e = if appScore <= compScore evalApp l c f e = if appScore <= compScore
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs noComposeExp) then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs noComposeExp)
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs noComposeExp) else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs noComposeExp)
where where
noComposeExp = removeCompose f e noComposeExp = removeCompose l f e
(appScore, compScore) = applyComposeScore noComposeExp (appScore, compScore) = applyComposeScore noComposeExp
-- END evaluateAppExpression -- END evaluateAppExpression
evalIf :: EvalContext -> Exp -> Exp -> Exp -> State IDState (SyntaxGraph, NameAndPort) evalIf :: Show l => EvalContext -> Exp l -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
evalIf c boolExp trueExp falseExp = makeGuardGraph 2 evalIf c boolExp trueExp falseExp = makeGuardGraph 2
<$> <$>
getUniqueName getUniqueName
@ -419,23 +419,23 @@ evalIf c boolExp trueExp falseExp = makeGuardGraph 2
-- BEGIN evalGeneralLet -- BEGIN evalGeneralLet
getBoundVarName :: Decl -> [String] getBoundVarName :: Show l => Decl l -> [String]
-- TODO Should evalState be used here? -- TODO Should evalState be used here?
getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState
getBoundVarName (FunBind (Match _ name _ _ _ _:_)) = [nameToString name] getBoundVarName (FunBind _ (Match _ name _ _ _:_)) = [nameToString name]
-- TODO: Other cases -- TODO: Other cases
getBoundVarName (TypeSig _ _ _) = [] getBoundVarName (TypeSig _ _ _) = []
getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl
evalBinds :: EvalContext -> Binds -> State IDState (SyntaxGraph, EvalContext) evalBinds :: Show l => EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext)
evalBinds c (BDecls decls) = evalBinds c (BDecls _ decls) =
let let
boundNames = concatMap getBoundVarName decls boundNames = concatMap getBoundVarName decls
augmentedContext = boundNames <> c augmentedContext = boundNames <> c
in in
((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls ((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls
evalGeneralLet :: (EvalContext -> State IDState GraphAndRef) -> EvalContext -> Binds -> State IDState GraphAndRef evalGeneralLet :: Show l => (EvalContext -> State IDState GraphAndRef) -> EvalContext -> Binds l-> State IDState GraphAndRef
evalGeneralLet expOrRhsEvaler c bs = do evalGeneralLet expOrRhsEvaler c bs = do
(bindGraph, bindContext) <- evalBinds c bs (bindGraph, bindContext) <- evalBinds c bs
expVal <- expOrRhsEvaler bindContext expVal <- expOrRhsEvaler bindContext
@ -447,21 +447,21 @@ evalGeneralLet expOrRhsEvaler c bs = do
-- END evalGeneralLet -- END evalGeneralLet
evalLet :: EvalContext -> Binds -> Exp -> State IDState GraphAndRef evalLet :: Show l => EvalContext -> Binds l -> Exp l-> State IDState GraphAndRef
evalLet context binds e = evalGeneralLet (`evalExp` e) context binds evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
-- BEGIN rhsWithBinds -- BEGIN rhsWithBinds
evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef evalStmt :: Show l => EvalContext -> Stmt l -> State IDState GraphAndRef
evalStmt c (Qualifier e) = evalExp c e evalStmt c (Qualifier _ e) = evalExp c e
evalStmts :: EvalContext -> [Stmt] -> State IDState GraphAndRef evalStmts :: Show l => EvalContext -> [Stmt l] -> State IDState GraphAndRef
evalStmts c [stmt] = evalStmt c stmt evalStmts c [stmt] = evalStmt c stmt
evalGuardedRhs :: EvalContext -> GuardedRhs -> State IDState (GraphAndRef, GraphAndRef) evalGuardedRhs :: Show l => EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef)
evalGuardedRhs c (GuardedRhs _ stmts e) = (,) <$> evalStmts c stmts <*> evalExp c e evalGuardedRhs c (GuardedRhs _ stmts e) = (,) <$> evalStmts c stmts <*> evalExp c e
evalGuardedRhss :: EvalContext -> [GuardedRhs] -> State IDState (SyntaxGraph, NameAndPort) evalGuardedRhss :: Show l => EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort)
evalGuardedRhss c rhss = let evalGuardedRhss c rhss = let
evaledRhss = unzip <$> mapM (evalGuardedRhs c) rhss evaledRhss = unzip <$> mapM (evalGuardedRhs c) rhss
in in
@ -475,11 +475,11 @@ evalGuardedRhss c rhss = let
-- | First argument is the right hand side. -- | First argument is the right hand side.
-- The second arugement is a list of strings that are bound in the environment. -- The second arugement is a list of strings that are bound in the environment.
evalRhs :: EvalContext -> Rhs -> State IDState GraphAndRef evalRhs :: Show l => EvalContext -> Rhs l -> State IDState GraphAndRef
evalRhs c (UnGuardedRhs e) = evalExp c e evalRhs c (UnGuardedRhs _ e) = evalExp c e
evalRhs c (GuardedRhss rhss) = grNamePortToGrRef <$> evalGuardedRhss c rhss evalRhs c (GuardedRhss _ rhss) = grNamePortToGrRef <$> evalGuardedRhss c rhss
rhsWithBinds :: Maybe Binds -> Rhs -> EvalContext -> State IDState GraphAndRef rhsWithBinds :: Show l => Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef
rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
Nothing -> evalRhs rhsContext rhs Nothing -> evalRhs rhsContext rhs
Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b
@ -489,7 +489,7 @@ rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
-- BEGIN evalCase -- BEGIN evalCase
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a name -- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a name
evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) evalPatAndRhs :: Show l => EvalContext -> Pat l-> Rhs l -> Maybe (Binds l) -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
evalPatAndRhs c pat rhs maybeWhereBinds = do evalPatAndRhs c pat rhs maybeWhereBinds = do
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
bindOrAltHelper c pat rhs maybeWhereBinds bindOrAltHelper c pat rhs maybeWhereBinds
@ -503,7 +503,7 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef, mPatAsName) pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef, mPatAsName)
-- returns (combined graph, pattern reference, rhs reference) -- returns (combined graph, pattern reference, rhs reference)
evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) evalAlt :: Show l => EvalContext -> Exts.Alt l -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
evalCaseHelper :: evalCaseHelper ::
@ -543,7 +543,7 @@ evalCaseHelper numAlts caseIconName resultIconNames (GraphAndRef expGraph expRef
result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) result = (finalGraph, nameAndPort caseIconName (resultPort caseNode))
evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (SyntaxGraph, NameAndPort) evalCase :: Show l => EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort)
evalCase c e alts = evalCase c e alts =
let let
numAlts = length alts numAlts = length alts
@ -560,7 +560,7 @@ evalCase c e alts =
-- END evalCase -- END evalCase
evalTuple :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort) evalTuple :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
evalTuple c exps = evalTuple c exps =
let let
numExps = length exps numExps = length exps
@ -573,7 +573,7 @@ evalTuple c exps =
<*> <*>
mapM (evalExp c) exps mapM (evalExp c) exps
evalTupleSection :: EvalContext -> [Maybe Exp] -> State IDState (SyntaxGraph, NameAndPort) evalTupleSection :: Show l => EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort)
evalTupleSection c mExps = evalTupleSection c mExps =
let let
exps = catMaybes mExps exps = catMaybes mExps
@ -587,14 +587,14 @@ evalTupleSection c mExps =
<*> <*>
mapM (evalExp c) exps mapM (evalExp c) exps
evalListExp :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort) evalListExp :: Show l => l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
evalListExp _ [] = makeBox "[]" evalListExp _ _ [] = makeBox "[]"
evalListExp c exps = evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp . nListString . length $ exps, exps) evalListExp l c exps = evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l . nListString . length $ exps, exps)
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState GraphAndRef evalLeftSection :: Show l => l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef
evalLeftSection c e op = evalExp c $ App (qOpToExp op) e evalLeftSection l c e op = evalExp c $ App l (qOpToExp op) e
evalRightSection :: EvalContext -> QOp -> Exp -> State IDState (SyntaxGraph, NameAndPort) evalRightSection :: Show l => EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
evalRightSection c op e = evalRightSection c op e =
makeApplyGraph 2 ApplyNodeFlavor False makeApplyGraph 2 ApplyNodeFlavor False
<$> <$>
@ -610,19 +610,19 @@ evalRightSection c op e =
) )
-- evalEnums is only used by evalExp -- evalEnums is only used by evalExp
evalEnums :: EvalContext -> String -> [Exp] -> State IDState GraphAndRef evalEnums :: Show l => l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef
evalEnums c s exps = grNamePortToGrRef <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp s, exps) evalEnums l c s exps = grNamePortToGrRef <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps)
desugarDo :: [Stmt] -> Exp desugarDo :: [Stmt l] -> Exp l
desugarDo [Qualifier e] = e desugarDo [Qualifier _ e] = e
desugarDo (Qualifier e : stmts) = InfixApp e thenOp (desugarDo stmts) desugarDo (Qualifier l e : stmts) = InfixApp l e thenOp (desugarDo stmts)
where thenOp = makeQVarOp ">>" where thenOp = makeQVarOp l ">>"
desugarDo (Generator srcLoc pat e : stmts) = desugarDo (Generator l pat e : stmts) =
InfixApp e (makeQVarOp ">>=") (Lambda srcLoc [pat] (desugarDo stmts)) InfixApp l e (makeQVarOp l ">>=") (Lambda l [pat] (desugarDo stmts))
desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts) desugarDo (LetStmt l binds : stmts) = Let l binds (desugarDo stmts)
-- TODO: Finish evalRecConstr -- TODO: Finish evalRecConstr
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState GraphAndRef evalRecConstr :: EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef
evalRecConstr c qName _ = evalQName qName c evalRecConstr c qName _ = evalQName qName c
-- BEGIN generalEvalLambda -- BEGIN generalEvalLambda
@ -631,7 +631,7 @@ evalRecConstr c qName _ = evalQName qName c
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName] asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort) generalEvalLambda :: Show l => EvalContext -> [Pat l] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
generalEvalLambda context patterns rhsEvalFun = do generalEvalLambda context patterns rhsEvalFun = do
lambdaName <- getUniqueName lambdaName <- getUniqueName
patternValsWithAsNames <- mapM evalPattern patterns patternValsWithAsNames <- mapM evalPattern patterns
@ -669,36 +669,36 @@ generalEvalLambda context patterns rhsEvalFun = do
-- END generalEvalLambda -- END generalEvalLambda
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (SyntaxGraph, NameAndPort) evalLambda :: Show l => EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e) evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
evalExp :: EvalContext -> Exp -> State IDState GraphAndRef evalExp :: Show l => EvalContext -> Exp l -> State IDState GraphAndRef
evalExp c x = case x of evalExp c x = case x of
Var n -> evalQName n c Var _ n -> evalQName n c
Con n -> evalQName n c Con _ n -> evalQName n c
Lit l -> grNamePortToGrRef <$> evalLit l Lit _ l -> grNamePortToGrRef <$> evalLit l
InfixApp e1 op e2 -> evalInfixApp c e1 op e2 InfixApp l e1 op e2 -> evalInfixApp l c e1 op e2
App f arg -> grNamePortToGrRef <$> evalApp c f arg App l f arg -> grNamePortToGrRef <$> evalApp l c f arg
NegApp e -> evalExp c (App (makeVarExp "negate") e) NegApp l e -> evalExp c (App l (makeVarExp l "negate") e)
Lambda _ patterns e -> grNamePortToGrRef <$> evalLambda c patterns e Lambda _ patterns e -> grNamePortToGrRef <$> evalLambda c patterns e
Let bs e -> evalLet c bs e Let _ bs e -> evalLet c bs e
If e1 e2 e3 -> grNamePortToGrRef <$> evalIf c e1 e2 e3 If _ e1 e2 e3 -> grNamePortToGrRef <$> evalIf c e1 e2 e3
Case e alts -> grNamePortToGrRef <$> evalCase c e alts Case _ e alts -> grNamePortToGrRef <$> evalCase c e alts
Do stmts -> evalExp c (desugarDo stmts) Do _ stmts -> evalExp c (desugarDo stmts)
-- TODO special tuple symbol -- TODO special tuple symbol
Tuple _ exps -> grNamePortToGrRef <$> evalTuple c exps Tuple _ _ exps -> grNamePortToGrRef <$> evalTuple c exps
TupleSection _ mExps -> grNamePortToGrRef <$> evalTupleSection c mExps TupleSection _ _ mExps -> grNamePortToGrRef <$> evalTupleSection c mExps
List exps -> grNamePortToGrRef <$> evalListExp c exps List l exps -> grNamePortToGrRef <$> evalListExp l c exps
Paren e -> evalExp c e Paren _ e -> evalExp c e
LeftSection e op -> evalLeftSection c e op LeftSection l e op -> evalLeftSection l c e op
RightSection op e -> grNamePortToGrRef <$> evalRightSection c op e RightSection _ op e -> grNamePortToGrRef <$> evalRightSection c op e
RecConstr n updates -> evalRecConstr c n updates RecConstr _ n updates -> evalRecConstr c n updates
-- TODO: Do RecUpdate correcly -- TODO: Do RecUpdate correcly
RecUpdate e _ -> evalExp c e RecUpdate _ e _ -> evalExp c e
EnumFrom e -> evalEnums c "enumFrom" [e] EnumFrom l e -> evalEnums l c "enumFrom" [e]
EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2] EnumFromTo l e1 e2 -> evalEnums l c "enumFromTo" [e1, e2]
EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2] EnumFromThen l e1 e2 -> evalEnums l c "enumFromThen" [e1, e2]
EnumFromThenTo e1 e2 e3 -> evalEnums c "enumFromThenTo" [e1, e2, e3] EnumFromThenTo l e1 e2 e3 -> evalEnums l c "enumFromThenTo" [e1, e2, e3]
-- TODO: Add the type signiture to ExpTypeSig. -- TODO: Add the type signiture to ExpTypeSig.
ExpTypeSig _ e _ -> evalExp c e ExpTypeSig _ e _ -> evalExp c e
-- TODO: Add other cases -- TODO: Add other cases
@ -709,33 +709,33 @@ evalExp c x = case x of
-- BEGIN evalMatches -- BEGIN evalMatches
-- Only used by matchesToCase -- Only used by matchesToCase
matchToAlt :: Match -> Alt matchToAlt :: Match l -> Alt l
matchToAlt (Match srcLocation _ mtaPats _ rhs binds) = Alt srcLocation altPattern rhs binds where matchToAlt (Match l _ mtaPats rhs binds) = Alt l altPattern rhs binds where
altPattern = case mtaPats of altPattern = case mtaPats of
[onePat] -> onePat [onePat] -> onePat
_ -> PTuple Exts.Boxed mtaPats _ -> PTuple l Exts.Boxed mtaPats
matchesToCase :: Match -> [Match] -> State IDState Match matchesToCase :: Match l -> [Match l] -> State IDState (Match l)
matchesToCase match [] = pure match matchesToCase match [] = pure match
matchesToCase firstMatch@(Match srcLoc funName pats mType _ _) restOfMatches = do matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
-- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar" -- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
tempStrings <- replicateM (length pats) (getUniqueString " tempvar") tempStrings <- replicateM (length pats) (getUniqueString " tempvar")
let let
tempPats = fmap (PVar . Ident) tempStrings tempPats = fmap (PVar srcLoc . Ident srcLoc) tempStrings
tempVars = fmap makeVarExp tempStrings tempVars = fmap (makeVarExp srcLoc) tempStrings
tuple = Tuple Exts.Boxed tempVars tuple = Tuple srcLoc Exts.Boxed tempVars
caseExp = case tempVars of caseExp = case tempVars of
[oneTempVar] -> Case oneTempVar alts [oneTempVar] -> Case srcLoc oneTempVar alts
_ -> Case tuple alts _ -> Case srcLoc tuple alts
rhs = UnGuardedRhs caseExp rhs = UnGuardedRhs srcLoc caseExp
match = Match srcLoc funName tempPats mType rhs Nothing match = Match srcLoc funName tempPats rhs Nothing
pure match pure match
where where
allMatches = firstMatch:restOfMatches allMatches = firstMatch:restOfMatches
alts = fmap matchToAlt allMatches alts = fmap matchToAlt allMatches
evalMatch :: EvalContext -> Match -> State IDState SyntaxGraph evalMatch :: Show l => EvalContext -> (Match l) -> State IDState SyntaxGraph
evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do
let let
matchFunNameString = nameToString name matchFunNameString = nameToString name
newContext = matchFunNameString : c newContext = matchFunNameString : c
@ -745,13 +745,13 @@ evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do
newBinding = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)] newBinding = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)]
pure $ makeEdges (newBinding <> lambdaGraph) pure $ makeEdges (newBinding <> lambdaGraph)
evalMatches :: EvalContext -> [Match] -> State IDState SyntaxGraph evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph
evalMatches _ [] = pure mempty evalMatches _ [] = pure mempty
evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c
-- END evalMatches -- END evalMatches
evalPatBind :: EvalContext -> Decl -> State IDState SyntaxGraph evalPatBind :: Show l => EvalContext -> Decl l -> State IDState SyntaxGraph
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
bindOrAltHelper c pat rhs maybeWhereBinds bindOrAltHelper c pat rhs maybeWhereBinds
@ -767,7 +767,7 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
-- Pretty printing the entire type sig results in extra whitespace in the middle -- Pretty printing the entire type sig results in extra whitespace in the middle
-- TODO May want to trim whitespace from (prettyPrint typeForNames) -- TODO May want to trim whitespace from (prettyPrint typeForNames)
evalTypeSig :: Decl -> State IDState (SyntaxGraph, NameAndPort) evalTypeSig :: Decl l -> State IDState (SyntaxGraph, NameAndPort)
evalTypeSig (TypeSig _ names typeForNames) = makeBox evalTypeSig (TypeSig _ names typeForNames) = makeBox
(intercalate "," (fmap prettyPrintWithoutNewlines names) (intercalate "," (fmap prettyPrintWithoutNewlines names)
++ " :: " ++ " :: "
@ -777,10 +777,10 @@ evalTypeSig (TypeSig _ names typeForNames) = makeBox
-- Use (unwords . words) to convert consecutive whitspace characters to one space -- Use (unwords . words) to convert consecutive whitspace characters to one space
prettyPrintWithoutNewlines = unwords . words . prettyPrint prettyPrintWithoutNewlines = unwords . words . prettyPrint
evalDecl :: EvalContext -> Decl -> State IDState SyntaxGraph evalDecl :: Show l => EvalContext -> Decl l -> State IDState SyntaxGraph
evalDecl c d = case d of evalDecl c d = case d of
PatBind _ _ _ _ -> evalPatBind c d PatBind _ _ _ _ -> evalPatBind c d
FunBind matches -> evalMatches c matches FunBind _ matches -> evalMatches c matches
TypeSig _ _ _ -> fst <$> evalTypeSig d TypeSig _ _ _ -> fst <$> evalTypeSig d
--TODO: Add other cases here --TODO: Add other cases here
_ -> pure mempty _ -> pure mempty
@ -804,7 +804,7 @@ showTopLevelBinds gr = do
newGraph <- mconcat <$> mapM addBind binds newGraph <- mconcat <$> mapM addBind binds
pure $ newGraph <> gr pure $ newGraph <> gr
translateDeclToSyntaxGraph :: Decl -> SyntaxGraph translateDeclToSyntaxGraph :: Show l => Decl l -> SyntaxGraph
translateDeclToSyntaxGraph d = graph where translateDeclToSyntaxGraph d = graph where
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
graph = evalState evaluatedDecl initialIdState graph = evalState evaluatedDecl initialIdState
@ -818,7 +818,7 @@ customParseMode = Exts.defaultParseMode
] ]
} }
customParseDecl :: String -> Decl customParseDecl :: String -> Decl Exts.SrcSpanInfo
customParseDecl = fromParseResult . parseDeclWithMode customParseMode customParseDecl = fromParseResult . parseDeclWithMode customParseMode
-- | Convert a single function declaration into a SyntaxGraph -- | Convert a single function declaration into a SyntaxGraph
@ -828,16 +828,16 @@ translateStringToSyntaxGraph = translateDeclToSyntaxGraph . customParseDecl
syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
translateDeclToCollapsedGraph :: Decl -> IngSyntaxGraph FGR.Gr translateDeclToCollapsedGraph :: Show l => Decl l -> IngSyntaxGraph FGR.Gr
translateDeclToCollapsedGraph = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph translateDeclToCollapsedGraph = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph
-- Profiling: At one point, this was about 1.5% of total time. -- Profiling: At one point, this was about 1.5% of total time.
translateStringToCollapsedGraphAndDecl :: String -> (IngSyntaxGraph FGR.Gr, Decl) translateStringToCollapsedGraphAndDecl :: String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo)
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
decl = customParseDecl s -- :: ParseResult Module decl = customParseDecl s -- :: ParseResult Module
drawing = translateDeclToCollapsedGraph decl drawing = translateDeclToCollapsedGraph decl
translateModuleToCollapsedGraphs :: Module -> [IngSyntaxGraph FGR.Gr] translateModuleToCollapsedGraphs :: Show l => Module l -> [IngSyntaxGraph FGR.Gr]
translateModuleToCollapsedGraphs (Module _ _ _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls translateModuleToCollapsedGraphs (Module _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls
-- END Exported functions -- END Exported functions

2
stack.yaml
View File

@ -1,7 +1,7 @@
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-7.14 resolver: lts-8.23
# Local packages, usually specified by relative directory name # Local packages, usually specified by relative directory name
packages: packages: