rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-08-17 19:00:31 +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

541
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 #-}
module Translate
( translateStringToSyntaxGraph,
translateStringToCollapsedGraphAndDecl, translateStringToCollapsedGraphAndDecl,
translateModuleToCollapsedGraphs, translateModuleToCollapsedGraphs,
customParseDecl customParseDecl,
) where )
where
import Diagrams.Prelude((<>))
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,21 +104,21 @@ 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) =
fromMaybe
( case ref of ( case ref of
Left str -> str Left str -> str
Right _ -> "" Right _ -> ""
@ -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,24 +217,28 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
asNameBinds = mapMaybe asNameBind argVals asNameBinds = mapMaybe asNameBind argVals
allBinds = nestedBinds <> asNameBinds allBinds = nestedBinds <> asNameBinds
newEMap = Map.fromList newEMap =
Map.fromList
((\(Named n _) -> (n, applyIconName)) <$> nestedArgs) ((\(Named n _) -> (n, applyIconName)) <$> nestedArgs)
<> nestedEMaps <> nestedEMaps
newGraph = SyntaxGraph newGraph =
SyntaxGraph
icons icons
[] []
nestedSinks nestedSinks
allBinds allBinds
newEMap newEMap
nestedApplyResult = (newGraph <> combinedGraph nestedApplyResult =
, nameAndPort applyIconName (resultPort pAppNode)) ( 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
@ -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 (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef pure
, Just outerName) ( GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef,
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,6 +301,7 @@ 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,8 +310,10 @@ 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
mapper gr =
if str `elem` c
then GraphAndRef mempty (Left str) then GraphAndRef mempty (Left str)
else grNamePortToGrRef gr else grNamePortToGrRef gr
@ -267,28 +321,33 @@ strToGraphRef c str = fmap mapper (makeBox str) where
-- 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 $
makeApplyGraph
(length evaluatedFunctions) (length evaluatedFunctions)
ComposeNodeFlavor ComposeNodeFlavor
False False
@ -299,8 +358,8 @@ evalFunctionComposition c functions = do
-- | 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,7 +368,8 @@ 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)
where
(e1App, e1Comp) = applyComposeScore exp1 (e1App, e1Comp) = applyComposeScore exp1
(e2App, e2Comp) = applyComposeScore exp2 (e2App, e2Comp) = applyComposeScore exp2
@ -323,8 +383,8 @@ applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
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,16 +412,18 @@ 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 _ ->
if appScore <= compScore
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr) then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr)
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr) else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr)
where where
@ -372,93 +435,104 @@ 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 _ ->
namesInPattern
-- TODO Should evalState be used here? -- TODO Should evalState be used here?
$ evalState (evalPattern pat) initialIdState $
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 in (,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
(,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 (patRhsAreConnected pure
, deleteBindings grWithEdges ( patRhsAreConnected,
, patRef deleteBindings grWithEdges,
, lookedUpRhsRef patRef,
, mPatAsName) lookedUpRhsRef,
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
resultIconNames
(GraphAndRef expGraph expRef)
evaledAlts =
result
where where
(patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts
combindedAltGraph = mconcat altGraphs combindedAltGraph = mconcat altGraphs
@ -467,8 +541,10 @@ evalCaseHelper numAlts caseIconName resultIconNames
caseGraph = syntaxGraphFromNodes icons caseGraph = syntaxGraphFromNodes icons
expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode))
patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts
rhsEdges = zip patRhsConnected $ zip rhsRefs rhsEdges =
$ map (nameAndPort caseIconName) caseRhsPorts zip patRhsConnected $
zip rhsRefs $
map (nameAndPort caseIconName) caseRhsPorts
(connectedRhss, unConnectedRhss) = partition fst rhsEdges (connectedRhss, unConnectedRhss) = partition fst rhsEdges
makeCaseResult :: NodeName -> Reference -> SyntaxGraph makeCaseResult :: NodeName -> Reference -> SyntaxGraph
@ -480,40 +556,41 @@ evalCaseHelper numAlts caseIconName resultIconNames
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,
expGraph,
caseEdgeGraph,
caseGraph,
combindedAltGraph
]
result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) 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,22 +601,21 @@ 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
@ -556,12 +632,15 @@ evalLambda _ context patterns expr = do
(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 =
mconcat $
zipWith
asBindGraphZipper asBindGraphZipper
(fmap snd patternValsWithAsNames) (fmap snd patternValsWithAsNames)
lambdaPorts lambdaPorts
combinedGraph = deleteBindings . makeEdges combinedGraph =
$ (asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph) deleteBindings . makeEdges $
(asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph)
pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode)) pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode))
where where
@ -584,18 +663,22 @@ 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)
@ -606,13 +689,17 @@ evalPatBind _ c pat e = do
-- Pretty printing the entire type sig results in extra whitespace in the middle -- Pretty printing the entire type sig results in extra whitespace in the middle
-- TODO May want to trim whitespace from (prettyPrint typeForNames) -- TODO May want to trim whitespace from (prettyPrint typeForNames)
evalTypeSig :: 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 ->
State IDState (SyntaxGraph, NameAndPort)
evalTypeSig names typeForNames =
makeBox
( intercalate "," (fmap prettyPrintWithoutNewlines names) ( intercalate "," (fmap prettyPrintWithoutNewlines names)
++ " :: " ++ " :: "
++ prettyPrintWithoutNewlines typeForNames) ++ 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,13 +718,11 @@ 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 let icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)]
icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)]
edges = [makeSimpleEdge (port, justName uniquePatName)] edges = [makeSimpleEdge (port, justName uniquePatName)]
edgeGraph = syntaxGraphFromNodesEdges icons edges edgeGraph = syntaxGraphFromNodesEdges icons edges
pure edgeGraph pure edgeGraph
@ -645,7 +730,8 @@ showTopLevelBinds gr = do
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
where
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
graph = evalState evaluatedDecl initialIdState graph = evalState evaluatedDecl initialIdState
@ -654,27 +740,32 @@ 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)
where
decl = customParseDecl s -- :: ParseResult Module decl = customParseDecl s -- :: ParseResult Module
drawing = translateDeclToCollapsedGraph decl 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
translateModuleToCollapsedGraphs moduleSyntax =
error $
"Unsupported syntax in translateModuleToCollapsedGraphs: "
<> show moduleSyntax <> show moduleSyntax
-- END Exported functions -- END Exported functions

