mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 23:17:21 +03:00
Update stackage, fix warnings and format some app files with Ormolu.
This commit is contained in:
parent
a6a9fb988c
commit
0b3efb0262
557
app/Translate.hs
557
app/Translate.hs
@ -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.State (State, evalState)
|
||||||
import Control.Monad(replicateM)
|
import Data.Either (partitionEithers)
|
||||||
import Control.Monad.State(State, evalState)
|
|
||||||
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,22 +104,22 @@ 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
|
||||||
|
( 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,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,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 ->
|
||||||
(intercalate "," (fmap prettyPrintWithoutNewlines names)
|
State IDState (SyntaxGraph, NameAndPort)
|
||||||
|
evalTypeSig names typeForNames =
|
||||||
|
makeBox
|
||||||
|
( 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
|
||||||
|
@ -1,10 +1,11 @@
|
|||||||
module TranslateCore(
|
-- This file is formatted with Ormolu
|
||||||
Reference,
|
module TranslateCore
|
||||||
SyntaxGraph(..),
|
( Reference,
|
||||||
|
SyntaxGraph (..),
|
||||||
EvalContext,
|
EvalContext,
|
||||||
GraphAndRef(..),
|
GraphAndRef (..),
|
||||||
SgSink(..),
|
SgSink (..),
|
||||||
SgBind(..),
|
SgBind (..),
|
||||||
syntaxGraphFromNodes,
|
syntaxGraphFromNodes,
|
||||||
syntaxGraphFromNodesEdges,
|
syntaxGraphFromNodesEdges,
|
||||||
bindsToSyntaxGraph,
|
bindsToSyntaxGraph,
|
||||||
@ -25,27 +26,49 @@ 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)
|
||||||
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,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."
|
||||||
|
|
||||||
@ -139,69 +167,74 @@ 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 ->
|
||||||
|
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,9 +259,10 @@ 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
|
||||||
Nothing -> newRef
|
Nothing -> newRef
|
||||||
where
|
where
|
||||||
@ -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,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 =
|
||||||
|
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)
|
||||||
|
|
||||||
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
|
||||||
|
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
|
||||||
|
)
|
||||||
|
94
app/Types.hs
94
app/Types.hs
@ -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,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)
|
||||||
|
@ -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:
|
||||||
|
Loading…
Reference in New Issue
Block a user