mirror of
https://github.com/rgleichman/glance.git
synced 2024-10-26 16:51:29 +03:00
Simplify types.
This commit is contained in:
parent
f331e8dca8
commit
287b477d1b
178
app/Icons.hs
178
app/Icons.hs
@ -22,9 +22,12 @@ import Diagrams.Prelude
|
|||||||
import Diagrams.TwoD.Text(Text)
|
import Diagrams.TwoD.Text(Text)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
import Types(Icon(..), Edge)
|
import Types(Icon(..), SpecialQDiagram, SpecialBackend)
|
||||||
import Util(fromMaybeError)
|
import Util(fromMaybeError)
|
||||||
|
|
||||||
|
-- TYPES --
|
||||||
|
type TransformableDia b = (Bool -> Double -> SpecialQDiagram b)
|
||||||
|
|
||||||
-- COLO(U)RS --
|
-- COLO(U)RS --
|
||||||
colorScheme :: (Floating a, Ord a) => ColorStyle a
|
colorScheme :: (Floating a, Ord a) => ColorStyle a
|
||||||
colorScheme = colorOnBlackScheme
|
colorScheme = colorOnBlackScheme
|
||||||
@ -109,19 +112,12 @@ randomColorScheme = ColorStyle {
|
|||||||
lineCol :: (Floating a, Ord a) => Colour a
|
lineCol :: (Floating a, Ord a) => Colour a
|
||||||
lineCol = lineC colorScheme
|
lineCol = lineC colorScheme
|
||||||
|
|
||||||
type TransformableDia a b c d = (Bool -> Double -> QDiagram a b c d)
|
|
||||||
|
|
||||||
-- FUNCTIONS --
|
-- FUNCTIONS --
|
||||||
-- Optimization: The apply0NDia's can be memoized.
|
-- Optimization: The apply0NDia's can be memoized.
|
||||||
-- iconToDiagram ::
|
iconToDiagram :: SpecialBackend b => Icon -> [(Name, SpecialQDiagram b)] -> Bool -> Double -> SpecialQDiagram b
|
||||||
-- (RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
|
||||||
-- Renderable (Text n) b) =>
|
|
||||||
-- Icon -> [(Name, QDiagram b V2 n Any)] -> TransformableDia b V2 n Any
|
|
||||||
iconToDiagram ::_ =>
|
|
||||||
Icon -> [(Name, QDiagram b V2 Double Any)] -> Bool -> Double -> QDiagram b V2 Double Any
|
|
||||||
iconToDiagram (ApplyAIcon n) _ = identDiaFunc $ applyADia n
|
iconToDiagram (ApplyAIcon n) _ = identDiaFunc $ applyADia n
|
||||||
iconToDiagram (PAppIcon n str) _ = diaFunc $ pAppDia n str
|
iconToDiagram (PAppIcon n str) _ = pAppDia n str
|
||||||
iconToDiagram (TextApplyAIcon n str) _ = diaFunc $ textApplyADia n str
|
iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str
|
||||||
iconToDiagram ResultIcon _ = identDiaFunc resultIcon
|
iconToDiagram ResultIcon _ = identDiaFunc resultIcon
|
||||||
iconToDiagram BranchIcon _ = identDiaFunc branchIcon
|
iconToDiagram BranchIcon _ = identDiaFunc branchIcon
|
||||||
iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s
|
iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s
|
||||||
@ -135,41 +131,22 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
|
|||||||
where
|
where
|
||||||
dia = fromMaybeError "iconToDiagram: subdiagram not found" $ lookup diagramName nameToSubdiagramMap
|
dia = fromMaybeError "iconToDiagram: subdiagram not found" $ lookup diagramName nameToSubdiagramMap
|
||||||
|
|
||||||
--Get the decimal part of a float
|
|
||||||
--reduceAngleRange :: Double -> Double
|
|
||||||
reduceAngleRange :: Double -> Double
|
|
||||||
reduceAngleRange x = x - fromInteger (floor x)
|
|
||||||
|
|
||||||
-- Make an identity TransformableDia
|
-- Make an identity TransformableDia
|
||||||
identDiaFunc :: _ => QDiagram b V2 n m -> TransformableDia b V2 n m
|
identDiaFunc :: SpecialQDiagram b -> TransformableDia b
|
||||||
identDiaFunc dia _ _ = dia
|
identDiaFunc dia _ _ = dia
|
||||||
|
|
||||||
--makeSymmetricTransDia :: _ => QDiagram b V2 n m -> nm -> Bool -> n -> QDiagram b V2 n m
|
|
||||||
--makeSymmetricTransDia dia nm reflect angle = nameDiagram nm $ rotateBy (if reflect then angle + (1/2) else angle) dia
|
|
||||||
|
|
||||||
diaFunc dia reflect angle = dia reflect angle
|
|
||||||
|
|
||||||
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||||
nameDiagram :: (Floating n, Ord n, Semigroup m, Metric v, IsName nm) => nm -> QDiagram b v n m -> QDiagram b v n m
|
nameDiagram :: (SpecialBackend b, IsName nm) => nm -> SpecialQDiagram b -> SpecialQDiagram b
|
||||||
nameDiagram name dia = named name (name .>> dia)
|
nameDiagram name dia = named name (name .>> dia)
|
||||||
|
|
||||||
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
||||||
--- since mempty has no size and will not be placed where you want it.
|
--- since mempty has no size and will not be placed where you want it.
|
||||||
makePort :: (Floating n, Ord n, Semigroup m, Metric v) => Int -> QDiagram b v n m
|
makePort :: Int -> SpecialQDiagram b
|
||||||
makePort x = mempty # named x
|
makePort x = mempty # named x
|
||||||
--makePort x = circle 0.2 # fc green # named x
|
--makePort x = circle 0.2 # fc green # named x
|
||||||
-- Note, the version of makePort below seems to have a different type.
|
-- Note, the version of makePort below seems to have a different type.
|
||||||
--makePort x = textBox (show x) # fc green # named x
|
--makePort x = textBox (show x) # fc green # named x
|
||||||
|
|
||||||
|
|
||||||
--makePortDiagrams :: [P2 Double] -> Diagram B
|
|
||||||
--makePortDiagrams ::(Monoid a, Semigroup a, HasOrigin a, b ~ N a) => [P2 b] -> GeneralDiagram a
|
|
||||||
makePortDiagrams ::
|
|
||||||
(Floating n, Ord n, Semigroup m, Metric v) =>
|
|
||||||
[Point v n] -> QDiagram b v n m
|
|
||||||
makePortDiagrams points =
|
|
||||||
atPoints points (map makePort ([0,1..] :: [Int]))
|
|
||||||
|
|
||||||
-- CONSTANTS --
|
-- CONSTANTS --
|
||||||
defaultLineWidth :: (Fractional a) => a
|
defaultLineWidth :: (Fractional a) => a
|
||||||
defaultLineWidth = 0.15
|
defaultLineWidth = 0.15
|
||||||
@ -178,54 +155,23 @@ defaultLineWidth = 0.15
|
|||||||
circleRadius :: (Fractional a) => a
|
circleRadius :: (Fractional a) => a
|
||||||
circleRadius = 0.5
|
circleRadius = 0.5
|
||||||
|
|
||||||
type GeneralDiagram b = (Transformable b, RealFloat (N b), Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
|
||||||
|
|
||||||
resultCircle ::
|
|
||||||
(RealFloat (N b), Typeable (N b), Transformable b, HasStyle b,
|
|
||||||
TrailLike b, V b ~ V2) =>
|
|
||||||
b
|
|
||||||
resultCircle = circle circleRadius # fc (apply0C colorScheme) # lw none
|
|
||||||
|
|
||||||
apply0Triangle ::
|
apply0Triangle ::
|
||||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||||
V b ~ V2) =>
|
V b ~ V2) =>
|
||||||
b
|
b
|
||||||
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # lw none
|
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # lw none
|
||||||
|
|
||||||
apply0Line ::
|
portCircle :: (SpecialBackend b) => SpecialQDiagram b
|
||||||
(Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
|
||||||
apply0Line = rect defaultLineWidth (2 * circleRadius) # fc lineCol # lw none
|
|
||||||
|
|
||||||
--apply0Dia :: (Juxtaposable a, Semigroup a) => GeneralDiagram a
|
|
||||||
applyA0Dia ::
|
|
||||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
|
||||||
TrailLike (QDiagram b V2 n m)) =>
|
|
||||||
QDiagram b V2 n m
|
|
||||||
applyA0Dia = ((resultCircle ||| apply0Line ||| fc (apply0C colorScheme) apply0Triangle) <> makePortDiagrams apply0PortLocations) # reflectX # centerXY
|
|
||||||
|
|
||||||
apply0PortLocations :: Floating a => [P2 a]
|
|
||||||
apply0PortLocations = map p2 [
|
|
||||||
(circleRadius + defaultLineWidth + triangleWidth, 0),
|
|
||||||
(-circleRadius,0),
|
|
||||||
(lineCenter,-circleRadius)
|
|
||||||
--(lineCenter,circleRadius),
|
|
||||||
]
|
|
||||||
where
|
|
||||||
triangleWidth = circleRadius * sqrt 3
|
|
||||||
lineCenter = circleRadius + (defaultLineWidth / 2.0)
|
|
||||||
|
|
||||||
portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
||||||
|
|
||||||
-- apply0N Icon--
|
-- applyA Icon--
|
||||||
-- | apply0N port locations:
|
-- | apply0N port locations:
|
||||||
-- Port 0: Function
|
-- Port 0: Function
|
||||||
-- Port 1: Result
|
-- Port 1: Result
|
||||||
-- Ports 2,3..: Arguments
|
-- Ports 2,3..: Arguments
|
||||||
coloredApplyADia ::
|
coloredApplyADia ::
|
||||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
(SpecialBackend b) =>
|
||||||
TrailLike (QDiagram b V2 n m)) =>
|
Colour Double -> Int -> SpecialQDiagram b
|
||||||
Colour Double -> Int -> QDiagram b V2 n m
|
|
||||||
--applyADia 1 = applyA0Dia
|
|
||||||
coloredApplyADia appColor n = finalDia # centerXY where
|
coloredApplyADia appColor n = finalDia # centerXY where
|
||||||
seperation = circleRadius * 1.5
|
seperation = circleRadius * 1.5
|
||||||
trianglePortsCircle = hcat [
|
trianglePortsCircle = hcat [
|
||||||
@ -238,18 +184,23 @@ coloredApplyADia appColor n = finalDia # centerXY where
|
|||||||
topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL
|
topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL
|
||||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||||
|
|
||||||
|
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||||
applyADia = coloredApplyADia (apply0C colorScheme)
|
applyADia = coloredApplyADia (apply0C colorScheme)
|
||||||
|
|
||||||
--textApplyADia :: _ => Int -> String -> QDiagram b V2 n m
|
textApplyADia :: SpecialBackend b =>
|
||||||
textApplyADia :: _ =>
|
Int -> String -> TransformableDia b
|
||||||
Int -> String -> TransformableDia b V2 Double Any
|
|
||||||
textApplyADia = generalTextAppDia (textBoxTextC colorScheme) (apply0C colorScheme)
|
textApplyADia = generalTextAppDia (textBoxTextC colorScheme) (apply0C colorScheme)
|
||||||
|
|
||||||
pAppDia :: _ =>
|
pAppDia :: SpecialBackend b =>
|
||||||
Int -> String -> TransformableDia b V2 Double Any
|
Int -> String -> TransformableDia b
|
||||||
pAppDia = generalTextAppDia (patternTextC colorScheme) (patternC colorScheme)
|
pAppDia = generalTextAppDia (patternTextC colorScheme) (patternC colorScheme)
|
||||||
|
|
||||||
generalTextAppDia :: _ => Colour Double -> Colour Double -> Int -> String -> Bool -> Double -> QDiagram b V2 n Any
|
--Get the decimal part of a float
|
||||||
|
reduceAngleRange :: Double -> Double
|
||||||
|
reduceAngleRange x = x - fromInteger (floor x)
|
||||||
|
|
||||||
|
generalTextAppDia :: SpecialBackend b =>
|
||||||
|
Colour Double -> Colour Double -> Int -> String -> Bool -> Double -> SpecialQDiagram b
|
||||||
generalTextAppDia textCol borderCol numArgs str reflect angle = rotateDia where
|
generalTextAppDia textCol borderCol numArgs str reflect angle = rotateDia where
|
||||||
rotateDia = rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str)) |||
|
rotateDia = rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str)) |||
|
||||||
coloredApplyADia borderCol numArgs
|
coloredApplyADia borderCol numArgs
|
||||||
@ -265,25 +216,19 @@ monoLetterWidthToHeightFraction = 0.61
|
|||||||
textBoxHeightFactor :: (Fractional a) => a
|
textBoxHeightFactor :: (Fractional a) => a
|
||||||
textBoxHeightFactor = 1.1
|
textBoxHeightFactor = 1.1
|
||||||
|
|
||||||
textBox ::
|
textBox :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
String -> SpecialQDiagram b
|
||||||
Renderable (Text n) b) =>
|
|
||||||
String -> QDiagram b V2 n Any
|
|
||||||
textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
|
textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
|
||||||
|
|
||||||
bindTextBox ::
|
bindTextBox :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
String -> SpecialQDiagram b
|
||||||
Renderable (Text n) b) =>
|
|
||||||
String -> QDiagram b V2 n Any
|
|
||||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||||
|
|
||||||
-- Since the normal SVG text has no size, some hackery is needed to determine
|
-- Since the normal SVG text has no size, some hackery is needed to determine
|
||||||
-- the size of the text's bounding box.
|
-- the size of the text's bounding box.
|
||||||
coloredTextBox ::
|
coloredTextBox :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
Colour Double
|
||||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||||
Colour Double
|
|
||||||
-> AlphaColour Double -> String -> QDiagram b V2 n Any
|
|
||||||
coloredTextBox textColor boxColor t =
|
coloredTextBox textColor boxColor t =
|
||||||
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
||||||
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth)
|
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth)
|
||||||
@ -293,67 +238,57 @@ coloredTextBox textColor boxColor t =
|
|||||||
+ (textBoxFontSize * 0.2)
|
+ (textBoxFontSize * 0.2)
|
||||||
|
|
||||||
-- ENCLOSING REGION --
|
-- ENCLOSING REGION --
|
||||||
enclosure ::
|
enclosure :: SpecialBackend b =>
|
||||||
(Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
|
SpecialQDiagram b -> SpecialQDiagram b
|
||||||
TrailLike (QDiagram b V2 n m)) =>
|
|
||||||
QDiagram b V2 n m -> QDiagram b V2 n m
|
|
||||||
enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
||||||
|
|
||||||
-- LAMBDA ICON --
|
-- LAMBDA ICON --
|
||||||
-- Don't use === here to put the port under the text box since mempty will stay
|
-- Don't use === here to put the port under the text box since mempty will stay
|
||||||
-- at the origin of the text box.
|
-- at the origin of the text box.
|
||||||
lambdaIcon ::
|
lambdaIcon ::
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
SpecialBackend b =>
|
||||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
Int -> SpecialQDiagram b
|
||||||
Int -> QDiagram b V2 n Any
|
|
||||||
lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
|
lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
|
||||||
|
|
||||||
-- LAMBDA REGION --
|
-- LAMBDA REGION --
|
||||||
|
|
||||||
-- | lambdaRegion takes as an argument the numbers of parameters to the lambda,
|
-- | lambdaRegion takes as an argument the numbers of parameters to the lambda,
|
||||||
-- and draws the diagram inside a region with the lambda icons on top.
|
-- and draws the diagram inside a region with the lambda icons on top.
|
||||||
lambdaRegion ::
|
lambdaRegion :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
||||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
|
||||||
Int -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
|
||||||
lambdaRegion n dia =
|
lambdaRegion n dia =
|
||||||
centerXY $ lambdaIcons # centerX === (enclosure dia # centerX)
|
centerXY $ lambdaIcons # centerX === (enclosure dia # centerX)
|
||||||
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
||||||
|
|
||||||
-- RESULT ICON --
|
-- RESULT ICON --
|
||||||
resultIcon ::
|
resultIcon :: SpecialBackend b => SpecialQDiagram b
|
||||||
(Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
|
||||||
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
||||||
|
|
||||||
-- BRANCH ICON --
|
-- BRANCH ICON --
|
||||||
branchIcon :: GeneralDiagram a
|
branchIcon :: SpecialBackend b => SpecialQDiagram b
|
||||||
branchIcon = circle circleRadius # fc lineCol # lc lineCol # lw none
|
branchIcon = circle circleRadius # fc lineCol # lc lineCol # lw none
|
||||||
|
|
||||||
-- GUARD ICON --
|
-- GUARD ICON --
|
||||||
guardSize :: (Fractional a) => a
|
guardSize :: (Fractional a) => a
|
||||||
guardSize = 0.7
|
guardSize = 0.7
|
||||||
|
|
||||||
guardTriangle ::
|
guardTriangle :: SpecialBackend b =>
|
||||||
(Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
|
Int -> SpecialQDiagram b
|
||||||
TrailLike (QDiagram b V2 n m)) =>
|
|
||||||
Int -> QDiagram b V2 n m
|
|
||||||
guardTriangle x =
|
guardTriangle x =
|
||||||
((triangleAndPort ||| (hrule (guardSize * 0.8) # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
|
((triangleAndPort ||| (hrule (guardSize * 0.8) # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
|
||||||
where
|
where
|
||||||
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
||||||
# rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR
|
# rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR
|
||||||
|
|
||||||
guardLBracket ::
|
guardLBracket :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
Int -> SpecialQDiagram b
|
||||||
Int -> QDiagram b V2 n Any
|
|
||||||
guardLBracket x = ell # alignT # alignL <> makePort x
|
guardLBracket x = ell # alignT # alignL <> makePort x
|
||||||
where
|
where
|
||||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||||
ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound
|
ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound
|
||||||
|
|
||||||
generalGuardIcon ::
|
generalGuardIcon :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b
|
||||||
Colour Double -> (Int -> QDiagram b V2 n Any) -> QDiagram b V2 n Any -> Int -> QDiagram b V2 n Any
|
|
||||||
generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0)
|
generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0)
|
||||||
where
|
where
|
||||||
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
||||||
@ -372,21 +307,18 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
|
|||||||
-- Port 1: Bottom result port
|
-- Port 1: Bottom result port
|
||||||
-- Ports 3,5...: The left ports for the booleans
|
-- Ports 3,5...: The left ports for the booleans
|
||||||
-- Ports 2,4...: The right ports for the values
|
-- Ports 2,4...: The right ports for the values
|
||||||
guardIcon ::
|
guardIcon :: SpecialBackend b =>
|
||||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
Int -> SpecialQDiagram b
|
||||||
Int -> QDiagram b V2 n Any
|
|
||||||
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
||||||
|
|
||||||
-- TODO Improve design to be more than a circle.
|
-- TODO Improve design to be more than a circle.
|
||||||
caseResult :: (RealFloat n,
|
caseResult :: SpecialBackend b =>
|
||||||
Typeable n,
|
SpecialQDiagram b
|
||||||
Renderable (Path V2 n) b) => QDiagram b V2 n Any
|
|
||||||
caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where
|
caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where
|
||||||
caseCColor = caseRhsC colorScheme
|
caseCColor = caseRhsC colorScheme
|
||||||
|
|
||||||
caseC :: (RealFloat n,
|
caseC :: SpecialBackend b =>
|
||||||
Typeable n,
|
Int -> SpecialQDiagram b
|
||||||
Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any
|
|
||||||
caseC n = caseResult <> makePort n
|
caseC n = caseResult <> makePort n
|
||||||
|
|
||||||
|
|
||||||
@ -395,15 +327,15 @@ caseC n = caseResult <> makePort n
|
|||||||
-- Port 1: Bottom result port
|
-- Port 1: Bottom result port
|
||||||
-- Ports 3,5...: The left ports for the results
|
-- Ports 3,5...: The left ports for the results
|
||||||
-- Ports 2,4...: The right ports for the patterns
|
-- Ports 2,4...: The right ports for the patterns
|
||||||
caseIcon ::(RealFloat n,
|
caseIcon :: SpecialBackend b =>
|
||||||
Typeable n,
|
Int -> SpecialQDiagram b
|
||||||
Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any
|
|
||||||
caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
||||||
|
|
||||||
-- | The ports of flatLambdaIcon are:
|
-- | The ports of flatLambdaIcon are:
|
||||||
-- 0: Result icon
|
-- 0: Result icon
|
||||||
-- 1: The lambda function value
|
-- 1: The lambda function value
|
||||||
-- 2,3.. : The parameters
|
-- 2,3.. : The parameters
|
||||||
|
flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||||
flatLambda n = finalDia where
|
flatLambda n = finalDia where
|
||||||
lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
||||||
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
||||||
|
33
app/Main.hs
33
app/Main.hs
@ -18,40 +18,31 @@ import Translate(translateString, drawingsFromModule)
|
|||||||
|
|
||||||
-- Refactor Translate
|
-- Refactor Translate
|
||||||
-- Add documentation.
|
-- Add documentation.
|
||||||
-- Update readme.
|
|
||||||
-- Test reference lookup in case rhs.
|
|
||||||
-- Have the file be a command line argument to main.
|
-- Have the file be a command line argument to main.
|
||||||
-- In evalPatBind, give the edge from the rhs to the pattern a special arrowhead.
|
|
||||||
-- Line intersections should have a small circle. This could probably be done with
|
|
||||||
-- a line ending.
|
|
||||||
-- Move tests out of main.
|
-- Move tests out of main.
|
||||||
|
|
||||||
-- TODO Later --
|
-- TODO Later --
|
||||||
-- Visual todos
|
-- Visual todos:
|
||||||
-- Give lines a black border to make line crossings easier to see.
|
-- Give lines a black border to make line crossings easier to see.
|
||||||
-- Give lines that cross the border of a lambda function a special color.
|
-- Give lines that cross the border of a lambda function a special color.
|
||||||
|
-- Line intersections should have a small circle. This could probably be done with
|
||||||
|
-- a line ending.
|
||||||
|
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
||||||
|
-- Let lines connect to ports in multiple locations (eg. case value, or guard result)
|
||||||
|
-- Rotate icons based on the outgoing line's difference from ideal angle, not line distance.
|
||||||
|
-- Improve line routing. Draw curved lines with outgoing lines at fixed angles.
|
||||||
|
-- - connectPerim might be useful for this.
|
||||||
|
|
||||||
-- Translate todos:
|
-- Translate todos:
|
||||||
-- Fix test case x of {0 -> 1; y -> y}.
|
-- Fix test case x of {0 -> 1; y -> y}.
|
||||||
|
|
||||||
-- Have icon rotation just rotate internal items, not the entire diagram.
|
|
||||||
-- Use a nested tree layout. A graph can take an optional (name, Icon) as filling a port.
|
|
||||||
-- Use clustered graphs. Make a test project.
|
|
||||||
-- Consider making lines between patterns Pattern Color when the line is a reference.
|
|
||||||
-- Consider using seperate parameter icons in functions.
|
|
||||||
-- Add function name and type to LambdaIcons.
|
|
||||||
-- Add proper RecConstr, and RecUpdate support.
|
-- Add proper RecConstr, and RecUpdate support.
|
||||||
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
|
||||||
-- Eliminate BranchIcon in Alts.
|
-- Eliminate BranchIcon in Alts.
|
||||||
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
||||||
-- otherwise Guard special case
|
-- otherwise Guard special case
|
||||||
-- Let lines connect to ports in multiple locations (eg. argument for Apply0Dia)
|
|
||||||
-- Add a small black border to lines to help distinguish line crossings.
|
--Other todos:
|
||||||
-- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly
|
-- Use a nested tree layout. A graph can take an optional (name, Icon) instead of a port.
|
||||||
-- todo: Find out and fix why connectinos to sub-icons need to be qualified twice (eg. "lam0" .> "arg" .> "arg")
|
|
||||||
-- todo: Rotate based on difference from ideal tangent angle, not line distance.
|
|
||||||
-- todo: Try using connectPerim for port to port connections. Hopefully this will draw a spline.
|
|
||||||
-- todo: layout and rotate considering external connections.
|
|
||||||
|
|
||||||
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
||||||
d0Icons = toNames
|
d0Icons = toNames
|
||||||
|
@ -6,7 +6,6 @@ module Rendering (
|
|||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude
|
||||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||||
import Diagrams.TwoD.Text(Text)
|
|
||||||
--import Diagrams.Backend.SVG(B)
|
--import Diagrams.Backend.SVG(B)
|
||||||
|
|
||||||
import qualified Data.GraphViz as GV
|
import qualified Data.GraphViz as GV
|
||||||
@ -22,8 +21,9 @@ import Data.Graph.Inductive.PatriciaTree (Gr)
|
|||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
--import Data.Word(Word16)
|
--import Data.Word(Word16)
|
||||||
|
|
||||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
import Icons(colorScheme, iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||||
import Types(Edge(..), EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
|
import Types(Edge(..), Icon, EdgeOption(..), Connection, Drawing(..), EdgeEnd(..),
|
||||||
|
NameAndPort(..), SpecialQDiagram, SpecialBackend)
|
||||||
import Util(fromMaybeError)
|
import Util(fromMaybeError)
|
||||||
|
|
||||||
-- If the inferred types for these functions becomes unweildy,
|
-- If the inferred types for these functions becomes unweildy,
|
||||||
@ -52,13 +52,7 @@ drawingToGraphvizScaleFactor = 0.15
|
|||||||
-- | Convert a map of names and icons, to a list of names and diagrams.
|
-- | Convert a map of names and icons, to a list of names and diagrams.
|
||||||
-- The first argument is the subdiagram map used for the inside of lambdaIcons
|
-- The first argument is the subdiagram map used for the inside of lambdaIcons
|
||||||
-- The second argument is the map of icons that should be converted to diagrams.
|
-- The second argument is the map of icons that should be converted to diagrams.
|
||||||
--makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)]
|
makeNamedMap :: SpecialBackend b => [(Name, SpecialQDiagram b)] -> [(t, Icon)] -> [(t, Bool -> Double -> SpecialQDiagram b)]
|
||||||
|
|
||||||
--
|
|
||||||
-- makeNamedMap ::
|
|
||||||
-- (RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
|
||||||
-- Renderable (Diagrams.TwoD.Text.Text n) b, IsName nm) =>
|
|
||||||
-- [(Name, QDiagram b V2 n Any)]-> [(nm, Icon)] -> [(nm, QDiagram b V2 n Any)]
|
|
||||||
makeNamedMap subDiagramMap =
|
makeNamedMap subDiagramMap =
|
||||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap))
|
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap))
|
||||||
|
|
||||||
@ -179,12 +173,11 @@ connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
|||||||
-- are minimized.
|
-- are minimized.
|
||||||
-- Precondition: the diagrams are already centered
|
-- Precondition: the diagrams are already centered
|
||||||
-- todo: confirm precondition (or use a newtype)
|
-- todo: confirm precondition (or use a newtype)
|
||||||
rotateNodes ::
|
rotateNodes :: SpecialBackend b =>
|
||||||
Semigroup m =>
|
Map.Map Name (Point V2 Double)
|
||||||
Map.Map Name (Point V2 Double)
|
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||||
-> [(Name, Bool -> Double -> QDiagram b V2 Double m)]
|
-> [Connection]
|
||||||
-> [Connection]
|
-> [(Name, SpecialQDiagram b)]
|
||||||
-> [(Name, QDiagram b V2 Double m)]
|
|
||||||
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||||
where
|
where
|
||||||
rotateDiagram (name, originalDia) = (name, nameDiagram name transformedDia)
|
rotateDiagram (name, originalDia) = (name, nameDiagram name transformedDia)
|
||||||
@ -219,12 +212,11 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
|||||||
minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges
|
minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges
|
||||||
|
|
||||||
type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a)
|
type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a)
|
||||||
placeNodes ::
|
placeNodes :: SpecialBackend b =>
|
||||||
(Monoid m, Semigroup m) =>
|
LayoutResult a
|
||||||
LayoutResult a
|
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||||
-> [(Name, Bool -> Double -> QDiagram b V2 Double m)]
|
-> [Connection]
|
||||||
-> [Connection]
|
-> SpecialQDiagram b
|
||||||
-> QDiagram b V2 Double m
|
|
||||||
placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
||||||
where
|
where
|
||||||
(positionMap, _) = getGraph layoutResult
|
(positionMap, _) = getGraph layoutResult
|
||||||
@ -234,12 +226,11 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
|||||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||||
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
||||||
|
|
||||||
doGraphLayout ::
|
doGraphLayout :: SpecialBackend b =>
|
||||||
_ =>
|
Gr Name e
|
||||||
Gr Name e
|
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||||
-> [(Name, Bool -> Double -> QDiagram b V2 Double m)]
|
-> [Connection]
|
||||||
-> [Connection]
|
-> IO (SpecialQDiagram b)
|
||||||
-> IO (QDiagram b V2 Double m)
|
|
||||||
doGraphLayout graph nameDiagramMap edges = do
|
doGraphLayout graph nameDiagramMap edges = do
|
||||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||||
@ -272,19 +263,18 @@ doGraphLayout graph nameDiagramMap edges = do
|
|||||||
where
|
where
|
||||||
--todo: Hack! Using (!!) here relies upon the implementation of Diagrams.TwoD.GraphViz.mkGraph
|
--todo: Hack! Using (!!) here relies upon the implementation of Diagrams.TwoD.GraphViz.mkGraph
|
||||||
-- to name the nodes in order
|
-- to name the nodes in order
|
||||||
(_, unTransformedDia) = (nameDiagramMap !! nodeInt)
|
(_, unTransformedDia) = nameDiagramMap !! nodeInt
|
||||||
dia = unTransformedDia False 0
|
dia = unTransformedDia False 0
|
||||||
|
|
||||||
diaWidth = drawingToGraphvizScaleFactor * (width dia)
|
diaWidth = drawingToGraphvizScaleFactor * width dia
|
||||||
diaHeight = drawingToGraphvizScaleFactor * (height dia)
|
diaHeight = drawingToGraphvizScaleFactor * height dia
|
||||||
circleDiameter' = max diaWidth diaHeight
|
circleDiameter' = max diaWidth diaHeight
|
||||||
circleDiameter = if circleDiameter' <= 0.01 then error ("circleDiameter too small: " ++ show circleDiameter') else circleDiameter'
|
circleDiameter = if circleDiameter' <= 0.01 then error ("circleDiameter too small: " ++ show circleDiameter') else circleDiameter'
|
||||||
|
|
||||||
|
|
||||||
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
||||||
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
||||||
renderDrawing ::
|
renderDrawing :: SpecialBackend b =>
|
||||||
_ =>
|
|
||||||
Drawing -> IO (QDiagram b V2 Double Any)
|
Drawing -> IO (QDiagram b V2 Double Any)
|
||||||
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
||||||
subDiagramMap <- traverse renderSubDrawing subDrawings
|
subDiagramMap <- traverse renderSubDrawing subDrawings
|
||||||
|
@ -23,8 +23,8 @@ import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst)
|
|||||||
import Icons(Icon(..))
|
import Icons(Icon(..))
|
||||||
import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef,
|
import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef,
|
||||||
iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions,
|
iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions,
|
||||||
edgesForRefPortList, iconGraphToDrawing, qualifyNameAndPort, makeApplyGraph,
|
edgesForRefPortList, iconGraphToDrawing, makeApplyGraph,
|
||||||
namesInPattern, lookupReference, deleteBindings, makeEdges, makeEdgesCore,
|
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
||||||
coerceExpressionResult, makeBox, nTupleString, nListString)
|
coerceExpressionResult, makeBox, nTupleString, nListString)
|
||||||
|
|
||||||
-- OVERVIEW --
|
-- OVERVIEW --
|
||||||
@ -100,9 +100,9 @@ evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName)
|
|||||||
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName)
|
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName)
|
||||||
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName)
|
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName)
|
||||||
|
|
||||||
evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
|
-- evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
|
||||||
evalQOp (QVarOp n) = evalQName n
|
-- evalQOp (QVarOp n) = evalQName n
|
||||||
evalQOp (QConOp n) = evalQName n
|
-- evalQOp (QConOp n) = evalQName n
|
||||||
|
|
||||||
qOpToString :: QOp -> String
|
qOpToString :: QOp -> String
|
||||||
qOpToString (QVarOp n) = qNameToString n
|
qOpToString (QVarOp n) = qNameToString n
|
||||||
@ -308,10 +308,11 @@ evalTuple c exps = do
|
|||||||
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
||||||
pure $ makeTextApplyGraph False applyIconName (nTupleString (length exps)) argVals (length exps)
|
pure $ makeTextApplyGraph False applyIconName (nTupleString (length exps)) argVals (length exps)
|
||||||
|
|
||||||
|
makeVarExp :: String -> Exp
|
||||||
makeVarExp = Var . UnQual . Ident
|
makeVarExp = Var . UnQual . Ident
|
||||||
|
|
||||||
evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
||||||
evalListExp c [] = makeBox "[]"
|
evalListExp _ [] = makeBox "[]"
|
||||||
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
||||||
|
|
||||||
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (IconGraph, NameAndPort)
|
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (IconGraph, NameAndPort)
|
||||||
@ -329,6 +330,7 @@ evalRightSection c op e = do
|
|||||||
evalEnums :: EvalContext -> String -> [Exp] -> State IDState (IconGraph, Reference)
|
evalEnums :: EvalContext -> String -> [Exp] -> State IDState (IconGraph, Reference)
|
||||||
evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
|
evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
|
||||||
|
|
||||||
|
makeQVarOp :: String -> QOp
|
||||||
makeQVarOp = QVarOp . UnQual . Ident
|
makeQVarOp = QVarOp . UnQual . Ident
|
||||||
|
|
||||||
desugarDo :: [Stmt] -> Exp
|
desugarDo :: [Stmt] -> Exp
|
||||||
@ -341,7 +343,7 @@ desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
|
|||||||
|
|
||||||
-- TODO: Finish evalRecConstr
|
-- TODO: Finish evalRecConstr
|
||||||
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (IconGraph, Reference)
|
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (IconGraph, Reference)
|
||||||
evalRecConstr c qName updates = evalQName qName c
|
evalRecConstr c qName _ = evalQName qName c
|
||||||
|
|
||||||
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
||||||
evalExp c x = case x of
|
evalExp c x = case x of
|
||||||
@ -364,7 +366,7 @@ evalExp c x = case x of
|
|||||||
RightSection op e -> fmap Right <$> evalRightSection c op e
|
RightSection op e -> fmap Right <$> evalRightSection c op e
|
||||||
RecConstr n updates -> evalRecConstr c n updates
|
RecConstr n updates -> evalRecConstr c n updates
|
||||||
-- TODO: Do RecUpdate correcly
|
-- TODO: Do RecUpdate correcly
|
||||||
RecUpdate e updates -> evalExp c e
|
RecUpdate e _ -> evalExp c e
|
||||||
EnumFrom e -> evalEnums c "enumFrom" [e]
|
EnumFrom e -> evalEnums c "enumFrom" [e]
|
||||||
EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2]
|
EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2]
|
||||||
EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2]
|
EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2]
|
||||||
@ -412,7 +414,7 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
patternGraph = mconcat $ map fst patternVals
|
patternGraph = mconcat $ map fst patternVals
|
||||||
|
|
||||||
(patternEdges, newBinds) =
|
(patternEdges, newBinds) =
|
||||||
partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts
|
partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts
|
||||||
numParameters = length patterns
|
numParameters = length patterns
|
||||||
-- TODO remove coerceExpressionResult here
|
-- TODO remove coerceExpressionResult here
|
||||||
(rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
|
(rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
|
||||||
@ -425,10 +427,10 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
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 input to a pattern.
|
||||||
-- makePatternEdges creates the edges between the patterns and the parameter ports.
|
-- makePatternEdges creates the edges between the patterns and the parameter ports.
|
||||||
makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
|
makePatternEdges :: GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
|
||||||
makePatternEdges lambdaName (_, Right patPort) lamPort =
|
makePatternEdges (_, Right patPort) lamPort =
|
||||||
Left $ makeSimpleEdge (lamPort, patPort)
|
Left $ makeSimpleEdge (lamPort, patPort)
|
||||||
makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort)
|
makePatternEdges (_, Left str) lamPort = Right (str, Right lamPort)
|
||||||
|
|
||||||
|
|
||||||
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
|
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
|
||||||
|
@ -9,14 +9,14 @@ module TranslateCore(
|
|||||||
getUniqueName,
|
getUniqueName,
|
||||||
edgesForRefPortList,
|
edgesForRefPortList,
|
||||||
combineExpressions,
|
combineExpressions,
|
||||||
qualifyNameAndPort,
|
--qualifyNameAndPort,
|
||||||
iconGraphToDrawing,
|
iconGraphToDrawing,
|
||||||
makeApplyGraph,
|
makeApplyGraph,
|
||||||
namesInPattern,
|
namesInPattern,
|
||||||
lookupReference,
|
lookupReference,
|
||||||
deleteBindings,
|
deleteBindings,
|
||||||
makeEdges,
|
makeEdges,
|
||||||
makeEdgesCore,
|
--makeEdgesCore,
|
||||||
coerceExpressionResult,
|
coerceExpressionResult,
|
||||||
makeBox,
|
makeBox,
|
||||||
nTupleString,
|
nTupleString,
|
||||||
@ -91,8 +91,8 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs
|
|||||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
else IconGraph mempty mempty mempty [(str, port)] mempty
|
||||||
Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
||||||
|
|
||||||
qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||||
qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
-- qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
||||||
|
|
||||||
iconGraphToDrawing :: IconGraph -> Drawing
|
iconGraphToDrawing :: IconGraph -> Drawing
|
||||||
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
||||||
|
12
app/Types.hs
12
app/Types.hs
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ConstraintKinds #-}
|
||||||
|
|
||||||
module Types (
|
module Types (
|
||||||
Icon(..),
|
Icon(..),
|
||||||
@ -9,11 +9,14 @@ module Types (
|
|||||||
EdgeEnd(..),
|
EdgeEnd(..),
|
||||||
Drawing(..),
|
Drawing(..),
|
||||||
IDState,
|
IDState,
|
||||||
|
SpecialQDiagram,
|
||||||
|
SpecialBackend,
|
||||||
initialIdState,
|
initialIdState,
|
||||||
getId
|
getId
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude(Name)
|
import Diagrams.Prelude(Name, QDiagram, V2, Any, Renderable, Path)
|
||||||
|
import Diagrams.TwoD.Text(Text)
|
||||||
import Control.Monad.State(State, state)
|
import Control.Monad.State(State, state)
|
||||||
|
|
||||||
-- TYPES --
|
-- TYPES --
|
||||||
@ -48,6 +51,11 @@ data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] deriving (Show)
|
|||||||
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
|
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
|
||||||
newtype IDState = IDState Int deriving (Eq, Show)
|
newtype IDState = IDState Int deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- Note that SpecialBackend is a constraint synonym, not a type synonym.
|
||||||
|
type SpecialBackend b = (Renderable (Path V2 Double) b, Renderable (Text Double) b)
|
||||||
|
|
||||||
|
type SpecialQDiagram b = QDiagram b V2 Double Any
|
||||||
|
|
||||||
initialIdState :: IDState
|
initialIdState :: IDState
|
||||||
initialIdState = IDState 0
|
initialIdState = IDState 0
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user