243
app/TranslateCore.hs
View File

@ -1,5 +1,6 @@
module TranslateCore( -- This file is formatted with Ormolu
Reference, module TranslateCore
( Reference,
SyntaxGraph (..), SyntaxGraph (..),
EvalContext, EvalContext,
GraphAndRef (..), GraphAndRef (..),
@ -25,8 +26,9 @@ module TranslateCore(
nListString, nListString,
syntaxGraphToFglGraph, syntaxGraphToFglGraph,
nodeToIcon, nodeToIcon,
initialIdState initialIdState,
) where )
where
import Control.Monad.State (State, state) import Control.Monad.State (State, state)
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
@ -34,18 +36,39 @@ 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,23 +86,25 @@ 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)
@ -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,10 +152,13 @@ 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
incrementer (IDState x) = (x, IDState checkedIncrement)
where
xPlusOne = x + 1 xPlusOne = x + 1
checkedIncrement = if xPlusOne > x checkedIncrement =
if xPlusOne > x
then xPlusOne then xPlusOne
else error "getId: the ID state has overflowed." else error "getId: the ID state has overflowed."
@ -145,63 +173,68 @@ getUniqueString base = fmap ((base ++). show) getId
-- 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 ->
if inPattern
then bindsToSyntaxGraph [SgBind str (Right port)] then bindsToSyntaxGraph [SgBind str (Right port)]
else sinksToSyntaxGraph [SgSink str 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
then -- If in a pattern, then the port on the case icon is
-- the data source. -- the data source.
then (port, resPort) (port, resPort)
else (resPort, port) 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
Left str ->
if inPattern
then bindsToSyntaxGraph [SgBind str (Right port)] then bindsToSyntaxGraph [SgBind str (Right port)]
else sinksToSyntaxGraph [SgSink str port] else sinksToSyntaxGraph [SgSink str port]
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, 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,7 +259,8 @@ 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
where
lookupHelper newRef@(Right _) = newRef lookupHelper newRef@(Right _) = newRef
lookupHelper newRef@(Left s) = case lookup s (fmap sgBindToTuple bindings) of lookupHelper newRef@(Left s) = case lookup s (fmap sgBindToTuple bindings) of
Just r -> failIfCycle r $ lookupHelper r Just r -> failIfCycle r $ lookupHelper r
@ -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
where
(newSinks, newEdges) = makeEdgesCore sinks bindings (newSinks, newEdges) = makeEdgesCore sinks bindings
newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap 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,16 +301,17 @@ 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 ++ ")")
where
commas = case concatMap trueToUnderscore bools of commas = case concatMap trueToUnderscore bools of
[] -> [] [] -> []
(_ : xs) -> xs (_ : xs) -> xs
trueToUnderscore x = if x trueToUnderscore x =
if x
then ",_" then ",_"
else "," else ","
nListString :: Int -> String nListString :: Int -> String
-- TODO: Use something better than [_] -- TODO: Use something better than [_]
nListString 1 = "[_]" nListString 1 = "[_]"
@ -283,24 +319,26 @@ 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,
Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)
)
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
| otherwise = False -- This case should never happen | otherwise = False -- This case should never happen
@ -308,10 +346,11 @@ findArg currentPort
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,7 +384,8 @@ 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 =
NestedPApp
(pure (Just (Named (NodeName (-1)) (TextBoxIcon str)))) (pure (Just (Named (NodeName (-1)) (TextBoxIcon str))))
-- Why so many fmaps? -- Why so many fmaps?
((fmap . fmap . fmap . fmap) nodeToIcon children) ((fmap . fmap . fmap . fmap) nodeToIcon children)
@ -353,20 +394,28 @@ 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
where
lookupHelper name = case Map.lookup name eMap of lookupHelper name = case Map.lookup name eMap of
Nothing -> name Nothing -> name
Just parent -> if parent == origName Just parent ->
then error $ "lookupInEmbeddingMap: Found cycle. Node = " if parent == origName
++ show origName ++ "\nEmbedding Map = " ++ show eMap then
error $
"lookupInEmbeddingMap: Found cycle. Node = "
++ show origName
++ "\nEmbedding Map = "
++ show eMap
else lookupHelper parent 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
)

58
app/Types.hs
View File

@ -1,8 +1,11 @@
{-# 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 (..),
@ -30,18 +33,18 @@ module Types (
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,7 +66,8 @@ 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
@ -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,8 +109,8 @@ 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)]
@ -120,6 +125,7 @@ data SyntaxNode =
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: