mirror of
https://github.com/rgleichman/glance.git
synced 2024-11-23 08:27:18 +03:00
Cleanup and improve formatting.
This commit is contained in:
Robbie Gleichman
parent
5b8d4d598c
commit
9e7d01ab82
@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-}
|
||||
module Icons
|
||||
(
|
||||
Icon(..),
|
||||
TransformParams(..),
|
||||
TransformableDia,
|
||||
getPortAngles,
|
||||
|
||||
27
app/Main.hs
27
app/Main.hs
@ -5,14 +5,18 @@ module Main
|
||||
|
||||
import Prelude hiding (return)
|
||||
|
||||
-- Note: (#) and (&) are hidden in all Glance source files, since they would require
|
||||
-- - an special case when translating when Glance is run on its own source code.
|
||||
-- Note: (#) and (&) are hidden in all Glance source files, since they would
|
||||
-- require a special case when translating when Glance is run on its own source
|
||||
-- code.
|
||||
import qualified Diagrams.Prelude as Dia hiding ((#), (&))
|
||||
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
-- Options.Applicative does not seem to work qualified
|
||||
import Options.Applicative
|
||||
import Options.Applicative(header, progDesc, fullDesc, helper, info
|
||||
, defaultPrefs, customExecParser, help, short, switch
|
||||
, metavar, auto, argument, str, prefShowHelpOnError
|
||||
, Parser)
|
||||
|
||||
import Icons(ColorStyle(..), colorScheme, multilineComment)
|
||||
import Rendering(renderIngSyntaxGraph)
|
||||
@ -31,15 +35,22 @@ optionParser = CmdLineOptions
|
||||
<$> argument str (metavar "INPUT_FILE" Dia.<> help "Input .hs filename")
|
||||
<*> argument str (metavar "OUTPUT_FILE" Dia.<> help "Output .svg filename")
|
||||
<*> argument auto (metavar "IMAGE_WIDTH" Dia.<> help "Output image width")
|
||||
<*> switch (short 'c' Dia.<> help "Include comments between top level declarations.")
|
||||
<*> switch
|
||||
(short 'c' Dia.<> help "Include comments between top level declarations.")
|
||||
|
||||
renderFile :: CmdLineOptions -> IO ()
|
||||
renderFile (CmdLineOptions inputFilename outputFilename imageWidth includeComments) = do
|
||||
renderFile (CmdLineOptions
|
||||
inputFilename
|
||||
outputFilename
|
||||
imageWidth
|
||||
includeComments)
|
||||
= do
|
||||
putStrLn $ "Translating file " ++ inputFilename ++ " into a Glance image."
|
||||
parseResult <- Exts.parseFileWithComments
|
||||
(Exts.defaultParseMode
|
||||
{Exts.extensions = [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts],
|
||||
Exts.parseFilename = inputFilename
|
||||
(Exts.defaultParseMode {
|
||||
Exts.extensions = [Exts.EnableExtension Exts.MultiParamTypeClasses
|
||||
, Exts.EnableExtension Exts.FlexibleContexts]
|
||||
, Exts.parseFilename = inputFilename
|
||||
})
|
||||
inputFilename
|
||||
let
|
||||
|
||||
151
app/Rendering.hs
151
app/Rendering.hs
@ -6,7 +6,16 @@ module Rendering (
|
||||
renderIngSyntaxGraph
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude hiding ((#), (&))
|
||||
import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
||||
, arrowTail, noHead, arrowHead, scale, r2, bezier3
|
||||
, fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
|
||||
, TrailLike, V, height, width, (*^), reflectX, rotate
|
||||
, centerXY, place
|
||||
, roundedRect, dashingG, lwG, lightgreen, lc, centerPoint
|
||||
, moveTo, turn, (@@), unitX, signedAngleBetween, (.-.)
|
||||
, applyAll, names, angleV, rad, (^.), angleBetween, (.>)
|
||||
, connectOutside', connect', with, (%~), lengths, (^+^)
|
||||
, (.~))
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
@ -74,17 +83,29 @@ drawingToIconGraph (Drawing nodes edges) =
|
||||
++ show name ++ " Edge=" ++ show e
|
||||
|
||||
|
||||
bezierShaft :: (V t ~ V2, TrailLike t) => Angle (N t) -> Angle (N t) -> t
|
||||
bezierShaft :: (V t ~ V2, TrailLike t) =>
|
||||
Angle (N t) -> Angle (N t) -> t
|
||||
bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where
|
||||
scaleFactor = 0.5
|
||||
x = r2 (1,0)
|
||||
c1 = rotate angle1 (scale scaleFactor unitX)
|
||||
c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x
|
||||
|
||||
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption] -> (Angle n, Angle n) -> NameAndPort -> ArrowOpts n
|
||||
getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort)= arrowOptions
|
||||
getArrowOpts :: (RealFloat n, Typeable n) =>
|
||||
(EdgeEnd, EdgeEnd)
|
||||
-> [EdgeOption]
|
||||
-> (Angle n, Angle n)
|
||||
-> NameAndPort
|
||||
-> ArrowOpts n
|
||||
getArrowOpts (t, h)
|
||||
_
|
||||
(fromAngle, toAngle)
|
||||
(NameAndPort (NodeName nodeNum) mPort)
|
||||
= arrowOptions
|
||||
where
|
||||
--shaftColor = if EdgeInPattern `elem` opts then patternC colorScheme else hashedColor
|
||||
-- shaftColor = if EdgeInPattern `elem` opts
|
||||
-- then patternC colorScheme
|
||||
-- else hashedColor
|
||||
shaftColor = hashedColor
|
||||
|
||||
edgeColors = edgeListC colorScheme
|
||||
@ -108,8 +129,13 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
connectMaybePorts :: SpecialBackend b n =>
|
||||
(Angle n, Angle n)-> Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
connectMaybePorts portAngles (Edge opts ends (fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)) =
|
||||
connectFunc (getArrowOpts ends opts portAngles fromNamePort) qPort0 qPort1 where
|
||||
connectMaybePorts portAngles
|
||||
(Edge
|
||||
opts
|
||||
ends
|
||||
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2))
|
||||
= connectFunc (getArrowOpts ends opts portAngles fromNamePort) qPort0 qPort1
|
||||
where
|
||||
(connectFunc, qPort0, qPort1) = case (mPort1, mPort2) of
|
||||
(Just port0, Just port1) -> (connect', name0 .> port0, name1 .> port1)
|
||||
(Nothing, Just port1) -> (connectOutside', toName name0, name1 .> port1)
|
||||
@ -123,15 +149,23 @@ nameAndPortToName (NameAndPort name mPort) = case mPort of
|
||||
Just port -> name .> port
|
||||
|
||||
findPortAngles :: SpecialNum n => NamedIcon -> NameAndPort -> [Angle n]
|
||||
findPortAngles (NamedIcon nodeName nodeIcon) (NameAndPort diaName mPort) = case mPort of
|
||||
findPortAngles (NamedIcon nodeName nodeIcon) (NameAndPort diaName mPort)
|
||||
= case mPort of
|
||||
Nothing -> []
|
||||
Just port -> foundAngles where
|
||||
mName = if nodeName == diaName then Nothing else Just diaName
|
||||
foundAngles = getPortAngles nodeIcon port mName
|
||||
|
||||
-- TODO Clean up the Angle arithmatic
|
||||
pickClosestAngle :: SpecialNum n => (Bool, Angle n) -> Angle n -> Angle n -> Angle n -> [Angle n] -> Angle n
|
||||
pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles = case angles of
|
||||
pickClosestAngle :: SpecialNum n =>
|
||||
(Bool, Angle n)
|
||||
-> Angle n
|
||||
-> Angle n
|
||||
-> Angle n
|
||||
-> [Angle n]
|
||||
-> Angle n
|
||||
pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles
|
||||
= case angles of
|
||||
[] -> emptyCase
|
||||
_ -> (-) <$>
|
||||
fst (minimumBy (compare `on` snd) $ fmap angleDiff adjustedAngles)
|
||||
@ -141,13 +175,16 @@ pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles = case
|
||||
adjustedAngles = fmap adjustAngle angles
|
||||
angleDiff angle = (angle, angleBetween (angleV target) (angleV angle))
|
||||
|
||||
adjustAngle angle = if nodeFlip then
|
||||
signedAngleBetween (rotate nodeAngle $ reflectX (angleV angle)) unitX
|
||||
else
|
||||
(+) <$> angle <*> nodeAngle
|
||||
adjustAngle angle = if nodeFlip
|
||||
then signedAngleBetween
|
||||
(rotate nodeAngle $ reflectX (angleV angle))
|
||||
unitX
|
||||
else (+) <$> angle <*> nodeAngle
|
||||
|
||||
|
||||
-- TODO Refactor with pickClosestAngle
|
||||
smallestAngleDiff :: SpecialNum n => (Bool, Angle n) -> Angle n -> [Angle n] -> n
|
||||
smallestAngleDiff :: SpecialNum n =>
|
||||
(Bool, Angle n) -> Angle n -> [Angle n] -> n
|
||||
smallestAngleDiff (nodeFlip, nodeAngle) target angles = case angles of
|
||||
[] -> 0
|
||||
_ -> minimum $ fmap angleDiff adjustedAngles
|
||||
@ -161,21 +198,31 @@ smallestAngleDiff (nodeFlip, nodeAngle) target angles = case angles of
|
||||
(+) <$> angle <*> nodeAngle
|
||||
|
||||
|
||||
lookupNodeAngle :: Show n => [(NamedIcon, (Bool, Angle n))] -> NamedIcon -> (Bool, Angle n)
|
||||
lookupNodeAngle rotationMap key =
|
||||
fromMaybeError ("nodeVector: key not in rotaionMap. key = " ++ show key ++ "\n\n rotationMap = " ++ show rotationMap)
|
||||
lookupNodeAngle :: Show n =>
|
||||
[(NamedIcon, (Bool, Angle n))] -> NamedIcon -> (Bool, Angle n)
|
||||
lookupNodeAngle rotationMap key
|
||||
= fromMaybeError
|
||||
("nodeVector: key not in rotaionMap. key = " ++ show key
|
||||
++ "\n\n rotationMap = " ++ show rotationMap)
|
||||
$ lookup key rotationMap
|
||||
|
||||
makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr NamedIcon Edge -> SpecialQDiagram b n -> [(NamedIcon, (Bool, Angle n))] ->
|
||||
ING.LEdge Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePort1))) =
|
||||
connectMaybePorts portAngles edge
|
||||
gr NamedIcon Edge
|
||||
-> SpecialQDiagram b n
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
-> ING.LEdge Edge
|
||||
-> SpecialQDiagram b n
|
||||
-> SpecialQDiagram b n
|
||||
makeEdge graph dia rotationMap
|
||||
(node0, node1, edge@(Edge _ _ (namePort0, namePort1)))
|
||||
= connectMaybePorts portAngles edge
|
||||
where
|
||||
node0label = fromMaybeError ("makeEdge: node0 is not in graph. node0: " ++ show node0) $
|
||||
ING.lab graph node0
|
||||
node1label = fromMaybeError ("makeEdge: node1 is not in graph. node1: " ++ show node1) $
|
||||
ING.lab graph node1
|
||||
node0label = fromMaybeError
|
||||
("makeEdge: node0 is not in graph. node0: " ++ show node0)
|
||||
$ ING.lab graph node0
|
||||
node1label = fromMaybeError
|
||||
("makeEdge: node1 is not in graph. node1: " ++ show node1)
|
||||
$ ING.lab graph node1
|
||||
|
||||
node0Angle = lookupNodeAngle rotationMap node0label
|
||||
node1Angle = lookupNodeAngle rotationMap node1label
|
||||
@ -186,13 +233,20 @@ makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePor
|
||||
shaftVector = port1Point .-. port0Point
|
||||
shaftAngle = signedAngleBetween shaftVector unitX
|
||||
|
||||
icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle $ findPortAngles node0label namePort0
|
||||
icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle
|
||||
$ findPortAngles node0label namePort0
|
||||
|
||||
shaftAnglePlusOneHalf = (+) <$> shaftAngle <*> (1/2 @@ turn)
|
||||
icon1PortAngle = pickClosestAngle node1Angle (1/2 @@ turn) shaftAnglePlusOneHalf shaftAngle $ findPortAngles node1label namePort1
|
||||
icon1PortAngle = pickClosestAngle
|
||||
node1Angle
|
||||
(1/2 @@ turn)
|
||||
shaftAnglePlusOneHalf
|
||||
shaftAngle
|
||||
(findPortAngles node1label namePort1)
|
||||
|
||||
getPortPoint n = head $ fromMaybeError
|
||||
("makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: " ++ show diaNodeNamePointMap)
|
||||
("makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: "
|
||||
++ show diaNodeNamePointMap)
|
||||
(lookup n diaNodeNamePointMap)
|
||||
|
||||
portAngles = (icon0PortAngle, icon1PortAngle)
|
||||
@ -207,9 +261,6 @@ addEdges graph dia rotationMap = applyAll connections dia
|
||||
where
|
||||
connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
|
||||
|
||||
--printSelf :: (Show a) => a -> a
|
||||
--printSelf a = Debug.Trace.trace (show a ++ "/n") a
|
||||
|
||||
-- BEGIN rotateNodes --
|
||||
|
||||
-- TODO May want to use a power other than 2 for the edgeAngleDiffs
|
||||
@ -219,8 +270,11 @@ scoreAngle :: SpecialNum n =>
|
||||
-> Bool
|
||||
-> Angle n
|
||||
-> n
|
||||
scoreAngle iconPosition edges reflected angle = sum $ (^(2 :: Int)) <$> fmap edgeAngleDiff edges where
|
||||
edgeAngleDiff (otherNodePosition, portAngles) = angleDiff where
|
||||
scoreAngle iconPosition edges reflected angle
|
||||
= sum $ (^(2 :: Int)) <$> fmap edgeAngleDiff edges
|
||||
where
|
||||
edgeAngleDiff (otherNodePosition, portAngles) = angleDiff
|
||||
where
|
||||
shaftVector = otherNodePosition .-. iconPosition
|
||||
shaftAngle = signedAngleBetween shaftVector unitX
|
||||
angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles
|
||||
@ -231,16 +285,26 @@ bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
|
||||
-> NamedIcon
|
||||
-> Bool
|
||||
-> (Angle n, n)
|
||||
bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected =
|
||||
minimumBy (compare `on` snd) $ (\angle -> (angle, scoreAngle iconPosition edges reflected angle)) <$> fmap (@@ turn) possibleAngles
|
||||
bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
= minimumBy (compare `on` snd)
|
||||
( (\angle -> (angle
|
||||
, scoreAngle iconPosition edges reflected angle))
|
||||
<$> fmap (@@ turn) possibleAngles)
|
||||
where
|
||||
possibleAngles = [0,(1/24)..1]
|
||||
-- possibleAngles = [0, 1/2] -- (uncomment this line and comment out the line above to disable rotation)
|
||||
iconPosition = positionMap Map.! key
|
||||
edges = getPositionAndAngles <$> fmap getSucEdge (ING.lsuc graph nodeId) <> fmap getPreEdge (ING.lpre graph nodeId)
|
||||
edges = getPositionAndAngles
|
||||
<$> ( fmap getSucEdge (ING.lsuc graph nodeId)
|
||||
<> fmap getPreEdge (ING.lpre graph nodeId))
|
||||
|
||||
getPositionAndAngles (node, nameAndPort) = (positionMap Map.! nodeLabel, portAngles) where
|
||||
nodeLabel = fromMaybeError "getPositionAndAngles: node not found" $ ING.lab graph node
|
||||
|
||||
getPositionAndAngles (node, nameAndPort)
|
||||
= (positionMap Map.! nodeLabel, portAngles)
|
||||
where
|
||||
nodeLabel = fromMaybeError
|
||||
"getPositionAndAngles: node not found"
|
||||
(ING.lab graph node)
|
||||
portAngles = findPortAngles key nameAndPort
|
||||
|
||||
-- Edge points from id to otherNode
|
||||
@ -259,7 +323,8 @@ findIconRotation :: (SpecialNum n, ING.Graph gr) =>
|
||||
findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
-- Smaller scores are better
|
||||
(reflectedAngle, reflectedScore) = bestAngleForIcon positionMap graph key True
|
||||
(nonReflectedAngle, nonReflectedScore) = bestAngleForIcon positionMap graph key False
|
||||
(nonReflectedAngle, nonReflectedScore)
|
||||
= bestAngleForIcon positionMap graph key False
|
||||
reflected = reflectedScore < nonReflectedScore
|
||||
angle = if reflected then reflectedAngle else nonReflectedAngle
|
||||
|
||||
@ -267,7 +332,8 @@ rotateNodes :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
rotateNodes positionMap graph = findIconRotation positionMap graph <$> Map.keys positionMap
|
||||
rotateNodes positionMap graph
|
||||
= findIconRotation positionMap graph <$> Map.keys positionMap
|
||||
|
||||
-- END rotateNodes --
|
||||
|
||||
@ -387,7 +453,8 @@ renderDrawing = renderIconGraph . drawingToIconGraph
|
||||
renderIngSyntaxGraph ::
|
||||
SpecialBackend b Double =>
|
||||
Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph = renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
|
||||
renderIngSyntaxGraph
|
||||
= renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
|
||||
|
||||
renderIconGraph :: SpecialBackend b Double
|
||||
=> Gr NamedIcon Edge -> IO (SpecialQDiagram b Double)
|
||||
|
||||
307
app/Translate.hs
307
app/Translate.hs
@ -16,17 +16,20 @@ import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
||||
import Language.Haskell.Exts(
|
||||
Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
||||
Exp(..), QName(..), fromParseResult, Match(..), QOp(..), GuardedRhs(..),
|
||||
Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint)
|
||||
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..), SgBind(..),
|
||||
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions,
|
||||
edgesForRefPortList, makeApplyGraph, makeGuardGraph,
|
||||
import TranslateCore(
|
||||
Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..),
|
||||
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName,
|
||||
edgesForRefPortList, makeApplyGraph, makeGuardGraph, combineExpressions,
|
||||
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
||||
makeBox, nTupleString, nTupleSectionString, nListString,
|
||||
syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, graphAndRefToGraph,
|
||||
syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph,
|
||||
SgBind(..), graphAndRefToGraph,
|
||||
initialIdState)
|
||||
import Types(Labeled(..), NameAndPort(..), IDState,
|
||||
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
||||
@ -54,9 +57,12 @@ qOpToExp :: QOp l -> Exp l
|
||||
qOpToExp (QVarOp l n) = Var l n
|
||||
qOpToExp (QConOp l n) = Con l n
|
||||
|
||||
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names.
|
||||
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
|
||||
-- names.
|
||||
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
||||
makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where
|
||||
makeAsBindGraph ref asNames
|
||||
= bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames
|
||||
where
|
||||
makeBind mName = case mName of
|
||||
Nothing -> Nothing
|
||||
Just asName -> Just $ SgBind asName ref
|
||||
@ -64,8 +70,12 @@ makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asN
|
||||
grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef
|
||||
grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np)
|
||||
|
||||
bindOrAltHelper ::
|
||||
Show l => EvalContext -> Pat l -> Rhs l -> Maybe (Binds l) -> State IDState ((GraphAndRef, Maybe String), GraphAndRef)
|
||||
bindOrAltHelper :: Show l =>
|
||||
EvalContext
|
||||
-> Pat l
|
||||
-> Rhs l
|
||||
-> Maybe (Binds l)
|
||||
-> State IDState ((GraphAndRef, Maybe String), GraphAndRef)
|
||||
bindOrAltHelper c pat rhs maybeWhereBinds = do
|
||||
patGraphAndRef <- evalPattern pat
|
||||
let
|
||||
@ -90,7 +100,8 @@ nameToString (Ident _ s) = s
|
||||
nameToString (Symbol _ s) = s
|
||||
|
||||
qNameToString :: Show l => QName l -> String
|
||||
qNameToString (Qual _ (Exts.ModuleName _ modName) name) = modName ++ "." ++ nameToString name
|
||||
qNameToString (Qual _ (Exts.ModuleName _ modName) name)
|
||||
= modName ++ "." ++ nameToString name
|
||||
qNameToString (UnQual _ name) = nameToString name
|
||||
qNameToString (Special _ (UnitCon _)) = "()"
|
||||
qNameToString (Special _ (ListCon _)) = "[]"
|
||||
@ -105,7 +116,8 @@ qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q
|
||||
|
||||
-- BEGIN evalLit
|
||||
|
||||
-- This is in Translate and not Translate core since currently it is only used by evalLit.
|
||||
-- This is in Translate and not Translate core since currently it is only used
|
||||
-- by evalLit.
|
||||
makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort)
|
||||
makeLiteral = makeBox . show
|
||||
|
||||
@ -133,8 +145,11 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of
|
||||
Nothing -> Nothing
|
||||
Just asName -> Just $ SgBind asName ref
|
||||
|
||||
patternArgumentMapper :: ((GraphAndRef, Maybe String), t) -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
|
||||
patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherVal)
|
||||
patternArgumentMapper ::
|
||||
((GraphAndRef, Maybe String), t)
|
||||
-> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
|
||||
patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port)
|
||||
= (patName, eitherVal)
|
||||
where
|
||||
graph = graphAndRefToGraph graphAndRef
|
||||
patName = patternName asGraphAndRef
|
||||
@ -144,24 +159,36 @@ patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherV
|
||||
_ -> Left (graphAndRef, port)
|
||||
|
||||
|
||||
graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||
graphToTuple ::
|
||||
SyntaxGraph
|
||||
-> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||
graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
|
||||
|
||||
graphsToComponents :: [SyntaxGraph] -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||
graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) where
|
||||
graphsToComponents ::
|
||||
[SyntaxGraph]
|
||||
-> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||
graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e)
|
||||
where
|
||||
(a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs
|
||||
|
||||
makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort)
|
||||
makeNestedPatternGraph ::
|
||||
NodeName
|
||||
-> String
|
||||
-> [(GraphAndRef, Maybe String)]
|
||||
-> (SyntaxGraph, NameAndPort)
|
||||
makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
||||
where
|
||||
dummyNode = NestedPatternApplyNode "" []
|
||||
|
||||
argsAndPorts = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
|
||||
argsAndPorts
|
||||
= zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
|
||||
mappedArgs = fmap patternArgumentMapper argsAndPorts
|
||||
|
||||
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers (fmap snd mappedArgs)
|
||||
(unnestedArgsAndPort, nestedNamedNodesAndGraphs)
|
||||
= partitionEithers (fmap snd mappedArgs)
|
||||
|
||||
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
|
||||
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps)
|
||||
= graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
|
||||
|
||||
argListMapper (str, arg) = case arg of
|
||||
Left _ -> Labeled Nothing str
|
||||
@ -177,23 +204,18 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
||||
asNameBinds = catMaybes $ fmap asNameBind argVals
|
||||
allBinds = nestedBinds <> asNameBinds
|
||||
|
||||
newEMap = ((\(SgNamedNode n _) -> (n, applyIconName)) <$> nestedArgs) <> nestedEMaps
|
||||
newEMap = ((\(SgNamedNode n _) -> (n, applyIconName)) <$> nestedArgs)
|
||||
<> nestedEMaps
|
||||
|
||||
newGraph = SyntaxGraph icons [] nestedSinks allBinds newEMap
|
||||
nestedApplyResult = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort pAppNode))
|
||||
nestedApplyResult = (newGraph <> combinedGraph
|
||||
, nameAndPort applyIconName (resultPort pAppNode))
|
||||
|
||||
-- TODO Delete makePatternGraph'
|
||||
-- makePatternGraph' :: NodeName -> String -> [GraphAndRef] -> (SyntaxGraph, NameAndPort)
|
||||
-- makePatternGraph' applyIconName funStr argVals = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort pAppNode))
|
||||
-- where
|
||||
-- pAppNode = PatternApplyNode funStr numArgs
|
||||
-- argumentNamePorts = map (nameAndPort applyIconName) $ argumentPorts pAppNode
|
||||
-- combinedGraph = combineExpressions True $ zip argVals argumentNamePorts
|
||||
-- numArgs = length argVals
|
||||
-- icons = [SgNamedNode applyIconName pAppNode]
|
||||
-- newGraph = syntaxGraphFromNodes icons
|
||||
|
||||
evalPApp :: Show l => QName l -> [Pat l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalPApp :: Show l =>
|
||||
QName l
|
||||
-> [Pat l]
|
||||
-> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalPApp name patterns = case patterns of
|
||||
[] -> makeBox constructorName
|
||||
_ -> do
|
||||
@ -219,22 +241,27 @@ showLiteral (Exts.PrimDouble _ x _) = show x
|
||||
showLiteral (Exts.PrimChar _ x _) = show x
|
||||
showLiteral (Exts.PrimString _ x _) = show x
|
||||
|
||||
evalPLit :: Exts.Sign l -> Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalPLit ::
|
||||
Exts.Sign l -> Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalPLit sign l = case sign of
|
||||
Exts.Signless _ -> evalLit l
|
||||
Exts.Negative _ -> makeBox ('-' : showLiteral l)
|
||||
-- END evalPLit
|
||||
|
||||
evalPAsPat :: Show l => Name l -> Pat l -> State IDState (GraphAndRef, Maybe String)
|
||||
evalPAsPat :: Show l =>
|
||||
Name l -> Pat l -> State IDState (GraphAndRef, Maybe String)
|
||||
evalPAsPat n p = do
|
||||
(GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p
|
||||
let
|
||||
outerName = nameToString n
|
||||
asBindGraph = makeAsBindGraph (Left outerName) [mInnerName]
|
||||
pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef, Just outerName)
|
||||
pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef
|
||||
, Just outerName)
|
||||
|
||||
makePatternResult :: Functor f => f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String)
|
||||
makePatternResult = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
|
||||
makePatternResult :: Functor f =>
|
||||
f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String)
|
||||
makePatternResult
|
||||
= fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
|
||||
|
||||
evalPattern :: Show l => Pat l -> State IDState (GraphAndRef, Maybe String)
|
||||
evalPattern p = case p of
|
||||
@ -244,9 +271,13 @@ evalPattern p = case p of
|
||||
PApp _ name patterns -> makePatternResult $ evalPApp name patterns
|
||||
-- TODO special tuple handling.
|
||||
PTuple l _ patterns ->
|
||||
makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nTupleString . length $ patterns) patterns
|
||||
makePatternResult $ evalPApp
|
||||
(Exts.UnQual l . Ident l . nTupleString . length $ patterns)
|
||||
patterns
|
||||
PList l patterns ->
|
||||
makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nListString . length $ patterns) patterns
|
||||
makePatternResult $ evalPApp
|
||||
(Exts.UnQual l . Ident l . nListString . length $ patterns)
|
||||
patterns
|
||||
PParen _ pat -> evalPattern pat
|
||||
PAsPat _ n subPat -> evalPAsPat n subPat
|
||||
PWildCard _ -> makePatternResult $ makeBox "_"
|
||||
@ -275,7 +306,7 @@ evalQName qName c = case qName of
|
||||
|
||||
-- END evalQName
|
||||
|
||||
|
||||
-- TODO Delete these commented out functions.
|
||||
-- evalQOp :: QOp l -> EvalContext -> State IDState GraphAndRef
|
||||
-- evalQOp (QVarOp n) = evalQName n
|
||||
-- evalQOp (QConOp n) = evalQName n
|
||||
@ -297,41 +328,55 @@ removeParen e = case e of
|
||||
Paren _ x -> removeParen x
|
||||
_ -> e
|
||||
|
||||
evalFunExpAndArgs :: Show l => EvalContext -> LikeApplyFlavor -> (Exp l, [Exp l]) -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalFunExpAndArgs :: Show l =>
|
||||
EvalContext
|
||||
-> LikeApplyFlavor
|
||||
-> (Exp l, [Exp l])
|
||||
-> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalFunExpAndArgs c flavor (funExp, argExps) = do
|
||||
funVal <- evalExp c funExp
|
||||
argVals <- mapM (evalExp c) argExps
|
||||
applyIconName <- getUniqueName
|
||||
pure $ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals
|
||||
pure
|
||||
$ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals
|
||||
|
||||
-- END apply and compose helper functions
|
||||
|
||||
-- BEGIN evalInfixApp
|
||||
|
||||
evalFunctionComposition :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalFunctionComposition :: Show l =>
|
||||
EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalFunctionComposition c functions = do
|
||||
let reversedFunctios = reverse functions
|
||||
evaluatedFunctions <- mapM (evalExp c) reversedFunctios
|
||||
neverUsedPort <- Left <$> getUniqueString "unusedArgument"
|
||||
applyIconName <- getUniqueName
|
||||
pure $ makeApplyGraph (length evaluatedFunctions) ComposeNodeFlavor False applyIconName
|
||||
(GraphAndRef mempty neverUsedPort) evaluatedFunctions
|
||||
pure $ makeApplyGraph
|
||||
(length evaluatedFunctions)
|
||||
ComposeNodeFlavor
|
||||
False
|
||||
applyIconName
|
||||
(GraphAndRef mempty neverUsedPort)
|
||||
evaluatedFunctions
|
||||
|
||||
-- | Turn (a . b . c) into [a, b, c]
|
||||
compositionToList :: Exp l -> [Exp l]
|
||||
compositionToList e = case removeParen e of
|
||||
(InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2) -> exp1 : compositionToList exp2
|
||||
(InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2)
|
||||
-> exp1 : compositionToList exp2
|
||||
x -> [x]
|
||||
|
||||
-- | In the general case, infix is converted to prefix.
|
||||
-- Special cases:
|
||||
-- a $ b is converted to (a b)
|
||||
-- (a . b . c) uses the compose apply icon with no argument
|
||||
evalInfixApp :: Show l => l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef
|
||||
evalInfixApp :: Show l =>
|
||||
l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef
|
||||
evalInfixApp l c e1 op e2 = case op of
|
||||
QVarOp _ (UnQual _ (Symbol _ sym)) -> case sym of
|
||||
"$" -> evalExp c (App l e1 e2)
|
||||
"." -> grNamePortToGrRef <$> evalFunctionComposition c (e1 : compositionToList e2)
|
||||
"." -> grNamePortToGrRef
|
||||
<$> evalFunctionComposition c (e1 : compositionToList e2)
|
||||
_ -> defaultCase
|
||||
_ -> defaultCase
|
||||
where
|
||||
@ -346,7 +391,8 @@ simplifyExp e = case removeParen e of
|
||||
InfixApp l exp1 (QVarOp _ (UnQual _ (Symbol _ "$"))) exp2 -> App l exp1 exp2
|
||||
-- Don't convert compose to apply
|
||||
InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "."))) _ -> e
|
||||
App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg -> App l (makeVarExp l "fmap") arg
|
||||
App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg
|
||||
-> App l (makeVarExp l "fmap") arg
|
||||
InfixApp l exp1 op exp2 -> App l (App l (qOpToExp op) exp1) exp2
|
||||
LeftSection l exp1 op -> App l (qOpToExp op) exp1
|
||||
x -> x
|
||||
@ -370,7 +416,8 @@ applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
|
||||
compScore = max leftComp rightComp
|
||||
|
||||
-- TODO Consider putting this logic in a separate "simplifyExpression" function.
|
||||
-- | Returns the amount of nesting if the App is converted to (applyNode, composeNode)
|
||||
-- | Returns the amount of nesting if the App is converted to
|
||||
-- (applyNode, composeNode)
|
||||
applyComposeScore :: Exp l -> (Int, Int)
|
||||
applyComposeScore e = case simplifyExp e of
|
||||
App _ exp1 exp2 -> applyComposeScoreHelper exp1 exp2
|
||||
@ -397,11 +444,13 @@ appExpToArgFuncs e = case simplifyExp e of
|
||||
|
||||
removeCompose :: l -> Exp l -> Exp l -> Exp l
|
||||
removeCompose l f x = case removeParen f of
|
||||
(InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2) -> App l f1 $ removeCompose l f2 x
|
||||
(InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2)
|
||||
-> App l f1 $ removeCompose l f2 x
|
||||
_ -> App l f x
|
||||
|
||||
-- TODO Refactor this and all sub-expressions
|
||||
evalApp :: Show l => l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalApp :: Show l =>
|
||||
l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalApp l c f e = if appScore <= compScore
|
||||
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs noComposeExp)
|
||||
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs noComposeExp)
|
||||
@ -411,7 +460,12 @@ evalApp l c f e = if appScore <= compScore
|
||||
|
||||
-- END evaluateAppExpression
|
||||
|
||||
evalIf :: Show l => EvalContext -> Exp l -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalIf :: Show l =>
|
||||
EvalContext
|
||||
-> Exp l
|
||||
-> Exp l
|
||||
-> Exp l
|
||||
-> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalIf c boolExp trueExp falseExp = makeGuardGraph 2
|
||||
<$>
|
||||
getUniqueName
|
||||
@ -425,13 +479,16 @@ evalIf c boolExp trueExp falseExp = makeGuardGraph 2
|
||||
|
||||
getBoundVarName :: Show l => Decl l -> [String]
|
||||
-- TODO Should evalState be used here?
|
||||
getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState
|
||||
getBoundVarName (PatBind _ pat _ _)
|
||||
= namesInPattern $ evalState (evalPattern pat) initialIdState
|
||||
getBoundVarName (FunBind _ (Match _ name _ _ _:_)) = [nameToString name]
|
||||
-- TODO: Other cases
|
||||
getBoundVarName (TypeSig _ _ _) = []
|
||||
getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl
|
||||
getBoundVarName decl
|
||||
= error $ "getBoundVarName: No pattern in case for " ++ show decl
|
||||
|
||||
evalBinds :: Show l => EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext)
|
||||
evalBinds :: Show l =>
|
||||
EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext)
|
||||
evalBinds c (BDecls _ decls) =
|
||||
let
|
||||
boundNames = concatMap getBoundVarName decls
|
||||
@ -440,7 +497,11 @@ evalBinds c (BDecls _ decls) =
|
||||
((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls
|
||||
evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds
|
||||
|
||||
evalGeneralLet :: Show l => (EvalContext -> State IDState GraphAndRef) -> EvalContext -> Binds l-> State IDState GraphAndRef
|
||||
evalGeneralLet :: Show l =>
|
||||
(EvalContext -> State IDState GraphAndRef)
|
||||
-> EvalContext
|
||||
-> Binds l
|
||||
-> State IDState GraphAndRef
|
||||
evalGeneralLet expOrRhsEvaler c bs = do
|
||||
(bindGraph, bindContext) <- evalBinds c bs
|
||||
expVal <- expOrRhsEvaler bindContext
|
||||
@ -465,10 +526,13 @@ evalStmts :: Show l => EvalContext -> [Stmt l] -> State IDState GraphAndRef
|
||||
evalStmts c [stmt] = evalStmt c stmt
|
||||
evalStmts _ stmts = error $ "Unsupported syntax in evalStmts: " <> show stmts
|
||||
|
||||
evalGuardedRhs :: Show l => EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef)
|
||||
evalGuardedRhs c (GuardedRhs _ stmts e) = (,) <$> evalStmts c stmts <*> evalExp c e
|
||||
evalGuardedRhs :: Show l =>
|
||||
EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef)
|
||||
evalGuardedRhs c (GuardedRhs _ stmts e)
|
||||
= (,) <$> evalStmts c stmts <*> evalExp c e
|
||||
|
||||
evalGuardedRhss :: Show l => EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalGuardedRhss :: Show l =>
|
||||
EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalGuardedRhss c rhss = let
|
||||
evaledRhss = unzip <$> mapM (evalGuardedRhs c) rhss
|
||||
in
|
||||
@ -486,7 +550,8 @@ evalRhs :: Show l => EvalContext -> Rhs l -> State IDState GraphAndRef
|
||||
evalRhs c (UnGuardedRhs _ e) = evalExp c e
|
||||
evalRhs c (GuardedRhss _ rhss) = grNamePortToGrRef <$> evalGuardedRhss c rhss
|
||||
|
||||
rhsWithBinds :: Show l => Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef
|
||||
rhsWithBinds :: Show l =>
|
||||
Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef
|
||||
rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
|
||||
Nothing -> evalRhs rhsContext rhs
|
||||
Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b
|
||||
@ -495,22 +560,38 @@ rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
|
||||
|
||||
-- BEGIN evalCase
|
||||
|
||||
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a name
|
||||
evalPatAndRhs :: Show l => EvalContext -> Pat l-> Rhs l -> Maybe (Binds l) -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a
|
||||
-- name
|
||||
evalPatAndRhs :: Show l =>
|
||||
EvalContext
|
||||
-> Pat l
|
||||
-> Rhs l
|
||||
-> Maybe (Binds l)
|
||||
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
evalPatAndRhs c pat rhs maybeWhereBinds = do
|
||||
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
|
||||
bindOrAltHelper c pat rhs maybeWhereBinds
|
||||
let
|
||||
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
||||
lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef
|
||||
-- The pattern and rhs are conneted if makeEdges added extra edges, or if the rhsRef refers to a source
|
||||
-- in the pattern
|
||||
patRhsAreConnected = (rhsRef /= lookedUpRhsRef) ||
|
||||
length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph))
|
||||
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef, mPatAsName)
|
||||
-- The pattern and rhs are conneted if makeEdges added extra edges, or if
|
||||
-- the rhsRef refers to a source in the pattern.
|
||||
patRhsAreConnected
|
||||
= (rhsRef /= lookedUpRhsRef)
|
||||
|| ( length (sgEdges grWithEdges)
|
||||
>
|
||||
(length (sgEdges rhsGraph) + length (sgEdges patGraph)))
|
||||
pure (patRhsAreConnected
|
||||
, deleteBindings grWithEdges
|
||||
, patRef
|
||||
, lookedUpRhsRef
|
||||
, mPatAsName)
|
||||
|
||||
-- returns (combined graph, pattern reference, rhs reference)
|
||||
evalAlt :: Show l => EvalContext -> Exts.Alt l -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
evalAlt :: Show l =>
|
||||
EvalContext
|
||||
-> Exts.Alt l
|
||||
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
|
||||
|
||||
evalCaseHelper ::
|
||||
@ -520,7 +601,10 @@ evalCaseHelper ::
|
||||
-> GraphAndRef
|
||||
-> [(Bool, SyntaxGraph, Reference, Reference, Maybe String)]
|
||||
-> (SyntaxGraph, NameAndPort)
|
||||
evalCaseHelper numAlts caseIconName resultIconNames (GraphAndRef expGraph expRef) evaledAlts = result where
|
||||
evalCaseHelper numAlts caseIconName resultIconNames
|
||||
(GraphAndRef expGraph expRef) evaledAlts
|
||||
= result
|
||||
where
|
||||
(patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts
|
||||
combindedAltGraph = mconcat altGraphs
|
||||
caseNode = CaseNode numAlts
|
||||
@ -528,7 +612,8 @@ evalCaseHelper numAlts caseIconName resultIconNames (GraphAndRef expGraph expRef
|
||||
caseGraph = syntaxGraphFromNodes icons
|
||||
expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode))
|
||||
patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts
|
||||
rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName) caseRhsPorts
|
||||
rhsEdges = zip patRhsConnected $ zip rhsRefs
|
||||
$ map (nameAndPort caseIconName) caseRhsPorts
|
||||
(connectedRhss, unConnectedRhss) = partition fst rhsEdges
|
||||
|
||||
makeCaseResult :: NodeName -> Reference -> SyntaxGraph
|
||||
@ -539,18 +624,27 @@ evalCaseHelper numAlts caseIconName resultIconNames (GraphAndRef expGraph expRef
|
||||
rhsNewIcons = [SgNamedNode resultIconName CaseResultNode]
|
||||
rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)]
|
||||
|
||||
caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
|
||||
caseResultGraphs =
|
||||
mconcat
|
||||
$ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
|
||||
filteredRhsEdges = fmap snd unConnectedRhss
|
||||
patternEdgesGraph = edgesForRefPortList True patEdges
|
||||
caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges)
|
||||
|
||||
bindGraph = makeAsBindGraph expRef asNames
|
||||
|
||||
finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph, patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
||||
finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph
|
||||
, patternEdgesGraph
|
||||
, caseResultGraphs
|
||||
, expGraph
|
||||
, caseEdgeGraph
|
||||
, caseGraph
|
||||
, combindedAltGraph]
|
||||
result = (finalGraph, nameAndPort caseIconName (resultPort caseNode))
|
||||
|
||||
|
||||
evalCase :: Show l => EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalCase :: Show l =>
|
||||
EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalCase c e alts =
|
||||
let
|
||||
numAlts = length alts
|
||||
@ -567,7 +661,8 @@ evalCase c e alts =
|
||||
|
||||
-- END evalCase
|
||||
|
||||
evalTuple :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalTuple :: Show l =>
|
||||
EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalTuple c exps =
|
||||
let
|
||||
numExps = length exps
|
||||
@ -580,7 +675,8 @@ evalTuple c exps =
|
||||
<*>
|
||||
mapM (evalExp c) exps
|
||||
|
||||
evalTupleSection :: Show l => EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalTupleSection :: Show l =>
|
||||
EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalTupleSection c mExps =
|
||||
let
|
||||
exps = catMaybes mExps
|
||||
@ -594,14 +690,20 @@ evalTupleSection c mExps =
|
||||
<*>
|
||||
mapM (evalExp c) exps
|
||||
|
||||
evalListExp :: Show l => l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalListExp :: Show l =>
|
||||
l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalListExp _ _ [] = makeBox "[]"
|
||||
evalListExp l c exps = evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l . nListString . length $ exps, exps)
|
||||
evalListExp l c exps = evalFunExpAndArgs
|
||||
c
|
||||
ApplyNodeFlavor
|
||||
(makeVarExp l . nListString . length $ exps, exps)
|
||||
|
||||
evalLeftSection :: Show l => l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef
|
||||
evalLeftSection :: Show l =>
|
||||
l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef
|
||||
evalLeftSection l c e op = evalExp c $ App l (qOpToExp op) e
|
||||
|
||||
evalRightSection :: Show l => EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalRightSection :: Show l =>
|
||||
EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalRightSection c op e =
|
||||
makeApplyGraph 2 ApplyNodeFlavor False
|
||||
<$>
|
||||
@ -610,15 +712,19 @@ evalRightSection c op e =
|
||||
evalExp c (qOpToExp op)
|
||||
<*>
|
||||
((\x y -> [x, y]) <$>
|
||||
-- TODO: A better option would be for makeApplyGraph to take the list of expressions as Maybes.
|
||||
-- TODO: A better option would be for makeApplyGraph to take the list of
|
||||
-- expressions as Maybes.
|
||||
fmap (GraphAndRef mempty . Left) (getUniqueString "unusedArgument")
|
||||
<*>
|
||||
evalExp c e
|
||||
)
|
||||
|
||||
-- evalEnums is only used by evalExp
|
||||
evalEnums :: Show l => l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef
|
||||
evalEnums l c s exps = grNamePortToGrRef <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps)
|
||||
evalEnums :: Show l =>
|
||||
l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef
|
||||
evalEnums l c s exps
|
||||
= grNamePortToGrRef
|
||||
<$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps)
|
||||
|
||||
desugarDo :: Show l => [Stmt l] -> Exp l
|
||||
desugarDo [Qualifier _ e] = e
|
||||
@ -630,7 +736,8 @@ desugarDo (LetStmt l binds : stmts) = Let l binds (desugarDo stmts)
|
||||
desugarDo stmts = error $ "Unsupported syntax in degugarDo: " <> show stmts
|
||||
|
||||
-- TODO: Finish evalRecConstr
|
||||
evalRecConstr :: Show l => EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef
|
||||
evalRecConstr :: Show l =>
|
||||
EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef
|
||||
evalRecConstr c qName _ = evalQName qName c
|
||||
|
||||
-- BEGIN generalEvalLambda
|
||||
@ -679,8 +786,10 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
|
||||
pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode))
|
||||
where
|
||||
-- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
|
||||
-- makePatternEdges creates the edges between the patterns and the parameter ports.
|
||||
-- TODO Like evalPatBind, this edge should have an indicator that it is the
|
||||
-- input to a pattern.
|
||||
-- makePatternEdges creates the edges between the patterns and the parameter
|
||||
-- ports.
|
||||
makePatternEdges :: GraphAndRef -> NameAndPort -> Either Edge SgBind
|
||||
makePatternEdges (GraphAndRef _ ref) lamPort = case ref of
|
||||
Right patPort -> Left $ makeSimpleEdge (lamPort, patPort)
|
||||
@ -688,7 +797,8 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
|
||||
-- END generalEvalLambda
|
||||
|
||||
evalLambda :: Show l => EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalLambda :: Show l =>
|
||||
EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
|
||||
|
||||
evalExp :: Show l => EvalContext -> Exp l -> State IDState GraphAndRef
|
||||
@ -764,13 +874,15 @@ evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do
|
||||
(lambdaGraph, lambdaPort) <-
|
||||
generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
|
||||
let
|
||||
newBinding = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)]
|
||||
newBinding
|
||||
= bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)]
|
||||
pure $ makeEdges (newBinding <> lambdaGraph)
|
||||
evalMatch _ match = error $ "Unsupported syntax in evalMatch: " <> show match
|
||||
|
||||
evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph
|
||||
evalMatches _ [] = pure mempty
|
||||
evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c
|
||||
evalMatches c (firstMatch:restOfMatches)
|
||||
= matchesToCase firstMatch restOfMatches >>= evalMatch c
|
||||
|
||||
-- END evalMatches
|
||||
|
||||
@ -798,7 +910,8 @@ evalTypeSig (TypeSig _ names typeForNames) = makeBox
|
||||
++ prettyPrintWithoutNewlines typeForNames)
|
||||
where
|
||||
-- TODO Make custom version of prettyPrint for type signitures.
|
||||
-- Use (unwords . words) to convert consecutive whitspace characters to one space
|
||||
-- Use (unwords . words) to convert consecutive whitspace characters to one
|
||||
-- space.
|
||||
prettyPrintWithoutNewlines = unwords . words . prettyPrint
|
||||
evalTypeSig decl
|
||||
= error $ "Unsupported syntax in evalTypeSig: " <> show decl
|
||||
@ -855,16 +968,20 @@ syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
|
||||
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
|
||||
|
||||
translateDeclToCollapsedGraph :: Show l => Decl l -> IngSyntaxGraph FGR.Gr
|
||||
translateDeclToCollapsedGraph = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph
|
||||
translateDeclToCollapsedGraph
|
||||
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph
|
||||
|
||||
-- Profiling: At one point, this was about 1.5% of total time.
|
||||
translateStringToCollapsedGraphAndDecl :: String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo)
|
||||
translateStringToCollapsedGraphAndDecl ::
|
||||
String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo)
|
||||
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
||||
decl = customParseDecl s -- :: ParseResult Module
|
||||
drawing = translateDeclToCollapsedGraph decl
|
||||
|
||||
translateModuleToCollapsedGraphs :: Show l => Module l -> [IngSyntaxGraph FGR.Gr]
|
||||
translateModuleToCollapsedGraphs (Module _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls
|
||||
translateModuleToCollapsedGraphs :: Show l =>
|
||||
Module l -> [IngSyntaxGraph FGR.Gr]
|
||||
translateModuleToCollapsedGraphs (Module _ _ _ _ decls)
|
||||
= fmap translateDeclToCollapsedGraph decls
|
||||
translateModuleToCollapsedGraphs moduleSyntax
|
||||
= error $ "Unsupported syntax in translateModuleToCollapsedGraphs: "
|
||||
<> show moduleSyntax
|
||||
|
||||
@ -13,14 +13,12 @@ module TranslateCore(
|
||||
getUniqueString,
|
||||
edgesForRefPortList,
|
||||
combineExpressions,
|
||||
--qualifyNameAndPort,
|
||||
makeApplyGraph,
|
||||
makeGuardGraph,
|
||||
namesInPattern,
|
||||
lookupReference,
|
||||
deleteBindings,
|
||||
makeEdges,
|
||||
--makeEdgesCore,
|
||||
makeBox,
|
||||
nTupleString,
|
||||
nTupleSectionString,
|
||||
@ -32,17 +30,19 @@ module TranslateCore(
|
||||
|
||||
import Control.Monad.State(State, state)
|
||||
import Data.Either(partitionEithers)
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
import qualified Data.Graph.Inductive.Graph as ING
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
import Data.List(find)
|
||||
import Data.Semigroup(Semigroup, (<>))
|
||||
|
||||
import Types(Labeled(..), Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
|
||||
NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port,
|
||||
LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..), NamedIcon(..))
|
||||
import Icons(inputPort, resultPort, argumentPorts, guardRhsPorts
|
||||
, guardBoolPorts)
|
||||
import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..)
|
||||
, NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port
|
||||
, LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..)
|
||||
, NamedIcon(..))
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
|
||||
, mapNodeInNamedNode, nodeNameToInt)
|
||||
import Icons(Icon(..), inputPort, resultPort, argumentPorts, guardRhsPorts, guardBoolPorts)
|
||||
|
||||
{-# ANN module "HLint: ignore Use list comprehension" #-}
|
||||
|
||||
@ -73,8 +73,15 @@ data SyntaxGraph = SyntaxGraph {
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup SyntaxGraph where
|
||||
(SyntaxGraph icons1 edges1 sinks1 sources1 map1) <> (SyntaxGraph icons2 edges2 sinks2 sources2 map2) =
|
||||
SyntaxGraph (icons1 <> icons2) (edges1 <> edges2) (sinks1 <> sinks2) (sources1 <> sources2) (map1 <> map2)
|
||||
(<>)
|
||||
(SyntaxGraph icons1 edges1 sinks1 sources1 map1)
|
||||
(SyntaxGraph icons2 edges2 sinks2 sources2 map2)
|
||||
= SyntaxGraph
|
||||
(icons1 <> icons2)
|
||||
(edges1 <> edges2)
|
||||
(sinks1 <> sinks2)
|
||||
(sources1 <> sources2)
|
||||
(map1 <> map2)
|
||||
|
||||
instance Monoid SyntaxGraph where
|
||||
mempty = SyntaxGraph mempty mempty mempty mempty mempty
|
||||
@ -94,7 +101,8 @@ syntaxGraphFromNodes :: [SgNamedNode] -> SyntaxGraph
|
||||
syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty
|
||||
|
||||
syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph
|
||||
syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty mempty
|
||||
syntaxGraphFromNodesEdges icons edges
|
||||
= SyntaxGraph icons edges mempty mempty mempty
|
||||
|
||||
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
|
||||
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
|
||||
@ -134,20 +142,26 @@ getUniqueString base = fmap ((base ++). show) getId
|
||||
|
||||
-- TODO: Refactor with combineExpressions
|
||||
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph
|
||||
edgesForRefPortList inPattern portExpPairs = mconcat $ fmap makeGraph portExpPairs where
|
||||
edgesForRefPortList inPattern portExpPairs
|
||||
= mconcat $ fmap makeGraph portExpPairs
|
||||
where
|
||||
edgeOpts = if inPattern then [EdgeInPattern] else []
|
||||
makeGraph (ref, port) = case ref of
|
||||
Left str -> if inPattern
|
||||
then bindsToSyntaxGraph [SgBind str (Right port)]
|
||||
else sinksToSyntaxGraph [SgSink str port]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection] where
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection]
|
||||
where
|
||||
connection = if inPattern
|
||||
-- If in a pattern, then the port on the case icon is the data source.
|
||||
-- If in a pattern, then the port on the case icon is
|
||||
-- the data source.
|
||||
then (port, resPort)
|
||||
else (resPort, port)
|
||||
|
||||
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph
|
||||
combineExpressions inPattern portExpPairs = mconcat $ fmap makeGraph portExpPairs where
|
||||
combineExpressions inPattern portExpPairs
|
||||
= mconcat $ fmap makeGraph portExpPairs
|
||||
where
|
||||
edgeOpts = if inPattern then [EdgeInPattern] else []
|
||||
makeGraph (GraphAndRef graph ref, port) = graph <> case ref of
|
||||
Left str -> if inPattern
|
||||
@ -155,19 +169,37 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap makeGraph portExpPair
|
||||
else sinksToSyntaxGraph [SgSink str port]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)]
|
||||
|
||||
makeApplyGraph :: Int -> LikeApplyFlavor -> Bool -> NodeName -> GraphAndRef -> [GraphAndRef] -> (SyntaxGraph, NameAndPort)
|
||||
makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort applyNode))
|
||||
makeApplyGraph ::
|
||||
Int
|
||||
-> LikeApplyFlavor
|
||||
-> Bool
|
||||
-> NodeName
|
||||
-> GraphAndRef
|
||||
-> [GraphAndRef]
|
||||
-> (SyntaxGraph, NameAndPort)
|
||||
makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals
|
||||
= (newGraph <> combinedGraph
|
||||
, nameAndPort applyIconName (resultPort applyNode)
|
||||
)
|
||||
where
|
||||
applyNode = LikeApplyNode applyFlavor numArgs
|
||||
argumentNamePorts = map (nameAndPort applyIconName) (argumentPorts applyNode)
|
||||
argumentNamePorts
|
||||
= map (nameAndPort applyIconName) (argumentPorts applyNode)
|
||||
functionPort = nameAndPort applyIconName (inputPort applyNode)
|
||||
combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentNamePorts)
|
||||
combinedGraph = combineExpressions inPattern
|
||||
$ zip (funVal:argVals) (functionPort:argumentNamePorts)
|
||||
icons = [SgNamedNode applyIconName applyNode]
|
||||
newGraph = syntaxGraphFromNodes icons
|
||||
|
||||
makeGuardGraph ::
|
||||
Int -> NodeName -> [GraphAndRef] -> [GraphAndRef] -> (SyntaxGraph, NameAndPort)
|
||||
makeGuardGraph numPairs guardName bools exps = (newGraph, nameAndPort guardName (resultPort guardNode)) where
|
||||
Int
|
||||
-> NodeName
|
||||
-> [GraphAndRef]
|
||||
-> [GraphAndRef]
|
||||
-> (SyntaxGraph, NameAndPort)
|
||||
makeGuardGraph numPairs guardName bools exps
|
||||
= (newGraph, nameAndPort guardName (resultPort guardNode))
|
||||
where
|
||||
guardNode = GuardNode numPairs
|
||||
expsWithPorts = zip exps $ map (nameAndPort guardName) guardRhsPorts
|
||||
boolsWithPorts = zip bools $ map (nameAndPort guardName) guardBoolPorts
|
||||
@ -207,10 +239,11 @@ makeEdgesCore :: [SgSink] -> [SgBind] -> ([SgSink], [Edge])
|
||||
makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
|
||||
where
|
||||
renameOrMakeEdge :: SgSink -> Either SgSink Edge
|
||||
renameOrMakeEdge orig@(SgSink s destPort) = case lookup s (fmap sgBindToTuple bindings) of
|
||||
renameOrMakeEdge orig@(SgSink s destPort)
|
||||
= case lookup s (fmap sgBindToTuple bindings) of
|
||||
Just ref -> case lookupReference bindings ref of
|
||||
(Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort)
|
||||
(Left newStr) -> Left $ SgSink newStr destPort
|
||||
Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort)
|
||||
Left newStr -> Left $ SgSink newStr destPort
|
||||
Nothing -> Left orig
|
||||
|
||||
makeEdges :: SyntaxGraph -> SyntaxGraph
|
||||
@ -218,7 +251,6 @@ makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph where
|
||||
(newSinks, newEdges) = makeEdgesCore sinks bindings
|
||||
newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap
|
||||
|
||||
-- TODO: remove / change due toSyntaxGraph
|
||||
makeBox :: String -> State IDState (SyntaxGraph, NameAndPort)
|
||||
makeBox str = do
|
||||
name <- getUniqueName
|
||||
@ -265,7 +297,8 @@ nodeToIcon (NestedCaseOrGuardNode tag x edges)
|
||||
makeArg :: [(SgNamedNode, Edge)] -> Port -> Maybe NamedIcon
|
||||
makeArg args port = case find (findArg port) args of
|
||||
Nothing -> Nothing
|
||||
Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||
Just (SgNamedNode argName argSyntaxNode, _)
|
||||
-> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||
|
||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
||||
-> Int
|
||||
@ -279,7 +312,11 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||
headIcon = makeArg args (inputPort dummyNode)
|
||||
argList = fmap (makeArg args) argPorts
|
||||
|
||||
nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon
|
||||
nestedCaseOrGuardNodeToIcon ::
|
||||
CaseOrGuardTag
|
||||
-> Int
|
||||
-> [(SgNamedNode, Edge)]
|
||||
-> Icon
|
||||
nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
||||
CaseTag -> NestedCaseIcon argList
|
||||
GuardTag -> NestedGuardIcon argList
|
||||
@ -296,7 +333,9 @@ nestedPatternNodeToIcon str children = NestedPApp
|
||||
children)
|
||||
|
||||
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
||||
findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
findArg currentPort
|
||||
(SgNamedNode argName _
|
||||
, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
|
||||
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
||||
| otherwise = False -- This case should never happen
|
||||
@ -309,7 +348,8 @@ lookupInEmbeddingMap origName eMap = lookupHelper origName where
|
||||
lookupHelper name = case lookup name eMap of
|
||||
Nothing -> name
|
||||
Just parent -> if parent == origName
|
||||
then error $ "lookupInEmbeddingMap: Found cycle. Node = " ++ show origName ++ "\nEmbedding Map = " ++ show eMap
|
||||
then error $ "lookupInEmbeddingMap: Found cycle. Node = "
|
||||
++ show origName ++ "\nEmbedding Map = " ++ show eMap
|
||||
else lookupHelper parent
|
||||
|
||||
syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge
|
||||
@ -318,4 +358,6 @@ syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
|
||||
labeledEdges = fmap makeLabeledEdge edges
|
||||
|
||||
makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) =
|
||||
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap, nodeNameToInt $ lookupInEmbeddingMap name2 eMap, e)
|
||||
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap
|
||||
, nodeNameToInt $ lookupInEmbeddingMap name2 eMap
|
||||
, e)
|
||||
|
||||
47
app/Util.hs
47
app/Util.hs
@ -1,20 +1,13 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
|
||||
module Util (
|
||||
portToPort,
|
||||
printSelf,
|
||||
iconToPort,
|
||||
iconToIcon,
|
||||
iconToIconEnds,
|
||||
--iconHeadToPort,
|
||||
iconTailToPort,
|
||||
makeSimpleEdge,
|
||||
noEnds,
|
||||
nameAndPort,
|
||||
justName,
|
||||
fromMaybeError,
|
||||
mapFst,
|
||||
printSelf,
|
||||
eitherToMaybes,
|
||||
maybeBoolToBool,
|
||||
mapNodeInNamedNode,
|
||||
sgNamedNodeToSyntaxNode,
|
||||
@ -25,21 +18,16 @@ module Util (
|
||||
) where
|
||||
|
||||
import Diagrams.Backend.SVG(renderSVG', Options(..), SVG)
|
||||
import Graphics.Svg.Attributes(bindAttr, AttrTag(..))
|
||||
import qualified Diagrams.Prelude as Dia
|
||||
import Graphics.Svg.Attributes(bindAttr, AttrTag(..))
|
||||
|
||||
import Control.Arrow(first)
|
||||
-- import Diagrams.Prelude(IsName, toName, Name)
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Debug.Trace
|
||||
import Data.Text(pack)
|
||||
import Data.Typeable(Typeable)
|
||||
import qualified Debug.Trace
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..), Port,
|
||||
SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
||||
|
||||
mapFst :: Functor f => (a -> b) -> f (a, c) -> f (b, c)
|
||||
mapFst f = fmap (first f)
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..)
|
||||
, Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
||||
|
||||
noEnds :: (EdgeEnd, EdgeEnd)
|
||||
noEnds = (EndNone, EndNone)
|
||||
@ -54,27 +42,9 @@ justName :: NodeName -> NameAndPort
|
||||
justName n = NameAndPort n Nothing
|
||||
|
||||
-- BEGIN Edge constructors --
|
||||
portToPort :: NodeName -> Port -> NodeName -> Port -> Edge
|
||||
portToPort a b c d = makeSimpleEdge (nameAndPort a b, nameAndPort c d)
|
||||
|
||||
iconToPort :: NodeName -> NodeName -> Port -> Edge
|
||||
iconToPort a c d = makeSimpleEdge (justName a, nameAndPort c d)
|
||||
|
||||
iconToIcon :: NodeName -> NodeName -> Edge
|
||||
iconToIcon a c = makeSimpleEdge (justName a, justName c)
|
||||
|
||||
|
||||
-- If there are gaps between the arrow and the icon, try switching the first two arguments
|
||||
-- with the last two arguments
|
||||
iconToIconEnds :: NodeName -> EdgeEnd -> NodeName -> EdgeEnd -> Edge
|
||||
iconToIconEnds a b c d = Edge [] (b, d) (justName a, justName c)
|
||||
|
||||
-- iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
-- iconHeadToPort a endHead c d = Edge (justName a, nameAndPort c d) (EndNone, endHead)
|
||||
|
||||
iconTailToPort :: NodeName -> EdgeEnd -> NodeName -> Port -> Edge
|
||||
iconTailToPort a endTail c d = Edge [] (endTail, EndNone) (justName a, nameAndPort c d)
|
||||
|
||||
-- END Edge constructors --
|
||||
|
||||
fromMaybeError :: String -> Maybe a -> a
|
||||
@ -83,10 +53,6 @@ fromMaybeError s = fromMaybe (error s)
|
||||
printSelf :: (Show a) => a -> a
|
||||
printSelf a = Debug.Trace.trace (show a ++ "\n\n") a
|
||||
|
||||
eitherToMaybes :: Either a b -> (Maybe a, Maybe b)
|
||||
eitherToMaybes (Left x) = (Just x, Nothing)
|
||||
eitherToMaybes (Right y) = (Nothing, Just y)
|
||||
|
||||
-- | (Just True) = True, Nothing = False
|
||||
maybeBoolToBool :: Maybe Bool -> Bool
|
||||
maybeBoolToBool = or
|
||||
@ -114,5 +80,6 @@ customRenderSVG :: (Typeable n, Show n, RealFloat n) =>
|
||||
customRenderSVG outputFilename size = renderSVG' outputFilename svgOptions where
|
||||
-- This xml:space attribute preserves the whitespace in the svg text.
|
||||
attributes = [bindAttr XmlSpace_ (pack "preserve")]
|
||||
-- TODO Look at the source of renderSVG to see what the 3rd argument to SVGOptions should be
|
||||
-- TODO Look at the source of renderSVG to see what the 3rd argument to
|
||||
-- SVGOptions should be
|
||||
svgOptions = SVGOptions size Nothing (pack "") attributes True
|
||||
|
||||
@ -3,8 +3,7 @@
|
||||
module VisualRenderingTests (
|
||||
renderTests
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude hiding ((#), (&))
|
||||
import qualified Diagrams.Prelude as Dia
|
||||
|
||||
import Rendering (renderDrawing)
|
||||
import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..)
|
||||
@ -13,16 +12,17 @@ import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..)
|
||||
|
||||
import Util(iconToPort, tupleToNamedIcon)
|
||||
|
||||
|
||||
iconToIntPort :: NodeName -> NodeName -> Int -> Edge
|
||||
iconToIntPort x y p = iconToPort x y (Port p)
|
||||
|
||||
n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10 :: NodeName
|
||||
nodeNames :: [NodeName]
|
||||
nodeNames@[n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10] = fmap NodeName [0..10]
|
||||
nodeNames@[n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10]
|
||||
= fmap NodeName [0..10]
|
||||
|
||||
ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10 :: Icon -> NamedIcon
|
||||
[ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10] = fmap NamedIcon nodeNames
|
||||
[ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10]
|
||||
= fmap NamedIcon nodeNames
|
||||
|
||||
-- TODO refactor these Drawings
|
||||
nestedCaseDrawing :: Drawing
|
||||
@ -101,7 +101,6 @@ nestedApplyDia = Drawing icons []
|
||||
ApplyNodeFlavor
|
||||
(Just $ NamedIcon (NodeName 1) (TextBoxIcon "foo"))
|
||||
[])
|
||||
--[Just $ NamedIcon (NodeName 1) (TextBoxIcon "bar")])
|
||||
]
|
||||
|
||||
lambdaDia :: Drawing
|
||||
@ -118,7 +117,7 @@ lambdaDia = Drawing icons []
|
||||
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||
renderTests = do
|
||||
renderedDiagrams <- traverse renderDrawing allDrawings
|
||||
let vCattedDrawings = vsep 0.5 renderedDiagrams
|
||||
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
||||
pure vCattedDrawings
|
||||
where
|
||||
allDrawings = [
|
||||
|
||||
Loading…
Reference in New Issue
Block a user