diff --git a/app/Icons.hs b/app/Icons.hs index e5b4c21..869bfc7 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -22,9 +22,12 @@ import Diagrams.Prelude import Diagrams.TwoD.Text(Text) import Data.Typeable(Typeable) -import Types(Icon(..), Edge) +import Types(Icon(..), SpecialQDiagram, SpecialBackend) import Util(fromMaybeError) +-- TYPES -- +type TransformableDia b = (Bool -> Double -> SpecialQDiagram b) + -- COLO(U)RS -- colorScheme :: (Floating a, Ord a) => ColorStyle a colorScheme = colorOnBlackScheme @@ -109,19 +112,12 @@ randomColorScheme = ColorStyle { lineCol :: (Floating a, Ord a) => Colour a lineCol = lineC colorScheme -type TransformableDia a b c d = (Bool -> Double -> QDiagram a b c d) - -- FUNCTIONS -- -- Optimization: The apply0NDia's can be memoized. --- iconToDiagram :: --- (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 :: SpecialBackend b => Icon -> [(Name, SpecialQDiagram b)] -> Bool -> Double -> SpecialQDiagram b iconToDiagram (ApplyAIcon n) _ = identDiaFunc $ applyADia n -iconToDiagram (PAppIcon n str) _ = diaFunc $ pAppDia n str -iconToDiagram (TextApplyAIcon n str) _ = diaFunc $ textApplyADia n str +iconToDiagram (PAppIcon n str) _ = pAppDia n str +iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str iconToDiagram ResultIcon _ = identDiaFunc resultIcon iconToDiagram BranchIcon _ = identDiaFunc branchIcon iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s @@ -135,41 +131,22 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = where 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 -identDiaFunc :: _ => QDiagram b V2 n m -> TransformableDia b V2 n m +identDiaFunc :: SpecialQDiagram b -> TransformableDia b 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. -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) -- | 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. -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 = circle 0.2 # fc green # named x -- Note, the version of makePort below seems to have a different type. --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 -- defaultLineWidth :: (Fractional a) => a defaultLineWidth = 0.15 @@ -178,54 +155,23 @@ defaultLineWidth = 0.15 circleRadius :: (Fractional a) => a 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 :: (Typeable (N b), Transformable b, HasStyle b, TrailLike b, V b ~ V2) => b apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # lw none -apply0Line :: - (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 :: (SpecialBackend b) => SpecialQDiagram b portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none --- apply0N Icon-- +-- applyA Icon-- -- | apply0N port locations: -- Port 0: Function -- Port 1: Result -- Ports 2,3..: Arguments coloredApplyADia :: - (RealFloat n, Typeable n, Monoid m, Semigroup m, - TrailLike (QDiagram b V2 n m)) => - Colour Double -> Int -> QDiagram b V2 n m ---applyADia 1 = applyA0Dia + (SpecialBackend b) => + Colour Double -> Int -> SpecialQDiagram b coloredApplyADia appColor n = finalDia # centerXY where seperation = circleRadius * 1.5 trianglePortsCircle = hcat [ @@ -238,18 +184,23 @@ coloredApplyADia appColor n = finalDia # centerXY where topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL finalDia = topAndBottomLine === allPorts === topAndBottomLine +applyADia :: SpecialBackend b => Int -> SpecialQDiagram b applyADia = coloredApplyADia (apply0C colorScheme) ---textApplyADia :: _ => Int -> String -> QDiagram b V2 n m -textApplyADia :: _ => - Int -> String -> TransformableDia b V2 Double Any +textApplyADia :: SpecialBackend b => + Int -> String -> TransformableDia b textApplyADia = generalTextAppDia (textBoxTextC colorScheme) (apply0C colorScheme) -pAppDia :: _ => - Int -> String -> TransformableDia b V2 Double Any +pAppDia :: SpecialBackend b => + Int -> String -> TransformableDia b 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 rotateDia = rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str)) ||| coloredApplyADia borderCol numArgs @@ -265,25 +216,19 @@ monoLetterWidthToHeightFraction = 0.61 textBoxHeightFactor :: (Fractional a) => a textBoxHeightFactor = 1.1 -textBox :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b, - Renderable (Text n) b) => - String -> QDiagram b V2 n Any +textBox :: SpecialBackend b => + String -> SpecialQDiagram b textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme) -bindTextBox :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b, - Renderable (Text n) b) => - String -> QDiagram b V2 n Any +bindTextBox :: SpecialBackend b => + String -> SpecialQDiagram b bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme) -- Since the normal SVG text has no size, some hackery is needed to determine -- the size of the text's bounding box. -coloredTextBox :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b, - Renderable (Diagrams.TwoD.Text.Text n) b) => - Colour Double - -> AlphaColour Double -> String -> QDiagram b V2 n Any +coloredTextBox :: SpecialBackend b => + Colour Double + -> AlphaColour Double -> String -> SpecialQDiagram b coloredTextBox textColor boxColor t = text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize) <> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth) @@ -293,67 +238,57 @@ coloredTextBox textColor boxColor t = + (textBoxFontSize * 0.2) -- ENCLOSING REGION -- -enclosure :: - (Floating n, Ord n, Typeable n, Monoid m, Semigroup m, - TrailLike (QDiagram b V2 n m)) => - QDiagram b V2 n m -> QDiagram b V2 n m +enclosure :: SpecialBackend b => + SpecialQDiagram b -> SpecialQDiagram b enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth -- LAMBDA ICON -- -- Don't use === here to put the port under the text box since mempty will stay -- at the origin of the text box. lambdaIcon :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b, - Renderable (Diagrams.TwoD.Text.Text n) b) => - Int -> QDiagram b V2 n Any + SpecialBackend b => + Int -> SpecialQDiagram b lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x -- LAMBDA REGION -- -- | 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. -lambdaRegion :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b, - Renderable (Diagrams.TwoD.Text.Text n) b) => - Int -> QDiagram b V2 n Any -> QDiagram b V2 n Any +lambdaRegion :: SpecialBackend b => + Int -> SpecialQDiagram b -> SpecialQDiagram b lambdaRegion n dia = centerXY $ lambdaIcons # centerX === (enclosure dia # centerX) where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..])) -- RESULT ICON -- -resultIcon :: - (Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b +resultIcon :: SpecialBackend b => SpecialQDiagram b resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme) -- BRANCH ICON -- -branchIcon :: GeneralDiagram a +branchIcon :: SpecialBackend b => SpecialQDiagram b branchIcon = circle circleRadius # fc lineCol # lc lineCol # lw none -- GUARD ICON -- guardSize :: (Fractional a) => a guardSize = 0.7 -guardTriangle :: - (Floating n, Ord n, Typeable n, Monoid m, Semigroup m, - TrailLike (QDiagram b V2 n m)) => - Int -> QDiagram b V2 n m +guardTriangle :: SpecialBackend b => + Int -> SpecialQDiagram b guardTriangle x = ((triangleAndPort ||| (hrule (guardSize * 0.8) # lwG defaultLineWidth)) # alignR) <> makePort x # alignL where triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize]) # rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR -guardLBracket :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b) => - Int -> QDiagram b V2 n Any +guardLBracket :: SpecialBackend b => + Int -> SpecialQDiagram b guardLBracket x = ell # alignT # alignL <> makePort x where ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)] ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound -generalGuardIcon :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b) => - Colour Double -> (Int -> QDiagram b V2 n Any) -> QDiagram b V2 n Any -> Int -> QDiagram b V2 n Any +generalGuardIcon :: SpecialBackend b => + Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0) where --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 -- Ports 3,5...: The left ports for the booleans -- Ports 2,4...: The right ports for the values -guardIcon :: - (RealFloat n, Typeable n, Renderable (Path V2 n) b) => - Int -> QDiagram b V2 n Any +guardIcon :: SpecialBackend b => + Int -> SpecialQDiagram b guardIcon = generalGuardIcon lineCol guardLBracket mempty -- TODO Improve design to be more than a circle. -caseResult :: (RealFloat n, - Typeable n, - Renderable (Path V2 n) b) => QDiagram b V2 n Any +caseResult :: SpecialBackend b => + SpecialQDiagram b caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where caseCColor = caseRhsC colorScheme -caseC :: (RealFloat n, - Typeable n, - Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any +caseC :: SpecialBackend b => + Int -> SpecialQDiagram b caseC n = caseResult <> makePort n @@ -395,15 +327,15 @@ caseC n = caseResult <> makePort n -- Port 1: Bottom result port -- Ports 3,5...: The left ports for the results -- Ports 2,4...: The right ports for the patterns -caseIcon ::(RealFloat n, - Typeable n, - Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any +caseIcon :: SpecialBackend b => + Int -> SpecialQDiagram b caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult -- | The ports of flatLambdaIcon are: -- 0: Result icon -- 1: The lambda function value -- 2,3.. : The parameters +flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b flatLambda n = finalDia where lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle]) diff --git a/app/Main.hs b/app/Main.hs index f770e00..623156a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -18,40 +18,31 @@ import Translate(translateString, drawingsFromModule) -- Refactor Translate -- Add documentation. --- Update readme. --- Test reference lookup in case rhs. -- 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. -- TODO Later -- --- Visual todos +-- Visual todos: -- 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. +-- 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: -- 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. --- 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 for the identity funciton "y x = x" -- 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. --- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly --- 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. + +--Other todos: +-- Use a nested tree layout. A graph can take an optional (name, Icon) instead of a port. (d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar") d0Icons = toNames diff --git a/app/Rendering.hs b/app/Rendering.hs index 82191da..67390d6 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -6,7 +6,6 @@ module Rendering ( import Diagrams.Prelude import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph') -import Diagrams.TwoD.Text(Text) --import Diagrams.Backend.SVG(B) import qualified Data.GraphViz as GV @@ -22,8 +21,9 @@ import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Typeable(Typeable) --import Data.Word(Word16) -import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..)) -import Types(Edge(..), EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..)) +import Icons(colorScheme, iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..)) +import Types(Edge(..), Icon, EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), + NameAndPort(..), SpecialQDiagram, SpecialBackend) import Util(fromMaybeError) -- 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. -- 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. ---makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram 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 :: SpecialBackend b => [(Name, SpecialQDiagram b)] -> [(t, Icon)] -> [(t, Bool -> Double -> SpecialQDiagram b)] makeNamedMap subDiagramMap = map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap)) @@ -179,12 +173,11 @@ connectedPorts edges name = map edgeToPort $ filter nameInEdge edges -- are minimized. -- Precondition: the diagrams are already centered -- todo: confirm precondition (or use a newtype) -rotateNodes :: - Semigroup m => - Map.Map Name (Point V2 Double) - -> [(Name, Bool -> Double -> QDiagram b V2 Double m)] - -> [Connection] - -> [(Name, QDiagram b V2 Double m)] +rotateNodes :: SpecialBackend b => + Map.Map Name (Point V2 Double) + -> [(Name, Bool -> Double -> SpecialQDiagram b)] + -> [Connection] + -> [(Name, SpecialQDiagram b)] rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap where rotateDiagram (name, originalDia) = (name, nameDiagram name transformedDia) @@ -219,12 +212,11 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a) -placeNodes :: - (Monoid m, Semigroup m) => - LayoutResult a - -> [(Name, Bool -> Double -> QDiagram b V2 Double m)] - -> [Connection] - -> QDiagram b V2 Double m +placeNodes :: SpecialBackend b => + LayoutResult a + -> [(Name, Bool -> Double -> SpecialQDiagram b)] + -> [Connection] + -> SpecialQDiagram b placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes where (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. placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name)) -doGraphLayout :: - _ => - Gr Name e - -> [(Name, Bool -> Double -> QDiagram b V2 Double m)] - -> [Connection] - -> IO (QDiagram b V2 Double m) +doGraphLayout :: SpecialBackend b => + Gr Name e + -> [(Name, Bool -> Double -> SpecialQDiagram b)] + -> [Connection] + -> IO (SpecialQDiagram b) doGraphLayout graph nameDiagramMap edges = do layoutResult <- layoutGraph' layoutParams GVA.Neato graph -- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph @@ -272,19 +263,18 @@ doGraphLayout graph nameDiagramMap edges = do where --todo: Hack! Using (!!) here relies upon the implementation of Diagrams.TwoD.GraphViz.mkGraph -- to name the nodes in order - (_, unTransformedDia) = (nameDiagramMap !! nodeInt) + (_, unTransformedDia) = nameDiagramMap !! nodeInt dia = unTransformedDia False 0 - diaWidth = drawingToGraphvizScaleFactor * (width dia) - diaHeight = drawingToGraphvizScaleFactor * (height dia) + diaWidth = drawingToGraphvizScaleFactor * width dia + diaHeight = drawingToGraphvizScaleFactor * height dia circleDiameter' = max diaWidth diaHeight 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 -- lines connecting ports and icons. IO is needed for the GraphViz layout. -renderDrawing :: - _ => +renderDrawing :: SpecialBackend b => Drawing -> IO (QDiagram b V2 Double Any) renderDrawing (Drawing nameIconMap edges subDrawings) = do subDiagramMap <- traverse renderSubDrawing subDrawings diff --git a/app/Translate.hs b/app/Translate.hs index aaa76b7..022436f 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -23,8 +23,8 @@ import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst) import Icons(Icon(..)) import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef, iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions, - edgesForRefPortList, iconGraphToDrawing, qualifyNameAndPort, makeApplyGraph, - namesInPattern, lookupReference, deleteBindings, makeEdges, makeEdgesCore, + edgesForRefPortList, iconGraphToDrawing, makeApplyGraph, + namesInPattern, lookupReference, deleteBindings, makeEdges, coerceExpressionResult, makeBox, nTupleString, nListString) -- OVERVIEW -- @@ -100,9 +100,9 @@ evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName) evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName) evalQName qName _ = fmap Right <$> makeBox (qNameToString qName) -evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference) -evalQOp (QVarOp n) = evalQName n -evalQOp (QConOp n) = evalQName n +-- evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference) +-- evalQOp (QVarOp n) = evalQName n +-- evalQOp (QConOp n) = evalQName n qOpToString :: QOp -> String qOpToString (QVarOp n) = qNameToString n @@ -308,10 +308,11 @@ evalTuple c exps = do applyIconName <- DIA.toName <$> getUniqueName "tupleApp" pure $ makeTextApplyGraph False applyIconName (nTupleString (length exps)) argVals (length exps) +makeVarExp :: String -> Exp makeVarExp = Var . UnQual . Ident evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort) -evalListExp c [] = makeBox "[]" +evalListExp _ [] = makeBox "[]" evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps) 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 c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps) +makeQVarOp :: String -> QOp makeQVarOp = QVarOp . UnQual . Ident desugarDo :: [Stmt] -> Exp @@ -341,7 +343,7 @@ desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts) -- TODO: Finish evalRecConstr 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 c x = case x of @@ -364,7 +366,7 @@ evalExp c x = case x of RightSection op e -> fmap Right <$> evalRightSection c op e RecConstr n updates -> evalRecConstr c n updates -- TODO: Do RecUpdate correcly - RecUpdate e updates -> evalExp c e + RecUpdate e _ -> evalExp c e EnumFrom e -> evalEnums c "enumFrom" [e] EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2] EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2] @@ -412,7 +414,7 @@ generalEvalLambda context patterns rhsEvalFun = do patternGraph = mconcat $ map fst patternVals (patternEdges, newBinds) = - partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts + partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts numParameters = length patterns -- TODO remove coerceExpressionResult here (rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult @@ -425,10 +427,10 @@ generalEvalLambda context patterns rhsEvalFun = do where -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern. -- makePatternEdges creates the edges between the patterns and the parameter ports. - makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference) - makePatternEdges lambdaName (_, Right patPort) lamPort = + makePatternEdges :: GraphAndRef -> NameAndPort -> Either Edge (String, Reference) + makePatternEdges (_, Right patPort) lamPort = 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) diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index d232c4d..90f42ed 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -9,14 +9,14 @@ module TranslateCore( getUniqueName, edgesForRefPortList, combineExpressions, - qualifyNameAndPort, + --qualifyNameAndPort, iconGraphToDrawing, makeApplyGraph, namesInPattern, lookupReference, deleteBindings, makeEdges, - makeEdgesCore, + --makeEdgesCore, coerceExpressionResult, makeBox, nTupleString, @@ -91,8 +91,8 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs else IconGraph mempty mempty mempty [(str, port)] mempty Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty -qualifyNameAndPort :: String -> NameAndPort -> NameAndPort -qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p +-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort +-- qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p iconGraphToDrawing :: IconGraph -> Drawing iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings diff --git a/app/Types.hs b/app/Types.hs index 93153a1..8fc4fca 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ConstraintKinds #-} module Types ( Icon(..), @@ -9,11 +9,14 @@ module Types ( EdgeEnd(..), Drawing(..), IDState, + SpecialQDiagram, + SpecialBackend, initialIdState, getId ) 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) -- 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. 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 0