mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add SyntaxGraph. Replace IconGraph with SyntaxGraph in Translate.hs.
This commit is contained in:
parent
65fdc1006d
commit
58a757d41a
@ -23,7 +23,7 @@ import Diagrams.Prelude hiding ((&), (#))
|
|||||||
-- import Diagrams.Backend.SVG(B)
|
-- import Diagrams.Backend.SVG(B)
|
||||||
--import Diagrams.TwoD.Text(Text)
|
--import Diagrams.TwoD.Text(Text)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
import Data.Maybe(fromMaybe)
|
--import Data.Maybe(fromMaybe)
|
||||||
|
|
||||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend)
|
import Types(Icon(..), SpecialQDiagram, SpecialBackend)
|
||||||
import Util(fromMaybeError)
|
import Util(fromMaybeError)
|
||||||
|
@ -14,6 +14,8 @@ import Translate(drawingsFromModule)
|
|||||||
|
|
||||||
|
|
||||||
-- TODO Now --
|
-- TODO Now --
|
||||||
|
-- Rewrite Translate to generate an abstract computation graph that is then transformed (eg. find tree sections)
|
||||||
|
-- - and turned into an Icon graph.
|
||||||
-- Fix icon nesting if a non-nestable icon (eg. flatLambdaIcon) is part of the expression.
|
-- Fix icon nesting if a non-nestable icon (eg. flatLambdaIcon) is part of the expression.
|
||||||
-- - eg. y = f $ g (\x -> x)
|
-- - eg. y = f $ g (\x -> x)
|
||||||
|
|
||||||
|
201
app/Translate.hs
201
app/Translate.hs
@ -16,17 +16,16 @@ import Control.Monad.State(State, evalState)
|
|||||||
import Data.Either(partitionEithers)
|
import Data.Either(partitionEithers)
|
||||||
import Data.List(unzip4, partition)
|
import Data.List(unzip4, partition)
|
||||||
import Control.Monad(replicateM)
|
import Control.Monad(replicateM)
|
||||||
import Data.Maybe(catMaybes)
|
--import Data.Maybe(catMaybes)
|
||||||
|
|
||||||
import Types(Drawing(..), NameAndPort(..), IDState,
|
import Types(Drawing(..), NameAndPort(..), IDState,
|
||||||
initialIdState, Edge)
|
initialIdState, Edge, SyntaxNode(..))
|
||||||
import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst, eitherToMaybes)
|
import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst)
|
||||||
import Icons(Icon(..))
|
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef,
|
||||||
import TranslateCore(Reference, IconGraph(..), Sink, EvalContext, GraphAndRef,
|
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions,
|
||||||
iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions,
|
|
||||||
edgesForRefPortList, iconGraphToDrawing, makeApplyGraph,
|
edgesForRefPortList, iconGraphToDrawing, makeApplyGraph,
|
||||||
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
||||||
coerceExpressionResult, makeBox, nTupleString, nListString)
|
coerceExpressionResult, makeBox, nTupleString, nListString, syntaxGraphToIconGraph)
|
||||||
|
|
||||||
-- OVERVIEW --
|
-- OVERVIEW --
|
||||||
-- The core functions and data types used in this module are in TranslateCore.
|
-- The core functions and data types used in this module are in TranslateCore.
|
||||||
@ -49,17 +48,17 @@ qNameToString (Special Cons) = "(:)"
|
|||||||
-- unboxed singleton tuple constructor
|
-- unboxed singleton tuple constructor
|
||||||
qNameToString (Special UnboxedSingleCon) = "(# #)"
|
qNameToString (Special UnboxedSingleCon) = "(# #)"
|
||||||
|
|
||||||
evalPApp :: QName -> [Pat] -> State IDState (IconGraph, NameAndPort)
|
evalPApp :: QName -> [Pat] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalPApp name [] = makeBox $ qNameToString name
|
evalPApp name [] = makeBox $ qNameToString name
|
||||||
evalPApp name patterns = do
|
evalPApp name patterns = do
|
||||||
patName <- DIA.toName <$> getUniqueName "pat"
|
patName <- DIA.toName <$> getUniqueName "pat"
|
||||||
evaledPatterns <- mapM evalPattern patterns
|
evaledPatterns <- mapM evalPattern patterns
|
||||||
let
|
let
|
||||||
constructorName = qNameToString name
|
constructorName = qNameToString name
|
||||||
gr = makeTextApplyGraph True patName (Left constructorName) evaledPatterns (length evaledPatterns)
|
gr = makePatternGraph patName constructorName evaledPatterns (length evaledPatterns)
|
||||||
pure gr
|
pure gr
|
||||||
|
|
||||||
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (IconGraph, NameAndPort)
|
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalPLit Exts.Signless l = evalLit l
|
evalPLit Exts.Signless l = evalLit l
|
||||||
evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
|
evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
|
||||||
|
|
||||||
@ -68,7 +67,7 @@ evalPAsPat n p = do
|
|||||||
(evaledPatGraph, evaledPatRef) <- evalPattern p
|
(evaledPatGraph, evaledPatRef) <- evalPattern p
|
||||||
let
|
let
|
||||||
newBind = [(nameToString n, evaledPatRef)]
|
newBind = [(nameToString n, evaledPatRef)]
|
||||||
newGraph = IconGraph mempty mempty mempty mempty newBind
|
newGraph = SyntaxGraph mempty mempty mempty newBind
|
||||||
pure (newGraph <> evaledPatGraph, evaledPatRef)
|
pure (newGraph <> evaledPatGraph, evaledPatRef)
|
||||||
|
|
||||||
evalPattern :: Pat -> State IDState GraphAndRef
|
evalPattern :: Pat -> State IDState GraphAndRef
|
||||||
@ -89,98 +88,50 @@ evalPattern p = case p of
|
|||||||
-- TODO: Other cases
|
-- TODO: Other cases
|
||||||
|
|
||||||
-- strToGraphRef is not in TranslateCore, since it is only used by evalQName.
|
-- strToGraphRef is not in TranslateCore, since it is only used by evalQName.
|
||||||
strToGraphRef :: EvalContext -> String -> State IDState (IconGraph, Reference)
|
strToGraphRef :: EvalContext -> String -> State IDState (SyntaxGraph, Reference)
|
||||||
strToGraphRef c str = fmap mapper (makeBox str) where
|
strToGraphRef c str = fmap mapper (makeBox str) where
|
||||||
mapper gr = if str `elem` c
|
mapper gr = if str `elem` c
|
||||||
then (mempty, Left str)
|
then (mempty, Left str)
|
||||||
else fmap Right gr
|
else fmap Right gr
|
||||||
|
|
||||||
evalQName :: QName -> EvalContext -> State IDState (IconGraph, Reference)
|
evalQName :: QName -> EvalContext -> State IDState (SyntaxGraph, Reference)
|
||||||
evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName)
|
evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName)
|
||||||
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName)
|
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName)
|
||||||
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName)
|
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName)
|
||||||
|
|
||||||
-- evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
|
-- evalQOp :: QOp -> EvalContext -> State IDState (SyntaxGraph, Reference)
|
||||||
-- 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 -> String
|
||||||
qOpToString (QVarOp n) = qNameToString n
|
-- qOpToString (QVarOp n) = qNameToString n
|
||||||
qOpToString (QConOp n) = qNameToString n
|
-- qOpToString (QConOp n) = qNameToString n
|
||||||
|
|
||||||
decideIfNested :: ((IconGraph, t1), t) ->
|
--findReferencedIcon :: Reference -> [(DIA.Name, Icon)] -> Maybe (Name, Icon)
|
||||||
(Maybe ((IconGraph, t1), t), Maybe (DIA.Name, Icon), [Sink], [(String, Reference)])
|
-- findReferencedIcon :: Either t NameAndPort -> [(DIA.Name, t1)] -> Maybe (DIA.Name, t1)
|
||||||
decideIfNested ((IconGraph [nameAndIcon] [] [] sinks bindings, _), _) = (Nothing, Just nameAndIcon, sinks, bindings)
|
-- findReferencedIcon (Left str) _ = Nothing
|
||||||
decideIfNested valAndPort = (Just valAndPort, Nothing, [], [])
|
-- findReferencedIcon (Right (NameAndPort name _)) nameIconMap = (\x -> (name, x)) <$> lookup name nameIconMap
|
||||||
|
|
||||||
makeTextApplyGraph :: Bool -> DIA.Name -> Either String GraphAndRef-> [GraphAndRef] -> Int -> (IconGraph, NameAndPort)
|
makePatternGraph :: DIA.Name -> String -> [(SyntaxGraph, Reference)] -> Int -> (SyntaxGraph, NameAndPort)
|
||||||
makeTextApplyGraph inPattern applyIconName funStrOrVal argVals numArgs = result
|
makePatternGraph applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||||
where
|
|
||||||
(funStr, maybeFunVal) = eitherToMaybes funStrOrVal
|
|
||||||
result = nestedApplyResult
|
|
||||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
|
||||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts)
|
|
||||||
qualifiedSinks = map qualifySink (mconcat nestedSinks)
|
|
||||||
qualifySink (str, NameAndPort n p) = (str, NameAndPort (applyIconName DIA..> n) p)
|
|
||||||
|
|
||||||
qualifiedBinds = map qualifyBinds (mconcat nestedBindings)
|
|
||||||
qualifyBinds (str, ref) = (str, qualifiedRef) where
|
|
||||||
qualifiedRef = case ref of
|
|
||||||
Left _ -> ref
|
|
||||||
Right (NameAndPort n p) -> Right $ NameAndPort (applyIconName DIA..> n) p
|
|
||||||
|
|
||||||
functionPort = nameAndPort applyIconName 0
|
|
||||||
|
|
||||||
originalPortExpPairs = (catMaybes unnestedArgsAndPort)
|
|
||||||
portExpressionPairs = case maybeFunVal of
|
|
||||||
Just funVal -> (funVal, functionPort) : originalPortExpPairs
|
|
||||||
Nothing -> originalPortExpPairs
|
|
||||||
combinedGraph = combineExpressions inPattern portExpressionPairs
|
|
||||||
icon = if inPattern
|
|
||||||
then NestedPApp
|
|
||||||
else NestedApply
|
|
||||||
icons = [(applyIconName, icon funStr nestedArgs)]
|
|
||||||
newGraph = IconGraph icons [] [] qualifiedSinks qualifiedBinds
|
|
||||||
nestedApplyResult = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
|
||||||
|
|
||||||
|
|
||||||
makeTextApplyGraph' :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
|
||||||
makeTextApplyGraph' inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
|
||||||
where
|
where
|
||||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||||
combinedGraph = combineExpressions inPattern $ zip argVals argumentPorts
|
combinedGraph = combineExpressions True $ zip argVals argumentPorts
|
||||||
icon = if inPattern
|
icons = [(applyIconName, PatternApplyNode funStr numArgs)]
|
||||||
then PAppIcon
|
newGraph = syntaxGraphFromNodes icons
|
||||||
else TextApplyAIcon
|
|
||||||
icons = [(applyIconName, icon numArgs funStr)]
|
|
||||||
newGraph = iconGraphFromIcons icons
|
|
||||||
|
|
||||||
evalApp :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort)
|
evalApp :: EvalContext -> (Exp, [Exp]) -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalApp c exps@(funExp, argExps) = case funExp of
|
evalApp c exps@(funExp, argExps) = do
|
||||||
(Var n) -> makeTextApp n
|
|
||||||
(Con n) -> makeTextApp n
|
|
||||||
_ -> evalAppNoText c exps
|
|
||||||
where
|
|
||||||
makeTextApp funName = let funStr = qNameToString funName in
|
|
||||||
if funStr `elem` c
|
|
||||||
then evalAppNoText c exps
|
|
||||||
else do
|
|
||||||
argVals <- mapM (evalExp c) argExps
|
|
||||||
applyIconName <- DIA.toName <$> getUniqueName "app0"
|
|
||||||
pure $ makeTextApplyGraph False applyIconName (Left funStr) argVals (length argExps)
|
|
||||||
|
|
||||||
evalAppNoText :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort)
|
|
||||||
evalAppNoText c (funExp, argExps) = do
|
|
||||||
funVal <- evalExp c funExp
|
funVal <- evalExp c funExp
|
||||||
argVals <- mapM (evalExp c) argExps
|
argVals <- mapM (evalExp c) argExps
|
||||||
applyIconName <- DIA.toName <$> getUniqueName "app0"
|
applyIconName <- DIA.toName <$> getUniqueName "app0"
|
||||||
pure $ makeTextApplyGraph False applyIconName (Right funVal) argVals (length argExps)
|
pure $ makeApplyGraph False applyIconName funVal argVals (length argExps)
|
||||||
|
|
||||||
qOpToExp :: QOp -> Exp
|
qOpToExp :: QOp -> Exp
|
||||||
qOpToExp (QVarOp n) = Var n
|
qOpToExp (QVarOp n) = Var n
|
||||||
qOpToExp (QConOp n) = Con n
|
qOpToExp (QConOp n) = Con n
|
||||||
|
|
||||||
evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState (IconGraph, Reference)
|
evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState (SyntaxGraph, Reference)
|
||||||
evalInfixApp c e1 (QVarOp (UnQual (Symbol "$"))) e2 = evalExp c (App e1 e2)
|
evalInfixApp c e1 (QVarOp (UnQual (Symbol "$"))) e2 = evalExp c (App e1 e2)
|
||||||
evalInfixApp c e1 op e2 = fmap Right <$> evalApp c (qOpToExp op, [e1, e2])
|
evalInfixApp c e1 op e2 = fmap Right <$> evalApp c (qOpToExp op, [e1, e2])
|
||||||
|
|
||||||
@ -191,17 +142,17 @@ simplifyApp (App exp1 exp2) = (funExp, args <> [exp2])
|
|||||||
(funExp, args) = simplifyApp exp1
|
(funExp, args) = simplifyApp exp1
|
||||||
simplifyApp e = (e, [])
|
simplifyApp e = (e, [])
|
||||||
|
|
||||||
evalIf :: EvalContext -> Exp -> Exp -> Exp -> State IDState (IconGraph, NameAndPort)
|
evalIf :: EvalContext -> Exp -> Exp -> Exp -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalIf c e1 e2 e3 = do
|
evalIf c e1 e2 e3 = do
|
||||||
e1Val <- evalExp c e1
|
e1Val <- evalExp c e1
|
||||||
e2Val <- evalExp c e2
|
e2Val <- evalExp c e2
|
||||||
e3Val <- evalExp c e3
|
e3Val <- evalExp c e3
|
||||||
guardName <- DIA.toName <$> getUniqueName "if"
|
guardName <- DIA.toName <$> getUniqueName "if"
|
||||||
let
|
let
|
||||||
icons = [(guardName, GuardIcon 2)]
|
icons = [(guardName, GuardNode 2)]
|
||||||
combinedGraph =
|
combinedGraph =
|
||||||
combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName) [3, 2, 4])
|
combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName) [3, 2, 4])
|
||||||
newGraph = iconGraphFromIcons icons <> combinedGraph
|
newGraph = syntaxGraphFromNodes icons <> combinedGraph
|
||||||
pure (newGraph, NameAndPort guardName (Just 0))
|
pure (newGraph, NameAndPort guardName (Just 0))
|
||||||
|
|
||||||
evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
|
evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
|
||||||
@ -216,7 +167,7 @@ evalGuaredRhs c (GuardedRhs _ stmts e) = do
|
|||||||
stmtsVal <- evalStmts c stmts
|
stmtsVal <- evalStmts c stmts
|
||||||
pure (stmtsVal, expVal)
|
pure (stmtsVal, expVal)
|
||||||
|
|
||||||
evalGuardedRhss :: EvalContext -> [GuardedRhs] -> State IDState (IconGraph, NameAndPort)
|
evalGuardedRhss :: EvalContext -> [GuardedRhs] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalGuardedRhss c rhss = do
|
evalGuardedRhss c rhss = do
|
||||||
guardName <- DIA.toName <$> getUniqueName "guard"
|
guardName <- DIA.toName <$> getUniqueName "guard"
|
||||||
evaledRhss <- mapM (evalGuaredRhs c) rhss
|
evaledRhss <- mapM (evalGuaredRhs c) rhss
|
||||||
@ -225,15 +176,15 @@ evalGuardedRhss c rhss = do
|
|||||||
expsWithPorts = zip exps $ map (nameAndPort guardName) [2,4..]
|
expsWithPorts = zip exps $ map (nameAndPort guardName) [2,4..]
|
||||||
boolsWithPorts = zip bools $ map (nameAndPort guardName) [3,5..]
|
boolsWithPorts = zip bools $ map (nameAndPort guardName) [3,5..]
|
||||||
combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts
|
combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts
|
||||||
icons = [(guardName, GuardIcon (length rhss))]
|
icons = [(guardName, GuardNode (length rhss))]
|
||||||
newGraph = iconGraphFromIcons icons <> combindedGraph
|
newGraph = syntaxGraphFromNodes icons <> combindedGraph
|
||||||
pure (newGraph, NameAndPort guardName (Just 1))
|
pure (newGraph, NameAndPort guardName (Just 1))
|
||||||
|
|
||||||
-- This is in Translate and not Translate core since currently it is only used by evalLit.
|
-- This is in Translate and not Translate core since currently it is only used by evalLit.
|
||||||
makeLiteral :: (Show x) => x -> State IDState (IconGraph, NameAndPort)
|
makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
makeLiteral = makeBox. show
|
makeLiteral = makeBox. show
|
||||||
|
|
||||||
evalLit :: Exts.Literal -> State IDState (IconGraph, NameAndPort)
|
evalLit :: Exts.Literal -> 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
|
||||||
@ -270,7 +221,7 @@ getBoundVarName (TypeSig _ _ _) = []
|
|||||||
getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl
|
getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl
|
||||||
|
|
||||||
--TODO: Should this call makeEdges?
|
--TODO: Should this call makeEdges?
|
||||||
evalBinds :: EvalContext -> Binds -> State IDState (IconGraph, EvalContext)
|
evalBinds :: EvalContext -> Binds -> State IDState (SyntaxGraph, EvalContext)
|
||||||
evalBinds c (BDecls decls) = do
|
evalBinds c (BDecls decls) = do
|
||||||
let
|
let
|
||||||
boundNames = concatMap getBoundVarName decls
|
boundNames = concatMap getBoundVarName decls
|
||||||
@ -278,21 +229,21 @@ evalBinds c (BDecls decls) = do
|
|||||||
evaledDecl <- mconcat <$> mapM (evalDecl augmentedContext) decls
|
evaledDecl <- mconcat <$> mapM (evalDecl augmentedContext) decls
|
||||||
pure (evaledDecl, augmentedContext)
|
pure (evaledDecl, augmentedContext)
|
||||||
|
|
||||||
evalGeneralLet :: (EvalContext -> State IDState (IconGraph, Reference)) -> EvalContext -> Binds -> State IDState (IconGraph, Reference)
|
evalGeneralLet :: (EvalContext -> State IDState (SyntaxGraph, Reference)) -> EvalContext -> Binds -> State IDState (SyntaxGraph, Reference)
|
||||||
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
|
||||||
let
|
let
|
||||||
(expGraph, expResult) = expVal
|
(expGraph, expResult) = expVal
|
||||||
newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
|
newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
|
||||||
(IconGraph _ _ _ _ bindings) = bindGraph
|
(SyntaxGraph _ _ _ bindings) = bindGraph
|
||||||
pure (newGraph, lookupReference bindings expResult)
|
pure (newGraph, lookupReference bindings expResult)
|
||||||
|
|
||||||
evalLet :: EvalContext -> Binds -> Exp -> State IDState (IconGraph, Reference)
|
evalLet :: EvalContext -> Binds -> Exp -> State IDState (SyntaxGraph, Reference)
|
||||||
evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
|
evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
|
||||||
|
|
||||||
-- TODO: Refactor this with evalPatBind
|
-- TODO: Refactor this with evalPatBind
|
||||||
evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, IconGraph, Reference, NameAndPort)
|
evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, NameAndPort)
|
||||||
evalPatAndRhs c pat rhs maybeWhereBinds = do
|
evalPatAndRhs c pat rhs maybeWhereBinds = do
|
||||||
patternNames <- namesInPattern <$> evalPattern pat
|
patternNames <- namesInPattern <$> evalPattern pat
|
||||||
let rhsContext = patternNames <> c
|
let rhsContext = patternNames <> c
|
||||||
@ -303,14 +254,14 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do
|
|||||||
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
||||||
-- The pattern and rhs are conneted if makeEdges added extra edges.
|
-- The pattern and rhs are conneted if makeEdges added extra edges.
|
||||||
patRhsAreConnected =
|
patRhsAreConnected =
|
||||||
length (igEdges grWithEdges) > (length (igEdges rhsGraph) + length (igEdges patGraph))
|
length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph))
|
||||||
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, rhsRef)
|
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, rhsRef)
|
||||||
|
|
||||||
-- returns (combined graph, pattern reference, rhs reference)
|
-- returns (combined graph, pattern reference, rhs reference)
|
||||||
evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, IconGraph, Reference, NameAndPort)
|
evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, NameAndPort)
|
||||||
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
|
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
|
||||||
|
|
||||||
evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (IconGraph, NameAndPort)
|
evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalCase c e alts = do
|
evalCase c e alts = do
|
||||||
evaledAlts <- mapM (evalAlt c) alts
|
evaledAlts <- mapM (evalAlt c) alts
|
||||||
(expGraph, expRef) <- evalExp c e
|
(expGraph, expRef) <- evalExp c e
|
||||||
@ -319,17 +270,17 @@ evalCase c e alts = do
|
|||||||
(patRhsConnected, altGraphs, patRefs, rhsRefs) = unzip4 evaledAlts
|
(patRhsConnected, altGraphs, patRefs, rhsRefs) = unzip4 evaledAlts
|
||||||
combindedAltGraph = mconcat altGraphs
|
combindedAltGraph = mconcat altGraphs
|
||||||
numAlts = length alts
|
numAlts = length alts
|
||||||
icons = toNames [(caseIconName, CaseIcon numAlts)]
|
icons = toNames [(caseIconName, CaseNode numAlts)]
|
||||||
caseGraph = iconGraphFromIcons icons
|
caseGraph = syntaxGraphFromNodes icons
|
||||||
expEdge = (expRef, nameAndPort caseIconName 0)
|
expEdge = (expRef, nameAndPort caseIconName 0)
|
||||||
patEdges = zip patRefs $ map (nameAndPort caseIconName ) [2,4..]
|
patEdges = zip patRefs $ map (nameAndPort caseIconName ) [2,4..]
|
||||||
rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName) [3,5..]
|
rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName) [3,5..]
|
||||||
(connectedRhss, unConnectedRhss) = partition fst rhsEdges
|
(connectedRhss, unConnectedRhss) = partition fst rhsEdges
|
||||||
resultIconNames <- replicateM numAlts (getUniqueName "caseResult")
|
resultIconNames <- replicateM numAlts (getUniqueName "caseResult")
|
||||||
let
|
let
|
||||||
makeCaseResult resultIconName rhsPort = iconGraphFromIconsEdges rhsNewIcons rhsNewEdges
|
makeCaseResult resultIconName rhsPort = syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges
|
||||||
where
|
where
|
||||||
rhsNewIcons = toNames [(resultIconName, CaseResultIcon)]
|
rhsNewIcons = toNames [(resultIconName, CaseResultNode)]
|
||||||
rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)]
|
rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)]
|
||||||
caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
|
caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
|
||||||
filteredRhsEdges = mapFst Right $ fmap snd unConnectedRhss
|
filteredRhsEdges = mapFst Right $ fmap snd unConnectedRhss
|
||||||
@ -338,32 +289,34 @@ evalCase c e alts = do
|
|||||||
finalGraph = mconcat [patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
finalGraph = mconcat [patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
||||||
pure (finalGraph, nameAndPort caseIconName 1)
|
pure (finalGraph, nameAndPort caseIconName 1)
|
||||||
|
|
||||||
evalTuple :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
evalTuple :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalTuple c exps = do
|
evalTuple c exps = do
|
||||||
argVals <- mapM (evalExp c) exps
|
argVals <- mapM (evalExp c) exps
|
||||||
|
funVal <- makeBox $ nTupleString (length exps)
|
||||||
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
||||||
pure $ makeTextApplyGraph False applyIconName (Left $ nTupleString (length exps)) argVals (length exps)
|
pure $ makeApplyGraph False applyIconName (fmap Right funVal) argVals (length exps)
|
||||||
|
|
||||||
makeVarExp :: String -> Exp
|
makeVarExp :: String -> Exp
|
||||||
makeVarExp = Var . UnQual . Ident
|
makeVarExp = Var . UnQual . Ident
|
||||||
|
|
||||||
evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
evalListExp :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalListExp _ [] = makeBox "[]"
|
evalListExp _ [] = makeBox "[]"
|
||||||
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
||||||
|
|
||||||
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (IconGraph, NameAndPort)
|
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalLeftSection c e op = evalApp c (qOpToExp op, [e])
|
evalLeftSection c e op = evalApp c (qOpToExp op, [e])
|
||||||
|
|
||||||
evalRightSection:: EvalContext -> QOp -> Exp -> State IDState (IconGraph, NameAndPort)
|
evalRightSection:: EvalContext -> QOp -> Exp -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalRightSection c op e = do
|
evalRightSection c op e = do
|
||||||
expVal <- evalExp c e
|
expVal <- evalExp c e
|
||||||
|
funVal <- evalExp c (qOpToExp op)
|
||||||
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
||||||
-- TODO: A better option would be for makeApplyGraph to take the list of expressions as Maybes.
|
-- TODO: A better option would be for makeApplyGraph to take the list of expressions as Maybes.
|
||||||
neverUsedPort <- Left <$> getUniqueName "unusedArgument"
|
neverUsedPort <- Left <$> getUniqueName "unusedArgument"
|
||||||
pure $ makeTextApplyGraph False applyIconName (Left $ qOpToString op) [(mempty, neverUsedPort), expVal] 2
|
pure $ makeApplyGraph False applyIconName funVal [(mempty, neverUsedPort), expVal] 2
|
||||||
|
|
||||||
-- evalEnums is only used by evalExp
|
-- evalEnums is only used by evalExp
|
||||||
evalEnums :: EvalContext -> String -> [Exp] -> State IDState (IconGraph, Reference)
|
evalEnums :: EvalContext -> String -> [Exp] -> State IDState (SyntaxGraph, Reference)
|
||||||
evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
|
evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
|
||||||
|
|
||||||
makeQVarOp :: String -> QOp
|
makeQVarOp :: String -> QOp
|
||||||
@ -378,10 +331,10 @@ desugarDo (Generator srcLoc pat e : stmts) =
|
|||||||
desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
|
desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
|
||||||
|
|
||||||
-- TODO: Finish evalRecConstr
|
-- TODO: Finish evalRecConstr
|
||||||
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (IconGraph, Reference)
|
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (SyntaxGraph, Reference)
|
||||||
evalRecConstr c qName _ = evalQName qName c
|
evalRecConstr c qName _ = evalQName qName c
|
||||||
|
|
||||||
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
evalExp :: EvalContext -> Exp -> State IDState (SyntaxGraph, Reference)
|
||||||
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
|
||||||
@ -414,16 +367,16 @@ evalExp c x = case x of
|
|||||||
|
|
||||||
-- | 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 (IconGraph, Reference)
|
evalRhs :: EvalContext -> Rhs -> State IDState (SyntaxGraph, Reference)
|
||||||
evalRhs c (UnGuardedRhs e) = evalExp c e
|
evalRhs c (UnGuardedRhs e) = evalExp c e
|
||||||
evalRhs c (GuardedRhss rhss) = fmap Right <$> evalGuardedRhss c rhss
|
evalRhs c (GuardedRhss rhss) = fmap Right <$> evalGuardedRhss c rhss
|
||||||
|
|
||||||
rhsWithBinds :: Maybe Binds -> Rhs -> EvalContext -> State IDState (IconGraph, Reference)
|
rhsWithBinds :: Maybe Binds -> Rhs -> EvalContext -> State IDState (SyntaxGraph, Reference)
|
||||||
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
|
||||||
|
|
||||||
evalPatBind :: EvalContext -> Decl -> State IDState IconGraph
|
evalPatBind :: EvalContext -> Decl -> State IDState SyntaxGraph
|
||||||
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||||
patternNames <- namesInPattern <$> evalPattern pat
|
patternNames <- namesInPattern <$> evalPattern pat
|
||||||
let rhsContext = patternNames <> c
|
let rhsContext = patternNames <> c
|
||||||
@ -436,10 +389,10 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
|||||||
-- TODO This edge/sink should have a special arrow head to indicate an input to a pattern.
|
-- TODO This edge/sink should have a special arrow head to indicate an input to a pattern.
|
||||||
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty)
|
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty)
|
||||||
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
|
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
|
||||||
gr = IconGraph mempty newEdges mempty newSinks bindings
|
gr = SyntaxGraph mempty newEdges newSinks bindings
|
||||||
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
||||||
|
|
||||||
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (IconGraph, NameAndPort)
|
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
generalEvalLambda context patterns rhsEvalFun = do
|
generalEvalLambda context patterns rhsEvalFun = do
|
||||||
lambdaName <- getUniqueName "lam"
|
lambdaName <- getUniqueName "lam"
|
||||||
patternVals <- mapM evalPattern patterns
|
patternVals <- mapM evalPattern patterns
|
||||||
@ -455,9 +408,9 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
-- TODO remove coerceExpressionResult here
|
-- TODO remove coerceExpressionResult here
|
||||||
(rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
|
(rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
|
||||||
let
|
let
|
||||||
icons = toNames [(lambdaName, FlatLambdaIcon numParameters)]
|
icons = toNames [(lambdaName, FunctionDefNode numParameters)]
|
||||||
resultIconEdge = makeSimpleEdge (rhsResult, nameAndPort lambdaName 0)
|
resultIconEdge = makeSimpleEdge (rhsResult, nameAndPort lambdaName 0)
|
||||||
finalGraph = IconGraph icons (resultIconEdge:patternEdges) mempty
|
finalGraph = SyntaxGraph icons (resultIconEdge:patternEdges)
|
||||||
mempty newBinds
|
mempty newBinds
|
||||||
pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName 1)
|
pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName 1)
|
||||||
where
|
where
|
||||||
@ -469,10 +422,10 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
makePatternEdges (_, Left str) lamPort = Right (str, Right lamPort)
|
makePatternEdges (_, Left str) lamPort = Right (str, Right lamPort)
|
||||||
|
|
||||||
|
|
||||||
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
|
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
|
evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
|
||||||
|
|
||||||
evalMatch :: EvalContext -> Match -> State IDState IconGraph
|
evalMatch :: EvalContext -> Match -> 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
|
||||||
@ -480,7 +433,7 @@ evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do
|
|||||||
(lambdaGraph, lambdaPort) <-
|
(lambdaGraph, lambdaPort) <-
|
||||||
generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
|
generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
|
||||||
let
|
let
|
||||||
newBinding = IconGraph mempty mempty mempty mempty [(matchFunNameString, Right lambdaPort)]
|
newBinding = SyntaxGraph mempty mempty mempty [(matchFunNameString, Right lambdaPort)]
|
||||||
pure $ makeEdges (newBinding <> lambdaGraph)
|
pure $ makeEdges (newBinding <> lambdaGraph)
|
||||||
|
|
||||||
-- Only used by matchesToCase
|
-- Only used by matchesToCase
|
||||||
@ -509,11 +462,11 @@ matchesToCase firstMatch@(Match srcLoc funName pats mType _ _) restOfMatches = d
|
|||||||
alts = fmap matchToAlt allMatches
|
alts = fmap matchToAlt allMatches
|
||||||
|
|
||||||
|
|
||||||
evalMatches :: EvalContext -> [Match] -> State IDState IconGraph
|
evalMatches :: EvalContext -> [Match] -> 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
|
||||||
|
|
||||||
evalDecl :: EvalContext -> Decl -> State IDState IconGraph
|
evalDecl :: EvalContext -> Decl -> State IDState SyntaxGraph
|
||||||
evalDecl c d = evaluatedDecl where
|
evalDecl c d = evaluatedDecl where
|
||||||
evaluatedDecl = case d of
|
evaluatedDecl = case d of
|
||||||
pat@(PatBind _ _ _ _) -> evalPatBind c pat
|
pat@(PatBind _ _ _ _) -> evalPatBind c pat
|
||||||
@ -522,19 +475,19 @@ evalDecl c d = evaluatedDecl where
|
|||||||
_ -> pure mempty
|
_ -> pure mempty
|
||||||
|
|
||||||
drawingFromDecl :: Decl -> Drawing
|
drawingFromDecl :: Decl -> Drawing
|
||||||
drawingFromDecl d = iconGraphToDrawing $ evalState evaluatedDecl initialIdState
|
drawingFromDecl d = iconGraphToDrawing $ syntaxGraphToIconGraph $ evalState evaluatedDecl initialIdState
|
||||||
where
|
where
|
||||||
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
||||||
showTopLevelBinds :: IconGraph -> State IDState IconGraph
|
showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph
|
||||||
showTopLevelBinds gr@(IconGraph _ _ _ _ binds) = do
|
showTopLevelBinds gr@(SyntaxGraph _ _ _ binds) = do
|
||||||
let
|
let
|
||||||
addBind (_, Left _) = pure mempty
|
addBind (_, Left _) = pure mempty
|
||||||
addBind (patName, Right port) = do
|
addBind (patName, Right port) = do
|
||||||
uniquePatName <- getUniqueName patName
|
uniquePatName <- getUniqueName patName
|
||||||
let
|
let
|
||||||
icons = toNames [(uniquePatName, BindTextBoxIcon patName)]
|
icons = toNames [(uniquePatName, NameNode patName)]
|
||||||
edges = [makeSimpleEdge (justName uniquePatName, port)]
|
edges = [makeSimpleEdge (justName uniquePatName, port)]
|
||||||
edgeGraph = iconGraphFromIconsEdges icons edges
|
edgeGraph = syntaxGraphFromNodesEdges icons edges
|
||||||
pure edgeGraph
|
pure edgeGraph
|
||||||
newGraph <- mconcat <$> mapM addBind binds
|
newGraph <- mconcat <$> mapM addBind binds
|
||||||
pure $ newGraph <> gr
|
pure $ newGraph <> gr
|
||||||
|
@ -1,11 +1,12 @@
|
|||||||
module TranslateCore(
|
module TranslateCore(
|
||||||
Reference,
|
Reference,
|
||||||
IconGraph(..),
|
IconGraph(..),
|
||||||
|
SyntaxGraph(..),
|
||||||
EvalContext,
|
EvalContext,
|
||||||
GraphAndRef,
|
GraphAndRef,
|
||||||
Sink,
|
Sink,
|
||||||
iconGraphFromIcons,
|
syntaxGraphFromNodes,
|
||||||
iconGraphFromIconsEdges,
|
syntaxGraphFromNodesEdges,
|
||||||
getUniqueName,
|
getUniqueName,
|
||||||
edgesForRefPortList,
|
edgesForRefPortList,
|
||||||
combineExpressions,
|
combineExpressions,
|
||||||
@ -20,15 +21,17 @@ module TranslateCore(
|
|||||||
coerceExpressionResult,
|
coerceExpressionResult,
|
||||||
makeBox,
|
makeBox,
|
||||||
nTupleString,
|
nTupleString,
|
||||||
nListString
|
nListString,
|
||||||
|
syntaxGraphToIconGraph
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Semigroup(Semigroup, (<>))
|
import Data.Semigroup(Semigroup, (<>))
|
||||||
import qualified Diagrams.Prelude as DIA
|
import qualified Diagrams.Prelude as DIA
|
||||||
import Control.Monad.State(State)
|
import Control.Monad.State(State)
|
||||||
import Data.Either(partitionEithers)
|
import Data.Either(partitionEithers)
|
||||||
|
import Control.Arrow(second)
|
||||||
|
|
||||||
import Types(Icon, Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState,
|
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState,
|
||||||
getId)
|
getId)
|
||||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName)
|
import Util(noEnds, nameAndPort, makeSimpleEdge, justName)
|
||||||
import Icons(Icon(..))
|
import Icons(Icon(..))
|
||||||
@ -41,6 +44,25 @@ import Icons(Icon(..))
|
|||||||
-- used in Translate.
|
-- used in Translate.
|
||||||
|
|
||||||
type Reference = Either String NameAndPort
|
type Reference = Either String NameAndPort
|
||||||
|
|
||||||
|
-- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
|
||||||
|
-- generated from the Haskell syntax tree, and are used to generate IconGraphs
|
||||||
|
data SyntaxGraph = SyntaxGraph {
|
||||||
|
sgNodes :: [(DIA.Name, SyntaxNode)],
|
||||||
|
sgEdges :: [Edge],
|
||||||
|
sgSinks :: [(String, NameAndPort)],
|
||||||
|
sgSources :: [(String, Reference)]
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
instance Semigroup SyntaxGraph where
|
||||||
|
(SyntaxGraph icons1 edges1 sinks1 sources1) <> (SyntaxGraph icons2 edges2 sinks2 sources2) =
|
||||||
|
SyntaxGraph (icons1 <> icons2) (edges1 <> edges2) (sinks1 <> sinks2) (sources1 <> sources2)
|
||||||
|
|
||||||
|
instance Monoid SyntaxGraph where
|
||||||
|
mempty = SyntaxGraph mempty mempty mempty mempty
|
||||||
|
mappend = (<>)
|
||||||
|
|
||||||
|
-- TODO remove / change due to SyntaxGraph
|
||||||
-- | An IconGraph is a normal Drawing (Icons, Edges, and sub Drawings) with two additional fields:
|
-- | An IconGraph is a normal Drawing (Icons, Edges, and sub Drawings) with two additional fields:
|
||||||
-- unconected sink ports (varible usage), and unconnected source ports (varible definition).
|
-- unconected sink ports (varible usage), and unconnected source ports (varible definition).
|
||||||
data IconGraph = IconGraph {
|
data IconGraph = IconGraph {
|
||||||
@ -51,45 +73,45 @@ data IconGraph = IconGraph {
|
|||||||
igBindings :: [(String, Reference)]}
|
igBindings :: [(String, Reference)]}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
type EvalContext = [String]
|
|
||||||
type GraphAndRef = (IconGraph, Reference)
|
|
||||||
type Sink = (String, NameAndPort)
|
|
||||||
|
|
||||||
instance Semigroup IconGraph where
|
instance Semigroup IconGraph where
|
||||||
(IconGraph icons1 edges1 subDrawings1 sinks1 sources1) <> (IconGraph icons2 edges2 subDrawings2 sinks2 sources2) =
|
(IconGraph icons1 edges1 subDrawings1 sinks1 sources1) <> (IconGraph icons2 edges2 subDrawings2 sinks2 sources2) =
|
||||||
IconGraph (icons1 <> icons2) (edges1 <> edges2) (subDrawings1 <> subDrawings2) (sinks1 <> sinks2) (sources1 <> sources2)
|
IconGraph (icons1 <> icons2) (edges1 <> edges2) (subDrawings1 <> subDrawings2) (sinks1 <> sinks2) (sources1 <> sources2)
|
||||||
|
|
||||||
|
type EvalContext = [String]
|
||||||
|
type GraphAndRef = (SyntaxGraph, Reference)
|
||||||
|
type Sink = (String, NameAndPort)
|
||||||
|
|
||||||
instance Monoid IconGraph where
|
instance Monoid IconGraph where
|
||||||
mempty = IconGraph mempty mempty mempty mempty mempty
|
mempty = IconGraph mempty mempty mempty mempty mempty
|
||||||
mappend = (<>)
|
mappend = (<>)
|
||||||
|
|
||||||
iconGraphFromIcons :: [(DIA.Name, Icon)] -> IconGraph
|
syntaxGraphFromNodes :: [(DIA.Name, SyntaxNode)] -> SyntaxGraph
|
||||||
iconGraphFromIcons icons = IconGraph icons mempty mempty mempty mempty
|
syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty
|
||||||
|
|
||||||
iconGraphFromIconsEdges :: [(DIA.Name, Icon)] -> [Edge] -> IconGraph
|
syntaxGraphFromNodesEdges :: [(DIA.Name, SyntaxNode)] -> [Edge] -> SyntaxGraph
|
||||||
iconGraphFromIconsEdges icons edges = IconGraph icons edges mempty mempty mempty
|
syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty
|
||||||
|
|
||||||
getUniqueName :: String -> State IDState String
|
getUniqueName :: String -> State IDState String
|
||||||
getUniqueName base = fmap ((base ++). show) getId
|
getUniqueName base = fmap ((base ++). show) getId
|
||||||
|
|
||||||
-- TODO: Refactor with combineExpressions
|
-- TODO: Refactor with combineExpressions
|
||||||
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> IconGraph
|
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph
|
||||||
edgesForRefPortList inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
edgesForRefPortList inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||||
edgeOpts = if inPattern then [EdgeInPattern] else []
|
edgeOpts = if inPattern then [EdgeInPattern] else []
|
||||||
mkGraph (ref, port) = case ref of
|
mkGraph (ref, port) = case ref of
|
||||||
Left str -> if inPattern
|
Left str -> if inPattern
|
||||||
then IconGraph mempty mempty mempty mempty [(str, Right port)]
|
then SyntaxGraph mempty mempty mempty [(str, Right port)]
|
||||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
else SyntaxGraph mempty mempty [(str, port)] mempty
|
||||||
Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty
|
||||||
|
|
||||||
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> IconGraph
|
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph
|
||||||
combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||||
edgeOpts = if inPattern then [EdgeInPattern] else []
|
edgeOpts = if inPattern then [EdgeInPattern] else []
|
||||||
mkGraph ((graph, ref), port) = graph <> case ref of
|
mkGraph ((graph, ref), port) = graph <> case ref of
|
||||||
Left str -> if inPattern
|
Left str -> if inPattern
|
||||||
then IconGraph mempty mempty mempty mempty [(str, Right port)]
|
then SyntaxGraph mempty mempty mempty [(str, Right port)]
|
||||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
else SyntaxGraph mempty mempty [(str, port)] mempty
|
||||||
Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty
|
||||||
|
|
||||||
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||||
-- qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
-- qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
||||||
@ -97,18 +119,18 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs
|
|||||||
iconGraphToDrawing :: IconGraph -> Drawing
|
iconGraphToDrawing :: IconGraph -> Drawing
|
||||||
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
||||||
|
|
||||||
makeApplyGraph :: Bool -> DIA.Name -> GraphAndRef -> [GraphAndRef] -> Int -> (IconGraph, NameAndPort)
|
makeApplyGraph :: Bool -> DIA.Name -> GraphAndRef -> [GraphAndRef] -> Int -> (SyntaxGraph, NameAndPort)
|
||||||
makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||||
where
|
where
|
||||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||||
functionPort = nameAndPort applyIconName 0
|
functionPort = nameAndPort applyIconName 0
|
||||||
combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentPorts)
|
combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentPorts)
|
||||||
icons = [(applyIconName, ApplyAIcon numArgs)]
|
icons = [(applyIconName, ApplyNode numArgs)]
|
||||||
newGraph = iconGraphFromIcons icons
|
newGraph = syntaxGraphFromNodes icons
|
||||||
|
|
||||||
namesInPattern :: GraphAndRef -> [String]
|
namesInPattern :: GraphAndRef -> [String]
|
||||||
namesInPattern (_, Left str) = [str]
|
namesInPattern (_, Left str) = [str]
|
||||||
namesInPattern (IconGraph _ _ _ _ bindings, Right _) = fmap fst bindings
|
namesInPattern (SyntaxGraph _ _ _ bindings, Right _) = fmap fst bindings
|
||||||
|
|
||||||
-- | Recursivly find the matching reference in a list of bindings.
|
-- | Recursivly find the matching reference in a list of bindings.
|
||||||
-- TODO: Might want to present some indication if there is a reference cycle.
|
-- TODO: Might want to present some indication if there is a reference cycle.
|
||||||
@ -123,8 +145,8 @@ lookupReference bindings ref@(Left originalS) = lookupHelper ref where
|
|||||||
failIfCycle r@(Left newStr) res = if newStr == originalS then r else res
|
failIfCycle r@(Left newStr) res = if newStr == originalS then r else res
|
||||||
failIfCycle _ res = res
|
failIfCycle _ res = res
|
||||||
|
|
||||||
deleteBindings :: IconGraph -> IconGraph
|
deleteBindings :: SyntaxGraph -> SyntaxGraph
|
||||||
deleteBindings (IconGraph a b c d _) = IconGraph a b c d mempty
|
deleteBindings (SyntaxGraph a b c _) = SyntaxGraph a b c mempty
|
||||||
|
|
||||||
makeEdgesCore :: [Sink] -> [(String, Reference)] -> ([Sink], [Edge])
|
makeEdgesCore :: [Sink] -> [(String, Reference)] -> ([Sink], [Edge])
|
||||||
makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
|
makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
|
||||||
@ -136,28 +158,30 @@ makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
|
|||||||
(Left newStr) -> Left (newStr, destPort)
|
(Left newStr) -> Left (newStr, destPort)
|
||||||
Nothing -> Left orig
|
Nothing -> Left orig
|
||||||
|
|
||||||
makeEdges :: IconGraph -> IconGraph
|
makeEdges :: SyntaxGraph -> SyntaxGraph
|
||||||
makeEdges (IconGraph icons edges c sinks bindings) = newGraph where
|
makeEdges (SyntaxGraph icons edges sinks bindings) = newGraph where
|
||||||
(newSinks, newEdges) = makeEdgesCore sinks bindings
|
(newSinks, newEdges) = makeEdgesCore sinks bindings
|
||||||
newGraph = IconGraph icons (newEdges <> edges) c newSinks bindings
|
newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings
|
||||||
|
|
||||||
|
-- TODO: Remove BranchNode
|
||||||
-- | This is used by the rhs for identity (eg. y x = x)
|
-- | This is used by the rhs for identity (eg. y x = x)
|
||||||
coerceExpressionResult :: (IconGraph, Reference) -> State IDState (IconGraph, NameAndPort)
|
coerceExpressionResult :: (SyntaxGraph, Reference) -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
coerceExpressionResult (_, Left str) = makeDummyRhs str where
|
coerceExpressionResult (_, Left str) = makeDummyRhs str where
|
||||||
makeDummyRhs :: String -> State IDState (IconGraph, NameAndPort)
|
makeDummyRhs :: String -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
makeDummyRhs s = do
|
makeDummyRhs s = do
|
||||||
iconName <- getUniqueName s
|
iconName <- getUniqueName s
|
||||||
let
|
let
|
||||||
graph = IconGraph icons mempty mempty [(s, port)] mempty
|
graph = SyntaxGraph icons mempty [(s, port)] mempty
|
||||||
icons = [(DIA.toName iconName, BranchIcon)]
|
icons = [(DIA.toName iconName, BranchNode)]
|
||||||
port = justName iconName
|
port = justName iconName
|
||||||
pure (graph, port)
|
pure (graph, port)
|
||||||
coerceExpressionResult (g, Right x) = pure (g, x)
|
coerceExpressionResult (g, Right x) = pure (g, x)
|
||||||
|
|
||||||
makeBox :: String -> State IDState (IconGraph, NameAndPort)
|
-- TODO: remove / change due toSyntaxGraph
|
||||||
|
makeBox :: String -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
makeBox str = do
|
makeBox str = do
|
||||||
name <- DIA.toName <$> getUniqueName str
|
name <- DIA.toName <$> getUniqueName str
|
||||||
let graph = iconGraphFromIcons [(DIA.toName name, TextBoxIcon str)]
|
let graph = syntaxGraphFromNodes [(DIA.toName name, LiteralNode str)]
|
||||||
pure (graph, justName name)
|
pure (graph, justName name)
|
||||||
|
|
||||||
nTupleString :: Int -> String
|
nTupleString :: Int -> String
|
||||||
@ -167,3 +191,19 @@ nListString :: Int -> String
|
|||||||
-- TODO: Use something better than [_]
|
-- TODO: Use something better than [_]
|
||||||
nListString 1 = "[_]"
|
nListString 1 = "[_]"
|
||||||
nListString n = '[' : replicate (n -1) ',' ++ "]"
|
nListString n = '[' : replicate (n -1) ',' ++ "]"
|
||||||
|
|
||||||
|
nodeToIcon :: SyntaxNode -> Icon
|
||||||
|
nodeToIcon (ApplyNode n) = ApplyAIcon n
|
||||||
|
nodeToIcon (PatternApplyNode s n) = PAppIcon n s
|
||||||
|
nodeToIcon (NameNode s) = TextBoxIcon s
|
||||||
|
nodeToIcon (LiteralNode s) = TextBoxIcon s
|
||||||
|
nodeToIcon (FunctionDefNode n) = FlatLambdaIcon n
|
||||||
|
nodeToIcon (GuardNode n) = GuardIcon n
|
||||||
|
nodeToIcon (CaseNode n) = CaseIcon n
|
||||||
|
nodeToIcon BranchNode = BranchIcon
|
||||||
|
nodeToIcon CaseResultNode = CaseResultIcon
|
||||||
|
|
||||||
|
syntaxGraphToIconGraph :: SyntaxGraph -> IconGraph
|
||||||
|
syntaxGraphToIconGraph (SyntaxGraph nodes edges sources sinks) =
|
||||||
|
IconGraph icons edges mempty sources sinks where
|
||||||
|
icons = fmap (second nodeToIcon) nodes
|
||||||
|
12
app/Types.hs
12
app/Types.hs
@ -2,6 +2,7 @@
|
|||||||
|
|
||||||
module Types (
|
module Types (
|
||||||
Icon(..),
|
Icon(..),
|
||||||
|
SyntaxNode(..),
|
||||||
NameAndPort(..),
|
NameAndPort(..),
|
||||||
Connection,
|
Connection,
|
||||||
Edge(..),
|
Edge(..),
|
||||||
@ -34,6 +35,17 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
|||||||
| NestedPApp (Maybe String) [Maybe (Name, Icon)]
|
| NestedPApp (Maybe String) [Maybe (Name, Icon)]
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data SyntaxNode = ApplyNode Int-- Function application
|
||||||
|
| PatternApplyNode String Int -- Destructors as used in patterns
|
||||||
|
| NameNode String -- Identifiers or symbols
|
||||||
|
| LiteralNode String -- Literal values like the string "Hello World"
|
||||||
|
| FunctionDefNode Int-- Function definition (ie. lambda expression)
|
||||||
|
| GuardNode Int
|
||||||
|
| CaseNode Int
|
||||||
|
| BranchNode -- TODO remove BranchNode
|
||||||
|
| CaseResultNode -- TODO remove caseResultNode
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show, Eq)
|
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show, Eq)
|
||||||
|
|
||||||
type Connection = (NameAndPort, NameAndPort)
|
type Connection = (NameAndPort, NameAndPort)
|
||||||
|
@ -15,3 +15,6 @@ stack ghci glance:test:glance-test
|
|||||||
For all warnings (some warnings duplicated):
|
For all warnings (some warnings duplicated):
|
||||||
stack clean
|
stack clean
|
||||||
stack build --test --no-run-tests --ghc-options -Wall
|
stack build --test --no-run-tests --ghc-options -Wall
|
||||||
|
|
||||||
|
To open documentation for other libraries:
|
||||||
|
stack haddock --open <package-name>
|
||||||
|
Loading…
Reference in New Issue
Block a user