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