mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Update to lts-8.23. Changes in Translate.hs due to changes in haskell-src-exts.
This commit is contained in:
parent
b6171533c5
commit
8267305950
12
app/Main.hs
12
app/Main.hs
@ -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
364
app/Translate.hs
@ -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
|
||||||
|
@ -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:
|
||||||
|
Loading…
Reference in New Issue
Block a user