rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-10-05 19:58:30 +03:00
Code Issues Projects Releases Wiki Activity

Update stackage, fix warnings and format some app files with Ormolu.

Browse Source
This commit is contained in:
Robbie Gleichman 2020-12-25 22:35:24 -08:00
parent a6a9fb988c
commit 0b3efb0262
4 changed files with 723 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

753
app/Translate.hs
View File

@ -1,44 +1,85 @@
{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-} -- This file is formatted with Ormolu
module Translate( {-# LANGUAGE TupleSections #-}
translateStringToSyntaxGraph, {-# LANGUAGE NoMonomorphismRestriction #-}
translateStringToCollapsedGraphAndDecl,
translateModuleToCollapsedGraphs,
customParseDecl
) where
import Diagrams.Prelude((<>)) module Translate
( translateStringToSyntaxGraph,
translateStringToCollapsedGraphAndDecl,
translateModuleToCollapsedGraphs,
customParseDecl,
)
where
import Control.Monad(replicateM) import Control.Monad (replicateM)
import Control.Monad.State(State, evalState) import Control.Monad.State (State, evalState)
import Data.Either(partitionEithers) import Data.Either (partitionEithers)
import qualified Data.Graph.Inductive.PatriciaTree as FGR import qualified Data.Graph.Inductive.PatriciaTree as FGR
import Data.List(unzip5, partition, intercalate) import Data.List (intercalate, partition, unzip5)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe(fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set import qualified Data.Set as Set
import GraphAlgorithms (annotateGraph, collapseAnnotatedGraph)
import Icons
( argumentPorts,
casePatternPorts,
caseRhsPorts,
inputPort,
resultPort,
)
import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts as Exts
import qualified Language.Haskell.Exts.Pretty as PExts import qualified Language.Haskell.Exts.Pretty as PExts
import SimplifySyntax
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph) ( SelectorAndVal (..),
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts, SimpAlt (..),
casePatternPorts) SimpDecl (..),
import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..) SimpExp (..),
, qNameToString, nameToString, customParseDecl SimpPat (..),
, SimpDecl(..), hsDeclToSimpDecl, SelectorAndVal(..)) customParseDecl,
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..) hsDeclToSimpDecl,
, SgSink(..), syntaxGraphFromNodes nameToString,
, syntaxGraphFromNodesEdges, getUniqueName qNameToString,
, edgesForRefPortList, makeApplyGraph, makeMultiIfGraph stringToSimpDecl,
, combineExpressions, namesInPattern, lookupReference )
, deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph import TranslateCore
, getUniqueString, bindsToSyntaxGraph, SgBind(..) ( EvalContext,
, graphAndRefToGraph, initialIdState) GraphAndRef (..),
import Types(AnnotatedGraph, Labeled(..), NameAndPort(..), IDState, Reference,
Edge, SyntaxNode(..), NodeName, SgNamedNode, SgBind (..),
LikeApplyFlavor(..), CaseOrMultiIfTag(..), Named(..) SgSink (..),
, mkEmbedder) SyntaxGraph (..),
import Util(makeSimpleEdge, nameAndPort, justName) bindsToSyntaxGraph,
combineExpressions,
deleteBindings,
edgesForRefPortList,
getUniqueName,
getUniqueString,
graphAndRefToGraph,
initialIdState,
lookupReference,
makeApplyGraph,
makeBox,
makeEdges,
makeMultiIfGraph,
namesInPattern,
syntaxGraphFromNodes,
syntaxGraphFromNodesEdges,
syntaxGraphToFglGraph,
)
import Types
( AnnotatedGraph,
CaseOrMultiIfTag (..),
Edge,
IDState,
Labeled (..),
LikeApplyFlavor (..),
NameAndPort (..),
Named (..),
NodeName,
SgNamedNode,
SyntaxNode (..),
mkEmbedder,
)
import Util (justName, makeSimpleEdge, nameAndPort)
{-# ANN module "HLint: ignore Use record patterns" #-} {-# ANN module "HLint: ignore Use record patterns" #-}
@ -52,8 +93,8 @@ import Util(makeSimpleEdge, nameAndPort, justName)
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@) -- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
-- names. -- names.
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
makeAsBindGraph ref asNames makeAsBindGraph ref asNames =
= bindsToSyntaxGraph $ mapMaybe makeBind asNames bindsToSyntaxGraph $ mapMaybe makeBind asNames
where where
makeBind mName = case mName of makeBind mName = case mName of
Nothing -> Nothing Nothing -> Nothing
@ -63,26 +104,26 @@ grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef
grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np) grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np)
-- TODO Find a better name for bindOrAltHelper -- TODO Find a better name for bindOrAltHelper
bindOrAltHelper :: Show l => bindOrAltHelper ::
EvalContext Show l =>
-> SimpPat l EvalContext ->
-> SimpExp l SimpPat l ->
-> State IDState ((GraphAndRef, Maybe String), GraphAndRef) SimpExp l ->
State IDState ((GraphAndRef, Maybe String), GraphAndRef)
bindOrAltHelper c pat e = do bindOrAltHelper c pat e = do
patGraphAndRef <- evalPattern pat patGraphAndRef <- evalPattern pat
let let rhsContext = namesInPattern patGraphAndRef <> c
rhsContext = namesInPattern patGraphAndRef <> c
rhsGraphAndRef <- evalExp rhsContext e rhsGraphAndRef <- evalExp rhsContext e
pure (patGraphAndRef, rhsGraphAndRef) pure (patGraphAndRef, rhsGraphAndRef)
patternName :: (GraphAndRef, Maybe String) -> String patternName :: (GraphAndRef, Maybe String) -> String
patternName (GraphAndRef _ ref, mStr) = fromMaybe patternName (GraphAndRef _ ref, mStr) =
(case ref of fromMaybe
Left str -> str ( case ref of
Right _ -> "" Left str -> str
) Right _ -> ""
mStr )
mStr
-- END Helper Functions -- -- END Helper Functions --
@ -118,10 +159,10 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of
Just asName -> Just $ SgBind asName ref Just asName -> Just $ SgBind asName ref
patternArgumentMapper :: patternArgumentMapper ::
((GraphAndRef, Maybe String), t) ((GraphAndRef, Maybe String), t) ->
-> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)) (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) =
= (patName, eitherVal) (patName, eitherVal)
where where
graph = graphAndRefToGraph graphAndRef graph = graphAndRefToGraph graphAndRef
patName = patternName asGraphAndRef patName = patternName asGraphAndRef
@ -130,38 +171,37 @@ patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port)
(SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph) (SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
_ -> Left (graphAndRef, port) _ -> Left (graphAndRef, port)
graphToTuple :: graphToTuple ::
SyntaxGraph SyntaxGraph ->
-> ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName)
graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e) graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
graphsToComponents :: graphsToComponents ::
[SyntaxGraph] [SyntaxGraph] ->
-> ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName)
graphsToComponents graphs graphsToComponents graphs =
= (mconcat a, mconcat b, mconcat c, mconcat d, mconcat e) (mconcat a, mconcat b, mconcat c, mconcat d, mconcat e)
where where
(a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs (a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs
makeNestedPatternGraph :: makeNestedPatternGraph ::
NodeName NodeName ->
-> String String ->
-> [(GraphAndRef, Maybe String)] [(GraphAndRef, Maybe String)] ->
-> (SyntaxGraph, NameAndPort) (SyntaxGraph, NameAndPort)
makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
where where
dummyNode = PatternApplyNode "" [] dummyNode = PatternApplyNode "" []
argsAndPorts argsAndPorts =
= zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
mappedArgs = fmap patternArgumentMapper argsAndPorts mappedArgs = fmap patternArgumentMapper argsAndPorts
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) (unnestedArgsAndPort, nestedNamedNodesAndGraphs) =
= partitionEithers (fmap snd mappedArgs) partitionEithers (fmap snd mappedArgs)
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) =
= graphsToComponents $ fmap snd nestedNamedNodesAndGraphs graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
argListMapper (str, arg) = case arg of argListMapper (str, arg) = case arg of
Left _ -> Labeled Nothing str Left _ -> Labeled Nothing str
@ -177,27 +217,31 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
asNameBinds = mapMaybe asNameBind argVals asNameBinds = mapMaybe asNameBind argVals
allBinds = nestedBinds <> asNameBinds allBinds = nestedBinds <> asNameBinds
newEMap = Map.fromList newEMap =
((\(Named n _) -> (n, applyIconName)) <$> nestedArgs) Map.fromList
<> nestedEMaps ((\(Named n _) -> (n, applyIconName)) <$> nestedArgs)
<> nestedEMaps
newGraph = SyntaxGraph newGraph =
icons SyntaxGraph
[] icons
nestedSinks []
allBinds nestedSinks
newEMap allBinds
nestedApplyResult = (newGraph <> combinedGraph newEMap
, nameAndPort applyIconName (resultPort pAppNode)) nestedApplyResult =
( newGraph <> combinedGraph,
nameAndPort applyIconName (resultPort pAppNode)
)
evalPApp ::
evalPApp :: Show l => Show l =>
Exts.QName l Exts.QName l ->
-> [SimpPat l] [SimpPat l] ->
-> State IDState (SyntaxGraph, NameAndPort) State IDState (SyntaxGraph, NameAndPort)
evalPApp name patterns = case patterns of evalPApp name patterns = case patterns of
[] -> makeBox constructorName [] -> makeBox constructorName
_ -> do _ -> do
patName <- getUniqueName patName <- getUniqueName
evaledPatterns <- mapM evalPattern patterns evaledPatterns <- mapM evalPattern patterns
pure $ makeNestedPatternGraph patName constructorName evaledPatterns pure $ makeNestedPatternGraph patName constructorName evaledPatterns
@ -226,22 +270,29 @@ evalPLit ::
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 :: Show l => evalPAsPat ::
Exts.Name l -> SimpPat l -> State IDState (GraphAndRef, Maybe String) Show l =>
Exts.Name l ->
SimpPat 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 outerName = nameToString n
outerName = nameToString n asBindGraph = makeAsBindGraph (Left outerName) [mInnerName]
asBindGraph = makeAsBindGraph (Left outerName) [mInnerName] pure
pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef ( GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef,
, Just outerName) Just outerName
)
makePatternResult :: Functor f => makePatternResult ::
f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String) Functor f =>
makePatternResult f (SyntaxGraph, NameAndPort) ->
= fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) f (GraphAndRef, Maybe String)
makePatternResult =
fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
evalPattern :: Show l => SimpPat l -> State IDState (GraphAndRef, Maybe String) evalPattern :: Show l => SimpPat l -> State IDState (GraphAndRef, Maybe String)
evalPattern p = case p of evalPattern p = case p of
@ -250,7 +301,8 @@ evalPattern p = case p of
SpApp _ name patterns -> makePatternResult $ evalPApp name patterns SpApp _ name patterns -> makePatternResult $ evalPApp name patterns
SpAsPat _ name pat -> evalPAsPat name pat SpAsPat _ name pat -> evalPAsPat name pat
SpWildCard _ -> makePatternResult $ makeBox "_" SpWildCard _ -> makePatternResult $ makeBox "_"
-- _ -> error ("evalPattern todo: " <> show p)
-- _ -> error ("evalPattern todo: " <> show p)
-- END evalPattern -- END evalPattern
@ -258,49 +310,56 @@ evalPattern p = case p of
-- 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 GraphAndRef strToGraphRef :: EvalContext -> String -> State IDState GraphAndRef
strToGraphRef c str = fmap mapper (makeBox str) where strToGraphRef c str = fmap mapper (makeBox str)
mapper gr = if str `elem` c where
then GraphAndRef mempty (Left str) mapper gr =
else grNamePortToGrRef gr if str `elem` c
then GraphAndRef mempty (Left str)
else grNamePortToGrRef gr
-- END evalQName -- END evalQName
-- BEGIN apply and compose helper functions -- BEGIN apply and compose helper functions
evalFunExpAndArgs :: Show l => evalFunExpAndArgs ::
EvalContext Show l =>
-> LikeApplyFlavor EvalContext ->
-> (SimpExp l, [SimpExp l]) LikeApplyFlavor ->
-> State IDState (SyntaxGraph, NameAndPort) (SimpExp l, [SimpExp 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
applyIconName <- getUniqueName applyIconName <- getUniqueName
pure pure $
$ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals makeApplyGraph (length argExps) flavor False applyIconName funVal argVals
-- END apply and compose helper functions -- END apply and compose helper functions
evalFunctionComposition :: Show l => evalFunctionComposition ::
EvalContext -> [SimpExp l] -> State IDState (SyntaxGraph, NameAndPort) Show l =>
EvalContext ->
[SimpExp 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
neverUsedPort <- Left <$> getUniqueString "unusedArgument" neverUsedPort <- Left <$> getUniqueString "unusedArgument"
applyIconName <- getUniqueName applyIconName <- getUniqueName
pure $ makeApplyGraph pure $
(length evaluatedFunctions) makeApplyGraph
ComposeNodeFlavor (length evaluatedFunctions)
False ComposeNodeFlavor
applyIconName False
(GraphAndRef mempty neverUsedPort) applyIconName
evaluatedFunctions (GraphAndRef mempty neverUsedPort)
evaluatedFunctions
-- | Turn (a . b . c) into [a, b, c] -- | Turn (a . b . c) into [a, b, c]
compositionToList :: SimpExp l -> [SimpExp l] compositionToList :: SimpExp l -> [SimpExp l]
compositionToList e = case e of compositionToList e = case e of
(SeApp _ (SeApp _ (SeName _ ".") f1) f2) (SeApp _ (SeApp _ (SeName _ ".") f1) f2) ->
-> f1 : compositionToList f2 f1 : compositionToList f2
x -> [x] x -> [x]
-- BEGIN evaluateAppExpression -- BEGIN evaluateAppExpression
@ -309,22 +368,23 @@ compositionToList e = case e of
-- 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 :: SimpExp l -> SimpExp l -> (Int, Int) applyComposeScoreHelper :: SimpExp l -> SimpExp l -> (Int, Int)
applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where applyComposeScoreHelper exp1 exp2 = (appScore, compScore)
(e1App, e1Comp) = applyComposeScore exp1 where
(e2App, e2Comp) = applyComposeScore exp2 (e1App, e1Comp) = applyComposeScore exp1
(e2App, e2Comp) = applyComposeScore exp2
leftApp = min e1App (1 + e1Comp) leftApp = min e1App (1 + e1Comp)
rightApp = 1 + min e2App e2Comp rightApp = 1 + min e2App e2Comp
appScore = max leftApp rightApp appScore = max leftApp rightApp
leftComp = 1 + min e1App e1Comp leftComp = 1 + min e1App e1Comp
rightComp = min (1 + e2App) e2Comp rightComp = min (1 + e2App) e2Comp
compScore = max leftComp rightComp
compScore = max leftComp rightComp
-- 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 -- | Returns the amount of nesting if the App is converted to
-- (applyNode, composeNode) -- (applyNode, composeNode)
applyComposeScore :: SimpExp l -> (Int, Int) applyComposeScore :: SimpExp l -> (Int, Int)
@ -333,6 +393,7 @@ applyComposeScore e = case e of
_ -> (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 :: SimpExp l -> (SimpExp l, [SimpExp l]) appExpToFuncArgs :: SimpExp l -> (SimpExp l, [SimpExp l])
@ -351,18 +412,20 @@ appExpToArgFuncs e = case e of
(argExp, funcs) = appExpToArgFuncs exp2 (argExp, funcs) = appExpToArgFuncs exp2
simpleExp -> (simpleExp, []) simpleExp -> (simpleExp, [])
-- TODO Refactor this and all sub-expressions -- TODO Refactor this and all sub-expressions
evalApp :: Show l => evalApp ::
EvalContext -> SimpExp l Show l =>
-> State IDState (SyntaxGraph, NameAndPort) EvalContext ->
SimpExp l ->
State IDState (SyntaxGraph, NameAndPort)
evalApp c expr = case expr of evalApp c expr = case expr of
-- TODO This pattern for "." appears at least twice in this file. Refactor? -- TODO This pattern for "." appears at least twice in this file. Refactor?
(SeApp _ (SeApp _ (SeName _ ".") _) _) (SeApp _ (SeApp _ (SeName _ ".") _) _) ->
-> evalFunctionComposition c (compositionToList expr) evalFunctionComposition c (compositionToList expr)
_ -> if appScore <= compScore _ ->
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr) if appScore <= compScore
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr) then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr)
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr)
where where
(appScore, compScore) = applyComposeScore expr (appScore, compScore) = applyComposeScore expr
@ -372,148 +435,162 @@ evalApp c expr = case expr of
getBoundVarName :: Show l => SimpDecl l -> [String] getBoundVarName :: Show l => SimpDecl l -> [String]
getBoundVarName d = case d of getBoundVarName d = case d of
SdPatBind _ pat _ -> namesInPattern SdPatBind _ pat _ ->
-- TODO Should evalState be used here? namesInPattern
$ evalState (evalPattern pat) initialIdState -- TODO Should evalState be used here?
$
evalState (evalPattern pat) initialIdState
SdTypeSig _ _ _ -> [] SdTypeSig _ _ _ -> []
SdCatchAll _ -> [] SdCatchAll _ -> []
evalDecls :: Show l => evalDecls ::
EvalContext -> [SimpDecl l] -> State IDState (SyntaxGraph, EvalContext) Show l =>
EvalContext ->
[SimpDecl l] ->
State IDState (SyntaxGraph, EvalContext)
evalDecls c decls = evalDecls c decls =
let let boundNames = concatMap getBoundVarName decls
boundNames = concatMap getBoundVarName decls augmentedContext = boundNames <> c
augmentedContext = boundNames <> c in (,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
in
(,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
evalLet :: Show l => evalLet ::
EvalContext Show l =>
-> [SimpDecl l] EvalContext ->
-> SimpExp l [SimpDecl l] ->
-> State IDState GraphAndRef SimpExp l ->
State IDState GraphAndRef
evalLet c decls expr = do evalLet c decls expr = do
(bindGraph, bindContext) <- evalDecls c decls (bindGraph, bindContext) <- evalDecls c decls
expVal <- evalExp bindContext expr expVal <- evalExp bindContext expr
let let GraphAndRef expGraph expResult = expVal
GraphAndRef expGraph expResult = expVal newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph bindings = sgBinds bindGraph
bindings = sgBinds bindGraph
pure $ GraphAndRef newGraph (lookupReference bindings expResult) pure $ GraphAndRef newGraph (lookupReference bindings expResult)
-- END evalGeneralLet -- END evalGeneralLet
evalSelectorAndVal :: Show l => evalSelectorAndVal ::
EvalContext -> SelectorAndVal l -> State IDState (GraphAndRef, GraphAndRef) Show l =>
evalSelectorAndVal c SelectorAndVal{svSelector=sel, svVal=val} EvalContext ->
= (,) <$> evalExp c sel <*> evalExp c val SelectorAndVal l ->
State IDState (GraphAndRef, GraphAndRef)
evalSelectorAndVal c SelectorAndVal {svSelector = sel, svVal = val} =
(,) <$> evalExp c sel <*> evalExp c val
evalMultiIf :: Show l => evalMultiIf ::
EvalContext -> [SelectorAndVal l] -> State IDState (SyntaxGraph, NameAndPort) Show l =>
evalMultiIf c selectorsAndVals = let EvalContext ->
evaledRhss = unzip <$> mapM (evalSelectorAndVal c) selectorsAndVals [SelectorAndVal l] ->
in State IDState (SyntaxGraph, NameAndPort)
makeMultiIfGraph (length selectorsAndVals) evalMultiIf c selectorsAndVals =
<$> let evaledRhss = unzip <$> mapM (evalSelectorAndVal c) selectorsAndVals
getUniqueName in makeMultiIfGraph (length selectorsAndVals)
<*> <$> getUniqueName
fmap fst evaledRhss <*> fmap fst evaledRhss
<*> <*> fmap snd evaledRhss
fmap snd evaledRhss
-- BEGIN evalCase -- BEGIN evalCase
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a -- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a
-- name -- name
-- returns (combined graph, pattern reference, rhs reference) -- returns (combined graph, pattern reference, rhs reference)
evalAlt :: Show l => evalAlt ::
EvalContext Show l =>
-> SimpAlt l EvalContext ->
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) SimpAlt l ->
State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
evalAlt c (SimpAlt pat rhs) = do evalAlt c (SimpAlt pat rhs) = do
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
bindOrAltHelper c pat rhs bindOrAltHelper c pat rhs
let let grWithEdges = makeEdges (rhsGraph <> patGraph)
grWithEdges = makeEdges (rhsGraph <> patGraph) lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef
lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef -- The pattern and rhs are conneted if makeEdges added extra edges, or if
-- The pattern and rhs are conneted if makeEdges added extra edges, or if -- the rhsRef refers to a source in the pattern.
-- the rhsRef refers to a source in the pattern. patRhsAreConnected =
patRhsAreConnected (rhsRef /= lookedUpRhsRef)
= (rhsRef /= lookedUpRhsRef) || ( length (sgEdges grWithEdges)
|| ( length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph))
> )
(length (sgEdges rhsGraph) + length (sgEdges patGraph))) pure
pure (patRhsAreConnected ( patRhsAreConnected,
, deleteBindings grWithEdges deleteBindings grWithEdges,
, patRef patRef,
, lookedUpRhsRef lookedUpRhsRef,
, mPatAsName) mPatAsName
)
evalCaseHelper :: evalCaseHelper ::
Int Int ->
-> NodeName NodeName ->
-> [NodeName] [NodeName] ->
-> GraphAndRef GraphAndRef ->
-> [(Bool, SyntaxGraph, Reference, Reference, Maybe String)] [(Bool, SyntaxGraph, Reference, Reference, Maybe String)] ->
-> (SyntaxGraph, NameAndPort) (SyntaxGraph, NameAndPort)
evalCaseHelper numAlts caseIconName resultIconNames evalCaseHelper
(GraphAndRef expGraph expRef) evaledAlts numAlts
= result caseIconName
where resultIconNames
(patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts (GraphAndRef expGraph expRef)
combindedAltGraph = mconcat altGraphs evaledAlts =
caseNode = CaseOrMultiIfNode CaseTag numAlts result
icons = [Named caseIconName (mkEmbedder caseNode)] where
caseGraph = syntaxGraphFromNodes icons (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts
expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) combindedAltGraph = mconcat altGraphs
patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts caseNode = CaseOrMultiIfNode CaseTag numAlts
rhsEdges = zip patRhsConnected $ zip rhsRefs icons = [Named caseIconName (mkEmbedder caseNode)]
$ map (nameAndPort caseIconName) caseRhsPorts caseGraph = syntaxGraphFromNodes icons
(connectedRhss, unConnectedRhss) = partition fst rhsEdges expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode))
patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts
rhsEdges =
zip patRhsConnected $
zip rhsRefs $
map (nameAndPort caseIconName) caseRhsPorts
(connectedRhss, unConnectedRhss) = partition fst rhsEdges
makeCaseResult :: NodeName -> Reference -> SyntaxGraph makeCaseResult :: NodeName -> Reference -> SyntaxGraph
makeCaseResult resultIconName rhsRef = case rhsRef of makeCaseResult resultIconName rhsRef = case rhsRef of
Left _ -> mempty Left _ -> mempty
Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges
where where
rhsNewIcons = [Named resultIconName (mkEmbedder CaseResultNode)] rhsNewIcons = [Named resultIconName (mkEmbedder CaseResultNode)]
rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)]
caseResultGraphs = caseResultGraphs =
mconcat mconcat $
$ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
filteredRhsEdges = fmap snd unConnectedRhss filteredRhsEdges = fmap snd unConnectedRhss
patternEdgesGraph = edgesForRefPortList True patEdges patternEdgesGraph = edgesForRefPortList True patEdges
caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges)
bindGraph = makeAsBindGraph expRef asNames bindGraph = makeAsBindGraph expRef asNames
finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph finalGraph =
, patternEdgesGraph deleteBindings $
, caseResultGraphs makeEdges $
, expGraph mconcat
, caseEdgeGraph [ bindGraph,
, caseGraph patternEdgesGraph,
, combindedAltGraph] caseResultGraphs,
result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) expGraph,
caseEdgeGraph,
caseGraph,
combindedAltGraph
]
result = (finalGraph, nameAndPort caseIconName (resultPort caseNode))
evalCase ::
evalCase :: Show l => Show l =>
EvalContext -> SimpExp l -> [SimpAlt l] EvalContext ->
-> State IDState (SyntaxGraph, NameAndPort) SimpExp l ->
[SimpAlt l] ->
State IDState (SyntaxGraph, NameAndPort)
evalCase c e alts = evalCase c e alts =
let let numAlts = length alts
numAlts = length alts in evalCaseHelper (length alts)
in <$> getUniqueName
evalCaseHelper (length alts) <*> replicateM numAlts getUniqueName
<$> <*> evalExp c e
getUniqueName <*> mapM (evalAlt c) alts
<*>
replicateM numAlts getUniqueName
<*>
evalExp c e
<*>
mapM (evalAlt c) alts
-- END evalCase -- END evalCase
@ -524,44 +601,46 @@ asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName] asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
-- TODO Refactor evalLambda -- TODO Refactor evalLambda
evalLambda :: Show l evalLambda ::
=> l Show l =>
-> EvalContext l ->
-> [SimpPat l] EvalContext ->
-> SimpExp l [SimpPat l] ->
-> State IDState (SyntaxGraph, NameAndPort) SimpExp l ->
State IDState (SyntaxGraph, NameAndPort)
evalLambda _ context patterns expr = do evalLambda _ context patterns expr = do
lambdaName <- getUniqueName lambdaName <- getUniqueName
patternValsWithAsNames <- mapM evalPattern patterns patternValsWithAsNames <- mapM evalPattern patterns
let let patternVals = fmap fst patternValsWithAsNames
patternVals = fmap fst patternValsWithAsNames patternStrings = concatMap namesInPattern patternValsWithAsNames
patternStrings = concatMap namesInPattern patternValsWithAsNames rhsContext = patternStrings <> context
rhsContext = patternStrings <> context
GraphAndRef rhsRawGraph rhsRef <- evalExp rhsContext expr GraphAndRef rhsRawGraph rhsRef <- evalExp rhsContext expr
let let paramNames = fmap patternName patternValsWithAsNames
paramNames = fmap patternName patternValsWithAsNames enclosedNodeNames = Set.fromList $ naName <$> sgNodes combinedGraph
enclosedNodeNames = Set.fromList $ naName <$> sgNodes combinedGraph lambdaNode = FunctionDefNode paramNames enclosedNodeNames
lambdaNode = FunctionDefNode paramNames enclosedNodeNames lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
(patternEdges, newBinds) = (patternEdges, newBinds) =
partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts
icons = [Named lambdaName (mkEmbedder lambdaNode)] icons = [Named lambdaName (mkEmbedder lambdaNode)]
returnPort = nameAndPort lambdaName (inputPort lambdaNode) returnPort = nameAndPort lambdaName (inputPort lambdaNode)
(newEdges, newSinks) = case rhsRef of (newEdges, newSinks) = case rhsRef of
Left s -> (patternEdges, [SgSink s returnPort]) Left s -> (patternEdges, [SgSink s returnPort])
Right rhsPort -> Right rhsPort ->
(makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty) (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty)
finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty
asBindGraph = mconcat $ zipWith asBindGraph =
asBindGraphZipper mconcat $
(fmap snd patternValsWithAsNames) zipWith
lambdaPorts asBindGraphZipper
combinedGraph = deleteBindings . makeEdges (fmap snd patternValsWithAsNames)
$ (asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph) lambdaPorts
combinedGraph =
deleteBindings . makeEdges $
(asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph)
pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode)) pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode))
where where
@ -584,35 +663,43 @@ evalExp c x = case x of
SeLambda l patterns e -> grNamePortToGrRef <$> evalLambda l c patterns e SeLambda l patterns e -> grNamePortToGrRef <$> evalLambda l c patterns e
SeLet _ decls expr -> evalLet c decls expr SeLet _ decls expr -> evalLet c decls expr
SeCase _ expr alts -> grNamePortToGrRef <$> evalCase c expr alts SeCase _ expr alts -> grNamePortToGrRef <$> evalCase c expr alts
SeMultiIf _ selectorsAndVals SeMultiIf _ selectorsAndVals ->
-> grNamePortToGrRef <$> evalMultiIf c selectorsAndVals grNamePortToGrRef <$> evalMultiIf c selectorsAndVals
-- BEGIN evalDecl -- BEGIN evalDecl
evalPatBind :: Show l => evalPatBind ::
l -> EvalContext -> SimpPat l -> SimpExp l -> State IDState SyntaxGraph Show l =>
l ->
EvalContext ->
SimpPat l ->
SimpExp l ->
State IDState SyntaxGraph
evalPatBind _ c pat e = do evalPatBind _ c pat e = do
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
bindOrAltHelper c pat e bindOrAltHelper c pat e
let let (newEdges, newSinks, bindings) = case patRef of
(newEdges, newSinks, bindings) = case patRef of (Left s) -> (mempty, mempty, [SgBind s rhsRef])
(Left s) -> (mempty, mempty, [SgBind s rhsRef]) (Right patPort) -> case rhsRef of
(Right patPort) -> case rhsRef of (Left rhsStr) -> (mempty, [SgSink rhsStr patPort], mempty)
(Left rhsStr) -> (mempty, [SgSink rhsStr patPort], mempty) (Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty) asBindGraph = makeAsBindGraph rhsRef [mPatAsName]
asBindGraph = makeAsBindGraph rhsRef [mPatAsName] gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
pure . makeEdges $ (gr <> rhsGraph <> patGraph) pure . makeEdges $ (gr <> rhsGraph <> patGraph)
-- 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 :: Show l => evalTypeSig ::
[Exts.Name l] -> Exts.Type l Show l =>
-> State IDState (SyntaxGraph, NameAndPort) [Exts.Name l] ->
evalTypeSig names typeForNames = makeBox Exts.Type l ->
(intercalate "," (fmap prettyPrintWithoutNewlines names) State IDState (SyntaxGraph, NameAndPort)
++ " :: " evalTypeSig names typeForNames =
++ prettyPrintWithoutNewlines typeForNames) makeBox
( intercalate "," (fmap prettyPrintWithoutNewlines names)
++ " :: "
++ prettyPrintWithoutNewlines typeForNames
)
where where
-- TODO Make custom version of prettyPrint for type signitures. -- TODO Make custom version of prettyPrint for type signitures.
-- Use (unwords . words) to convert consecutive whitspace characters to one -- Use (unwords . words) to convert consecutive whitspace characters to one
@ -631,50 +718,54 @@ evalDecl c d = case d of
showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph
showTopLevelBinds gr = do showTopLevelBinds gr = do
let let binds = sgBinds gr
binds = sgBinds gr addBind (SgBind _ (Left _)) = pure mempty
addBind (SgBind _ (Left _)) = pure mempty addBind (SgBind patName (Right port)) = do
addBind (SgBind patName (Right port)) = do uniquePatName <- getUniqueName
uniquePatName <- getUniqueName let icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)]
let edges = [makeSimpleEdge (port, justName uniquePatName)]
icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)] edgeGraph = syntaxGraphFromNodesEdges icons edges
edges = [makeSimpleEdge (port, justName uniquePatName)] pure edgeGraph
edgeGraph = syntaxGraphFromNodesEdges icons edges
pure edgeGraph
newGraph <- mconcat <$> mapM addBind binds newGraph <- mconcat <$> mapM addBind binds
pure $ newGraph <> gr pure $ newGraph <> gr
translateDeclToSyntaxGraph :: Show l => SimpDecl l -> SyntaxGraph translateDeclToSyntaxGraph :: Show l => SimpDecl l -> SyntaxGraph
translateDeclToSyntaxGraph d = graph where translateDeclToSyntaxGraph d = graph
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds where
graph = evalState evaluatedDecl initialIdState evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
graph = evalState evaluatedDecl initialIdState
-- | Convert a single function declaration into a SyntaxGraph -- | Convert a single function declaration into a SyntaxGraph
translateStringToSyntaxGraph :: String -> SyntaxGraph translateStringToSyntaxGraph :: String -> SyntaxGraph
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr
syntaxGraphToCollapsedGraph syntaxGraphToCollapsedGraph =
= collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph
-- = annotateGraph . syntaxGraphToFglGraph
-- = annotateGraph . syntaxGraphToFglGraph
translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> AnnotatedGraph FGR.Gr translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> AnnotatedGraph FGR.Gr
translateDeclToCollapsedGraph translateDeclToCollapsedGraph =
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
-- 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 :: translateStringToCollapsedGraphAndDecl ::
String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo) String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where translateStringToCollapsedGraphAndDecl s = (drawing, decl)
decl = customParseDecl s -- :: ParseResult Module where
drawing = translateDeclToCollapsedGraph decl decl = customParseDecl s -- :: ParseResult Module
drawing = translateDeclToCollapsedGraph decl
translateModuleToCollapsedGraphs :: Show l => translateModuleToCollapsedGraphs ::
Exts.Module l -> [AnnotatedGraph FGR.Gr] Show l =>
translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls) Exts.Module l ->
= fmap translateDeclToCollapsedGraph decls [AnnotatedGraph FGR.Gr]
translateModuleToCollapsedGraphs moduleSyntax translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls) =
= error $ "Unsupported syntax in translateModuleToCollapsedGraphs: " fmap translateDeclToCollapsedGraph decls
<> show moduleSyntax translateModuleToCollapsedGraphs moduleSyntax =
error $
"Unsupported syntax in translateModuleToCollapsedGraphs: "
<> show moduleSyntax
-- END Exported functions -- END Exported functions

399
app/TranslateCore.hs
View File

@ -1,51 +1,74 @@
module TranslateCore( -- This file is formatted with Ormolu
Reference, module TranslateCore
SyntaxGraph(..), ( Reference,
EvalContext, SyntaxGraph (..),
GraphAndRef(..), EvalContext,
SgSink(..), GraphAndRef (..),
SgBind(..), SgSink (..),
syntaxGraphFromNodes, SgBind (..),
syntaxGraphFromNodesEdges, syntaxGraphFromNodes,
bindsToSyntaxGraph, syntaxGraphFromNodesEdges,
graphAndRefToGraph, bindsToSyntaxGraph,
getUniqueName, graphAndRefToGraph,
getUniqueString, getUniqueName,
edgesForRefPortList, getUniqueString,
combineExpressions, edgesForRefPortList,
makeApplyGraph, combineExpressions,
makeMultiIfGraph, makeApplyGraph,
namesInPattern, makeMultiIfGraph,
lookupReference, namesInPattern,
deleteBindings, lookupReference,
makeEdges, deleteBindings,
makeBox, makeEdges,
nTupleString, makeBox,
nTupleSectionString, nTupleString,
nListString, nTupleSectionString,
syntaxGraphToFglGraph, nListString,
nodeToIcon, syntaxGraphToFglGraph,
initialIdState nodeToIcon,
) where initialIdState,
)
where
import Control.Monad.State(State, state) import Control.Monad.State (State, state)
import Data.Either(partitionEithers) import Data.Either (partitionEithers)
import qualified Data.Graph.Inductive.Graph as ING import qualified Data.Graph.Inductive.Graph as ING
import qualified Data.Graph.Inductive.PatriciaTree as FGR import qualified Data.Graph.Inductive.PatriciaTree as FGR
import Data.List(find) import Data.List (find)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Semigroup(Semigroup, (<>))
import qualified Data.Set as Set import qualified Data.Set as Set
import Icons
import Icons(inputPort, resultPort, argumentPorts, multiIfRhsPorts ( argumentPorts,
, multiIfBoolPorts) inputPort,
import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..) multiIfBoolPorts,
, NameAndPort(..), IDState, SgNamedNode, NodeName(..), Port multiIfRhsPorts,
, LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..) resultPort,
, Embedder(..), mkEmbedder, Named(..) )
, EmbedderSyntaxNode) import Types
import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool ( CaseOrMultiIfTag (..),
, nodeNameToInt) Edge (..),
EdgeOption (..),
Embedder (..),
EmbedderSyntaxNode,
IDState (..),
Icon (..),
Labeled (..),
LikeApplyFlavor (..),
NameAndPort (..),
Named (..),
NodeName (..),
Port,
SgNamedNode,
SyntaxNode (..),
mkEmbedder,
)
import Util
( justName,
makeSimpleEdge,
maybeBoolToBool,
nameAndPort,
nodeNameToInt,
)
{-# ANN module "HLint: ignore Use list comprehension" #-} {-# ANN module "HLint: ignore Use list comprehension" #-}
@ -63,28 +86,30 @@ data SgBind = SgBind String Reference deriving (Eq, Show, Ord)
data SgSink = SgSink String NameAndPort deriving (Eq, Ord, Show) data SgSink = SgSink String NameAndPort deriving (Eq, Ord, Show)
-- TODO Replace lists with sets -- TODO Replace lists with sets
-- | A SyntaxGraph is an abstract representation of Haskell syntax. SyntaxGraphs -- | A SyntaxGraph is an abstract representation of Haskell syntax. SyntaxGraphs
-- are generated from the Haskell syntax tree and are used to generate Drawings. -- are generated from the Haskell syntax tree and are used to generate Drawings.
data SyntaxGraph = SyntaxGraph { data SyntaxGraph = SyntaxGraph
sgNodes :: [SgNamedNode], { sgNodes :: [SgNamedNode],
sgEdges :: [Edge], sgEdges :: [Edge],
sgSinks :: [SgSink], sgSinks :: [SgSink],
sgBinds :: [SgBind], sgBinds :: [SgBind],
-- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent) -- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent)
-- is in the Map, then child is embedded inside parent. -- is in the Map, then child is embedded inside parent.
sgEmbedMap :: Map.Map NodeName NodeName sgEmbedMap :: Map.Map NodeName NodeName
} deriving (Show, Eq) }
deriving (Show, Eq)
instance Semigroup SyntaxGraph where instance Semigroup SyntaxGraph where
(<>) (<>)
(SyntaxGraph icons1 edges1 sinks1 sources1 map1) (SyntaxGraph icons1 edges1 sinks1 sources1 map1)
(SyntaxGraph icons2 edges2 sinks2 sources2 map2) (SyntaxGraph icons2 edges2 sinks2 sources2 map2) =
= SyntaxGraph SyntaxGraph
(icons1 <> icons2) (icons1 <> icons2)
(edges1 <> edges2) (edges1 <> edges2)
(sinks1 <> sinks2) (sinks1 <> sinks2)
(sources1 <> sources2) (sources1 <> sources2)
(map1 <> map2) (map1 <> map2)
instance Monoid SyntaxGraph where instance Monoid SyntaxGraph where
mempty = SyntaxGraph mempty mempty mempty mempty mempty mempty = SyntaxGraph mempty mempty mempty mempty mempty
@ -104,8 +129,8 @@ syntaxGraphFromNodes :: [SgNamedNode] -> SyntaxGraph
syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty
syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph
syntaxGraphFromNodesEdges icons edges syntaxGraphFromNodesEdges icons edges =
= SyntaxGraph icons edges mempty mempty mempty SyntaxGraph icons edges mempty mempty mempty
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
@ -127,81 +152,89 @@ initialIdState :: IDState
initialIdState = IDState 0 initialIdState = IDState 0
getId :: State IDState Int getId :: State IDState Int
getId = state incrementer where getId = state incrementer
incrementer (IDState x) = (x, IDState checkedIncrement) where where
xPlusOne = x + 1 incrementer (IDState x) = (x, IDState checkedIncrement)
checkedIncrement = if xPlusOne > x where
then xPlusOne xPlusOne = x + 1
else error "getId: the ID state has overflowed." checkedIncrement =
if xPlusOne > x
then xPlusOne
else error "getId: the ID state has overflowed."
getUniqueName :: State IDState NodeName getUniqueName :: State IDState NodeName
getUniqueName = fmap NodeName getId getUniqueName = fmap NodeName getId
-- TODO Should getUniqueString prepend an illegal character? -- TODO Should getUniqueString prepend an illegal character?
getUniqueString :: String -> State IDState String getUniqueString :: String -> State IDState String
getUniqueString base = fmap ((base ++). show) getId getUniqueString base = fmap ((base ++) . show) getId
-- END IDState -- END IDState
-- TODO: Refactor with combineExpressions -- TODO: Refactor with combineExpressions
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph
edgesForRefPortList inPattern portExpPairs edgesForRefPortList inPattern portExpPairs =
= mconcat $ fmap makeGraph portExpPairs mconcat $ fmap makeGraph portExpPairs
where where
edgeOpts = if inPattern then [EdgeInPattern] else [] edgeOpts = if inPattern then [EdgeInPattern] else []
makeGraph (ref, port) = case ref of makeGraph (ref, port) = case ref of
Left str -> if inPattern Left str ->
then bindsToSyntaxGraph [SgBind str (Right port)] if inPattern
else sinksToSyntaxGraph [SgSink str port] then bindsToSyntaxGraph [SgBind str (Right port)]
else sinksToSyntaxGraph [SgSink str port]
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection] Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection]
where where
connection = if inPattern connection =
-- If in a pattern, then the port on the case icon is if inPattern
-- the data source. then -- If in a pattern, then the port on the case icon is
then (port, resPort) -- the data source.
else (resPort, port) (port, resPort)
else (resPort, port)
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph
combineExpressions inPattern portExpPairs combineExpressions inPattern portExpPairs =
= mconcat $ fmap makeGraph portExpPairs mconcat $ fmap makeGraph portExpPairs
where where
edgeOpts = if inPattern then [EdgeInPattern] else [] edgeOpts = if inPattern then [EdgeInPattern] else []
makeGraph (GraphAndRef graph ref, port) = graph <> case ref of makeGraph (GraphAndRef graph ref, port) =
Left str -> if inPattern graph <> case ref of
then bindsToSyntaxGraph [SgBind str (Right port)] Left str ->
else sinksToSyntaxGraph [SgSink str port] if inPattern
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)] then bindsToSyntaxGraph [SgBind str (Right port)]
else sinksToSyntaxGraph [SgSink str port]
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)]
makeApplyGraph :: makeApplyGraph ::
Int Int ->
-> LikeApplyFlavor LikeApplyFlavor ->
-> Bool Bool ->
-> NodeName NodeName ->
-> GraphAndRef GraphAndRef ->
-> [GraphAndRef] [GraphAndRef] ->
-> (SyntaxGraph, NameAndPort) (SyntaxGraph, NameAndPort)
makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals =
= (newGraph <> combinedGraph ( newGraph <> combinedGraph,
, nameAndPort applyIconName (resultPort applyNode) nameAndPort applyIconName (resultPort applyNode)
) )
where where
applyNode = ApplyNode applyFlavor numArgs applyNode = ApplyNode applyFlavor numArgs
argumentNamePorts argumentNamePorts =
= map (nameAndPort applyIconName) (argumentPorts applyNode) map (nameAndPort applyIconName) (argumentPorts applyNode)
functionPort = nameAndPort applyIconName (inputPort applyNode) functionPort = nameAndPort applyIconName (inputPort applyNode)
combinedGraph = combineExpressions inPattern combinedGraph =
$ zip (funVal:argVals) (functionPort:argumentNamePorts) combineExpressions inPattern $
zip (funVal : argVals) (functionPort : argumentNamePorts)
icons = [Named applyIconName (mkEmbedder applyNode)] icons = [Named applyIconName (mkEmbedder applyNode)]
newGraph = syntaxGraphFromNodes icons newGraph = syntaxGraphFromNodes icons
makeMultiIfGraph :: makeMultiIfGraph ::
Int Int ->
-> NodeName NodeName ->
-> [GraphAndRef] [GraphAndRef] ->
-> [GraphAndRef] [GraphAndRef] ->
-> (SyntaxGraph, NameAndPort) (SyntaxGraph, NameAndPort)
makeMultiIfGraph numPairs multiIfName bools exps makeMultiIfGraph numPairs multiIfName bools exps =
= (newGraph, nameAndPort multiIfName (resultPort multiIfNode)) (newGraph, nameAndPort multiIfName (resultPort multiIfNode))
where where
multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs
expsWithPorts = zip exps $ map (nameAndPort multiIfName) multiIfRhsPorts expsWithPorts = zip exps $ map (nameAndPort multiIfName) multiIfRhsPorts
@ -226,14 +259,15 @@ namesInPattern (graphAndRef, mName) = case mName of
-- 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.
lookupReference :: [SgBind] -> Reference -> Reference lookupReference :: [SgBind] -> Reference -> Reference
lookupReference _ ref@(Right _) = ref lookupReference _ ref@(Right _) = ref
lookupReference bindings ref@(Left originalS) = lookupHelper ref where lookupReference bindings ref@(Left originalS) = lookupHelper ref
lookupHelper newRef@(Right _) = newRef where
lookupHelper newRef@(Left s)= case lookup s (fmap sgBindToTuple bindings) of lookupHelper newRef@(Right _) = newRef
Just r -> failIfCycle r $ lookupHelper r lookupHelper newRef@(Left s) = case lookup s (fmap sgBindToTuple bindings) of
Nothing -> newRef Just r -> failIfCycle r $ lookupHelper r
where Nothing -> newRef
failIfCycle r@(Left newStr) res = if newStr == originalS then r else res where
failIfCycle _ res = res failIfCycle r@(Left newStr) res = if newStr == originalS then r else res
failIfCycle _ res = res
deleteBindings :: SyntaxGraph -> SyntaxGraph deleteBindings :: SyntaxGraph -> SyntaxGraph
deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e
@ -242,23 +276,24 @@ makeEdgesCore :: [SgSink] -> [SgBind] -> ([SgSink], [Edge])
makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
where where
renameOrMakeEdge :: SgSink -> Either SgSink Edge renameOrMakeEdge :: SgSink -> Either SgSink Edge
renameOrMakeEdge orig@(SgSink s destPort) renameOrMakeEdge orig@(SgSink s destPort) =
= case lookup s (fmap sgBindToTuple bindings) of case lookup s (fmap sgBindToTuple bindings) of
Just ref -> case lookupReference bindings ref of Just ref -> case lookupReference bindings ref of
Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort) Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort)
Left newStr -> Left $ SgSink newStr destPort Left newStr -> Left $ SgSink newStr destPort
Nothing -> Left orig Nothing -> Left orig
makeEdges :: SyntaxGraph -> SyntaxGraph makeEdges :: SyntaxGraph -> SyntaxGraph
makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph where makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph
(newSinks, newEdges) = makeEdgesCore sinks bindings where
newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap (newSinks, newEdges) = makeEdgesCore sinks bindings
newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap
makeBox :: String -> State IDState (SyntaxGraph, NameAndPort) makeBox :: String -> State IDState (SyntaxGraph, NameAndPort)
makeBox str = do makeBox str = do
name <- getUniqueName name <- getUniqueName
let graph let graph =
= syntaxGraphFromNodes [Named name (mkEmbedder (LiteralNode str))] syntaxGraphFromNodes [Named name (mkEmbedder (LiteralNode str))]
pure (graph, justName name) pure (graph, justName name)
nTupleString :: Int -> String nTupleString :: Int -> String
@ -266,15 +301,16 @@ nTupleString n = '(' : replicate (n -1) ',' ++ ")"
-- TODO Unit tests for this -- TODO Unit tests for this
nTupleSectionString :: [Bool] -> String nTupleSectionString :: [Bool] -> String
nTupleSectionString bools = '(' : (commas ++ ")") where nTupleSectionString bools = '(' : (commas ++ ")")
commas = case concatMap trueToUnderscore bools of where
[] -> [] commas = case concatMap trueToUnderscore bools of
(_:xs) -> xs [] -> []
(_ : xs) -> xs
trueToUnderscore x = if x
then ",_"
else ","
trueToUnderscore x =
if x
then ",_"
else ","
nListString :: Int -> String nListString :: Int -> String
-- TODO: Use something better than [_] -- TODO: Use something better than [_]
@ -283,35 +319,38 @@ nListString n = '[' : replicate (n -1) ',' ++ "]"
nodeToIcon :: EmbedderSyntaxNode -> Icon nodeToIcon :: EmbedderSyntaxNode -> Icon
nodeToIcon (Embedder embeddedNodes node) = case node of nodeToIcon (Embedder embeddedNodes node) = case node of
(ApplyNode flavor x) (ApplyNode flavor x) ->
-> nestedApplySyntaxNodeToIcon flavor x embeddedNodes nestedApplySyntaxNodeToIcon flavor x embeddedNodes
(PatternApplyNode s children) (PatternApplyNode s children) ->
-> nestedPatternNodeToIcon s children nestedPatternNodeToIcon s children
(NameNode s) -> TextBoxIcon s (NameNode s) -> TextBoxIcon s
(BindNameNode s) -> BindTextBoxIcon s (BindNameNode s) -> BindTextBoxIcon s
(LiteralNode s) -> TextBoxIcon s (LiteralNode s) -> TextBoxIcon s
(FunctionDefNode labels bodyNodes) (FunctionDefNode labels bodyNodes) ->
-> nestedLambdaToIcon labels embeddedNodes bodyNodes nestedLambdaToIcon labels embeddedNodes bodyNodes
CaseResultNode -> CaseResultIcon CaseResultNode -> CaseResultIcon
(CaseOrMultiIfNode tag x) (CaseOrMultiIfNode tag x) ->
-> nestedCaseOrMultiIfNodeToIcon tag x embeddedNodes nestedCaseOrMultiIfNodeToIcon tag x embeddedNodes
-- | Helper for makeArg -- | Helper for makeArg
findArg :: Port -> (NodeName, Edge) -> Bool findArg :: Port -> (NodeName, Edge) -> Bool
findArg currentPort findArg
(argName currentPort
, Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) ( argName,
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort )
| otherwise = False -- This case should never happen | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
| otherwise = False -- This case should never happen
makeArg :: Set.Set (NodeName, Edge) -> Port -> Maybe NodeName makeArg :: Set.Set (NodeName, Edge) -> Port -> Maybe NodeName
makeArg args port = fst <$> find (findArg port) args makeArg args port = fst <$> find (findArg port) args
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor nestedApplySyntaxNodeToIcon ::
-> Int LikeApplyFlavor ->
-> Set.Set (NodeName, Edge) Int ->
-> Icon Set.Set (NodeName, Edge) ->
Icon
nestedApplySyntaxNodeToIcon flavor numArgs args = nestedApplySyntaxNodeToIcon flavor numArgs args =
NestedApply flavor headIcon argList NestedApply flavor headIcon argList
where where
@ -320,10 +359,11 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
headIcon = makeArg args (inputPort dummyNode) headIcon = makeArg args (inputPort dummyNode)
argList = fmap (makeArg args) argPorts argList = fmap (makeArg args) argPorts
nestedLambdaToIcon :: [String] -- labels nestedLambdaToIcon ::
-> Set.Set (NodeName, Edge) -- embedded icons [String] -> -- labels
-> Set.Set NodeName -- body nodes Set.Set (NodeName, Edge) -> -- embedded icons
-> Icon Set.Set NodeName -> -- body nodes
Icon
nestedLambdaToIcon labels embeddedNodes = nestedLambdaToIcon labels embeddedNodes =
LambdaIcon labels embeddedBodyNode LambdaIcon labels embeddedBodyNode
where where
@ -331,10 +371,10 @@ nestedLambdaToIcon labels embeddedNodes =
embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode) embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode)
nestedCaseOrMultiIfNodeToIcon :: nestedCaseOrMultiIfNodeToIcon ::
CaseOrMultiIfTag CaseOrMultiIfTag ->
-> Int Int ->
-> Set.Set (NodeName, Edge) Set.Set (NodeName, Edge) ->
-> Icon Icon
nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of
CaseTag -> NestedCaseIcon argList CaseTag -> NestedCaseIcon argList
MultiIfTag -> NestedMultiIfIcon argList MultiIfTag -> NestedMultiIfIcon argList
@ -344,29 +384,38 @@ nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of
argList = fmap (makeArg args) (inputPort dummyNode : argPorts) argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
nestedPatternNodeToIcon :: String -> [Labeled (Maybe SgNamedNode)] -> Icon nestedPatternNodeToIcon :: String -> [Labeled (Maybe SgNamedNode)] -> Icon
nestedPatternNodeToIcon str children = NestedPApp nestedPatternNodeToIcon str children =
(pure (Just (Named (NodeName (-1)) (TextBoxIcon str)))) NestedPApp
-- Why so many fmaps? (pure (Just (Named (NodeName (-1)) (TextBoxIcon str))))
( (fmap . fmap . fmap . fmap) nodeToIcon children) -- Why so many fmaps?
((fmap . fmap . fmap . fmap) nodeToIcon children)
makeLNode :: SgNamedNode -> ING.LNode SgNamedNode makeLNode :: SgNamedNode -> ING.LNode SgNamedNode
makeLNode namedNode@(Named (NodeName name) _) = (name, namedNode) makeLNode namedNode@(Named (NodeName name) _) = (name, namedNode)
lookupInEmbeddingMap :: NodeName -> Map.Map NodeName NodeName -> NodeName lookupInEmbeddingMap :: NodeName -> Map.Map NodeName NodeName -> NodeName
lookupInEmbeddingMap origName eMap = lookupHelper origName where lookupInEmbeddingMap origName eMap = lookupHelper origName
lookupHelper name = case Map.lookup name eMap of where
Nothing -> name lookupHelper name = case Map.lookup name eMap of
Just parent -> if parent == origName Nothing -> name
then error $ "lookupInEmbeddingMap: Found cycle. Node = " Just parent ->
++ show origName ++ "\nEmbedding Map = " ++ show eMap if parent == origName
else lookupHelper parent then
error $
"lookupInEmbeddingMap: Found cycle. Node = "
++ show origName
++ "\nEmbedding Map = "
++ show eMap
else lookupHelper parent
syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge
syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) = syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
ING.mkGraph (fmap makeLNode nodes) labeledEdges where ING.mkGraph (fmap makeLNode nodes) labeledEdges
where
labeledEdges = fmap makeLabeledEdge edges labeledEdges = fmap makeLabeledEdge edges
makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) = makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) =
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap ( nodeNameToInt $ lookupInEmbeddingMap name1 eMap,
, nodeNameToInt $ lookupInEmbeddingMap name2 eMap nodeNameToInt $ lookupInEmbeddingMap name2 eMap,
, e) e
)

144
app/Types.hs
View File

@ -1,47 +1,50 @@
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-} -- This file is formatted with Ormolu
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Types ( module Types
Named(..), ( Named (..),
NamedIcon, NamedIcon,
IconInfo, IconInfo,
Icon(..), Icon (..),
SyntaxNode(..), SyntaxNode (..),
NodeName(..), NodeName (..),
Port(..), Port (..),
NameAndPort(..), NameAndPort (..),
Connection, Connection,
Edge(..), Edge (..),
EdgeOption(..), EdgeOption (..),
Drawing(..), Drawing (..),
IDState(..), IDState (..),
SpecialQDiagram, SpecialQDiagram,
SpecialBackend, SpecialBackend,
SpecialNum, SpecialNum,
SgNamedNode, SgNamedNode,
IngSyntaxGraph, IngSyntaxGraph,
LikeApplyFlavor(..), LikeApplyFlavor (..),
CaseOrMultiIfTag(..), CaseOrMultiIfTag (..),
Labeled(..), Labeled (..),
EmbedDirection(..), EmbedDirection (..),
EmbedInfo(..), EmbedInfo (..),
AnnotatedGraph, AnnotatedGraph,
NodeInfo(..), NodeInfo (..),
Embedder(..), Embedder (..),
mkEmbedder, mkEmbedder,
EmbedderSyntaxNode, EmbedderSyntaxNode,
) where )
where
import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
import Diagrams.TwoD.Text(Text)
import Control.Applicative(Applicative(..))
import qualified Data.Graph.Inductive as ING import qualified Data.Graph.Inductive as ING
import qualified Data.IntMap as IM import qualified Data.IntMap as IM
import Data.Set(Set, empty) import Data.Set (Set, empty)
import Data.Typeable(Typeable) import Data.Typeable (Typeable)
import Diagrams.Prelude (Any, IsName, Path, QDiagram, Renderable, V2)
import Diagrams.TwoD.Text (Text)
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show) newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
instance IsName NodeName instance IsName NodeName
data Named a = Named {naName :: NodeName, naVal :: a} data Named a = Named {naName :: NodeName, naVal :: a}
@ -63,23 +66,24 @@ type IconInfo = IM.IntMap Icon
-- | A datatype that represents an icon. -- | A datatype that represents an icon.
-- The TextBoxIcon's data is the text that appears in the text box. -- The TextBoxIcon's data is the text that appears in the text box.
data Icon = TextBoxIcon String data Icon
= TextBoxIcon String
| MultiIfIcon | MultiIfIcon
Int -- Number of alternatives Int -- Number of alternatives
| LambdaIcon | LambdaIcon
[String] -- Parameter labels [String] -- Parameter labels
(Maybe NodeName) -- Function body expression (Maybe NodeName) -- Function body expression
(Set NodeName) -- Nodes inside the lambda (Set NodeName) -- Nodes inside the lambda
| CaseIcon Int | CaseIcon Int
| CaseResultIcon | CaseResultIcon
| BindTextBoxIcon String | BindTextBoxIcon String
| NestedApply | NestedApply
LikeApplyFlavor -- apply or compose LikeApplyFlavor -- apply or compose
(Maybe NodeName) -- The function for apply, or the argument for compose (Maybe NodeName) -- The function for apply, or the argument for compose
[Maybe NodeName] -- list of arguments or functions [Maybe NodeName] -- list of arguments or functions
| NestedPApp | NestedPApp
(Labeled (Maybe NamedIcon)) -- Data constructor (Labeled (Maybe NamedIcon)) -- Data constructor
[Labeled (Maybe NamedIcon)] -- Arguments [Labeled (Maybe NamedIcon)] -- Arguments
| NestedCaseIcon [Maybe NodeName] | NestedCaseIcon [Maybe NodeName]
| NestedMultiIfIcon [Maybe NodeName] | NestedMultiIfIcon [Maybe NodeName]
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -90,9 +94,10 @@ data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor
data CaseOrMultiIfTag = CaseTag | MultiIfTag deriving (Show, Eq, Ord) data CaseOrMultiIfTag = CaseTag | MultiIfTag deriving (Show, Eq, Ord)
-- TODO The full edge does not need to be included, just the port. -- TODO The full edge does not need to be included, just the port.
data Embedder a = Embedder { data Embedder a = Embedder
emEmbedded :: Set (NodeName, Edge) -- ^ Set of embedded nodes { -- | Set of embedded nodes
, emNode :: a emEmbedded :: Set (NodeName, Edge),
emNode :: a
} }
deriving (Show, Eq, Ord, Functor) deriving (Show, Eq, Ord, Functor)
@ -104,22 +109,23 @@ type EmbedderSyntaxNode = Embedder SyntaxNode
type SgNamedNode = Named EmbedderSyntaxNode type SgNamedNode = Named EmbedderSyntaxNode
-- TODO remove Ints from SyntaxNode data constructors. -- TODO remove Ints from SyntaxNode data constructors.
data SyntaxNode = data SyntaxNode
-- Function application, composition, and applying to a composition = -- Function application, composition, and applying to a composition
-- The list of nodes is unordered (replace with a map?) -- The list of nodes is unordered (replace with a map?)
ApplyNode LikeApplyFlavor Int ApplyNode LikeApplyFlavor Int
| PatternApplyNode String [Labeled (Maybe SgNamedNode)] | PatternApplyNode String [Labeled (Maybe SgNamedNode)]
| NameNode String -- Identifiers or symbols | NameNode String -- Identifiers or symbols
| BindNameNode String | BindNameNode String
| LiteralNode String -- Literal values like the string "Hello World" | LiteralNode String -- Literal values like the string "Hello World"
| FunctionDefNode -- Function definition (ie. lambda expression) | FunctionDefNode -- Function definition (ie. lambda expression)
[String] -- Parameter labels [String] -- Parameter labels
(Set NodeName) -- Nodes inside the lambda (Set NodeName) -- Nodes inside the lambda
| CaseResultNode -- TODO remove caseResultNode | CaseResultNode -- TODO remove caseResultNode
| CaseOrMultiIfNode CaseOrMultiIfTag Int | CaseOrMultiIfNode CaseOrMultiIfTag Int
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
newtype Port = Port Int deriving (Typeable, Eq, Ord, Show) newtype Port = Port Int deriving (Typeable, Eq, Ord, Show)
instance IsName Port instance IsName Port
data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord) data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord)
@ -131,8 +137,10 @@ data EdgeOption = EdgeInPattern deriving (Show, Eq, Ord)
-- | An Edge has an name of the source icon, and its optional port number, -- | An Edge has an name of the source icon, and its optional port number,
-- and the name of the destination icon, and its optional port number. -- and the name of the destination icon, and its optional port number.
data Edge = Edge { edgeOptions :: [EdgeOption] data Edge = Edge
, edgeConnection :: Connection} { edgeOptions :: [EdgeOption],
edgeConnection :: Connection
}
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
-- | A drawing is a map from names to Icons, a list of edges, -- | A drawing is a map from names to Icons, a list of edges,
@ -143,19 +151,19 @@ data Drawing = Drawing [NamedIcon] [Edge] deriving (Show, Eq)
-- unique id. -- unique id.
newtype IDState = IDState Int deriving (Eq, Show) newtype IDState = IDState Int deriving (Eq, Show)
type SpecialNum n type SpecialNum n =
= (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n) (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n)
-- Note that SpecialBackend is a constraint synonym, not a type synonym. -- Note that SpecialBackend is a constraint synonym, not a type synonym.
type SpecialBackend b n type SpecialBackend b n =
= (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b) (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b)
type SpecialQDiagram b n = QDiagram b V2 n Any type SpecialQDiagram b n = QDiagram b V2 n Any
type IngSyntaxGraph gr = gr SgNamedNode Edge type IngSyntaxGraph gr = gr SgNamedNode Edge
data EmbedDirection = data EmbedDirection
EdEmbedFrom -- The tail = EdEmbedFrom -- The tail
| EdEmbedTo -- The head | EdEmbedTo -- The head
deriving (Show, Eq) deriving (Show, Eq)
@ -165,8 +173,8 @@ data EmbedInfo a = EmbedInfo {eiEmbedDir :: Maybe EmbedDirection, eiVal :: a}
type AnnotatedGraph gr = gr (NodeInfo SgNamedNode) (EmbedInfo Edge) type AnnotatedGraph gr = gr (NodeInfo SgNamedNode) (EmbedInfo Edge)
data NodeInfo a = NodeInfo { data NodeInfo a = NodeInfo
niParent :: Maybe ING.Node { niParent :: Maybe ING.Node,
, niVal :: a niVal :: a
} }
deriving (Show, Eq, Functor, Ord) deriving (Show, Eq, Functor, Ord)

2
stack.yaml
View File

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