Remove the backend as an import for all files except Main.hs. Add type signitures.

2024-11-30 05:47:46 +03:00 · 2016-01-22 19:42:15 -08:00 · 2016-01-22 19:42:15 -08:00 · 5e34428b50
commit 5e34428b50
parent 041032dc94
4 changed files with 119 additions and 26 deletions
--- a/app/Icons.hs
+++ b/app/Icons.hs
@ -1,11 +1,9 @@
-{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, RankNTypes #-}
 module Icons
    (
    Icon(..),
    apply0Dia,
    iconToDiagram,
-    --drawIconAndPorts,
-    --drawIconsAndPortNumbers,
    nameDiagram,
    textBox,
    enclosure,
@ -19,8 +17,10 @@ module Icons
    ) where

 import Diagrams.Prelude
-import Diagrams.Backend.SVG(B)
+-- import Diagrams.Backend.SVG(B)
+import Diagrams.TwoD.Text(Text)
 import Data.Maybe (fromMaybe)
+import Data.Typeable(Typeable)

 import Types(Icon(..), Edge(..))

@ -80,10 +80,15 @@ randomColorScheme = ColorStyle {
  regionPerimC = cyan
 }

+lineCol :: (Floating a, Ord a) => Colour a
 lineCol = lineC colorScheme

 -- FUNCTIONS --

+iconToDiagram ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b,
+      Renderable (Text n) b) =>
+     Icon -> [(Name, QDiagram b V2 n Any)] -> QDiagram b V2 n Any
 iconToDiagram Apply0Icon _ = apply0Dia
 iconToDiagram (Apply0NIcon n) _ = apply0NDia n
 iconToDiagram ResultIcon _ = resultIcon
@ -96,18 +101,24 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
    dia = fromMaybe (error "iconToDiagram: subdiagram not found") $ lookup diagramName nameToSubdiagramMap

 -- | 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 name dia = name .>> (dia # named name)

 -- | 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 :: Int -> Diagram B
+makePort :: (Floating n, Ord n, Semigroup m, Metric v) => Int -> QDiagram b v n m
 makePort x = mempty # named x
 --makePort x = circle 0.2 # 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..])
+  atPoints points (map makePort ([0,1..] :: [Int]))

 -- CONSTANTS --
 defaultLineWidth = 0.15
@ -116,18 +127,32 @@ defaultLineWidth = 0.15
 circleRadius = 0.5
 apply0LineWidth = defaultLineWidth

--resultCircle :: Diagram B
+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 :: Diagram B
+apply0Triangle ::
+   (Typeable (N b), Transformable b, HasStyle b, TrailLike b,
+      V b ~ V2) =>
+     b
 apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc (apply0C colorScheme) # lw none

--apply0Line :: Diagram B
+apply0Line ::
+   (Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
 apply0Line = rect apply0LineWidth (2 * circleRadius) # fc lineCol # lw none

--apply0Dia :: Diagram B
+--apply0Dia :: (Juxtaposable a, Semigroup a) => GeneralDiagram a
+apply0Dia ::
+   (RealFloat n, Typeable n, Monoid m, Semigroup m,
+      TrailLike (QDiagram b V2 n m)) =>
+     QDiagram b V2 n m
 apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY

+apply0PortLocations :: Floating a => [P2 a]
 apply0PortLocations = map p2 [
  (circleRadius + apply0LineWidth + triangleWidth, 0),
  (lineCenter,circleRadius),
@ -139,7 +164,10 @@ apply0PortLocations = map p2 [

 -- apply0N Icon--

-apply0NDia :: Int -> Diagram B
+apply0NDia ::
+   (RealFloat n, Typeable n, Monoid m, Semigroup m,
+      TrailLike (QDiagram b V2 n m)) =>
+     Int -> QDiagram b V2 n m
 apply0NDia n = finalDia # centerXY where
  seperation = circleRadius * 1.5
  trianglePortsCircle = hcat [
@ -157,11 +185,19 @@ textBoxFontSize = 1
 monoLetterWidthToHeightFraction = 0.6
 textBoxHeightFactor = 1.1

--textBox :: String -> Diagram B
+textBox ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b,
+      Renderable (Text n) b) =>
+      String -> QDiagram b V2 n Any
 textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC 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 textColor boxColor t =
  text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
  <> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor
@ -171,38 +207,58 @@ 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 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
 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 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 = unitSquare # lw none # fc (lamArgResC colorScheme)

 -- BRANCH ICON --
-branchIcon :: Diagram B
+branchIcon :: GeneralDiagram a
 branchIcon = circle 0.3 # fc lineCol # lc lineCol

 -- GUARD ICON --
 guardSize = 0.7
-guardTriangle :: Int -> Diagram B
+
+guardTriangle ::
+   (Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
+      TrailLike (QDiagram b V2 n m)) =>
+     Int -> QDiagram b V2 n m
 guardTriangle x =
  ((triangleAndPort ||| (hrule (guardSize * 0.8) # lc lineCol # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
  where
    triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
      # rotateBy (1/8)# lc lineCol # lwG defaultLineWidth # alignT # alignR

-guardLBracket :: Int -> Diagram B
+guardLBracket ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
+     Int -> QDiagram b V2 n Any
 guardLBracket x = ell # alignT # alignL <> makePort x
  where
    ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
@ -213,7 +269,9 @@ guardLBracket x = ell # alignT # alignL <> makePort x
 -- Port 1: Bottom result port
 -- Ports 3,5...: The left ports for the booleans
 -- Ports 2,4...: The right ports for the values
-guardIcon :: Int -> Diagram B
+guardIcon ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
+     Int -> QDiagram b V2 n Any
 guardIcon n = centerXY $ makePort 1 <> alignB (vcat (take n trianglesAndBrackets # alignT) <> makePort 0)
  where
    --guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
--- a/app/Main.hs
+++ b/app/Main.hs
@ -235,9 +235,9 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges []
 main1 :: IO ()
 main1 = do
  placedNodes <- renderDrawing factLam1Drawing
-  mainWith (placedNodes # bgFrame 1 (backgroundC colorScheme))
+  mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)

-main2 = mainWith (apply0NDia 3 # bgFrame 0.1 black)
+main2 = mainWith ((apply0NDia 3 # bgFrame 0.1 black)  :: Diagram B)

 main :: IO ()
 main = main1
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -6,7 +6,8 @@ module Rendering (

 import Diagrams.Prelude
 import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
-import Diagrams.Backend.SVG(B)
+import Diagrams.TwoD.Text(Text)
+--import Diagrams.Backend.SVG(B)

 import qualified Data.GraphViz as GV
 import qualified Data.GraphViz.Attributes.Complete as GVA
@ -25,7 +26,12 @@ import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
 -- | 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 :: 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 subDiagramMap =
  map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))

@ -68,9 +74,12 @@ getArrowOpts (t, h) = arrowOptions
      & shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
      & lookupTail t & lookupHead h

+plainLine :: (RealFloat n, Typeable n) => ArrowOpts n
 plainLine = getArrowOpts (EndNone, EndNone)

-connectMaybePorts :: Edge -> Diagram B -> Diagram B
+connectMaybePorts ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
+     Edge -> QDiagram b V2 n Any -> QDiagram b V2 n Any
 connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) ends) =
  connect'
  (getArrowOpts ends)
@ -83,7 +92,9 @@ connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) ends) =
 connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) ends) =
  connectOutside' (getArrowOpts ends) icon0 icon1

-makeConnections :: [Edge] -> Diagram B -> Diagram B
+makeConnections ::
+   (RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
+     [Edge] -> QDiagram b V2 n Any -> QDiagram b V2 n Any
 makeConnections edges = applyAll connections
  where
    connections = map connectMaybePorts edges
@ -133,7 +144,12 @@ getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
 -- are minimized.
 -- Precondition: the diagrams are already centered
 -- todo: confirm precondition (or use a newtype)
-rotateNodes :: Map.Map Name (Point V2 Double) -> [(Name, Diagram B)] -> [Connection] -> [(Name, Diagram B)]
+rotateNodes ::
+   Semigroup m =>
+     Map.Map Name (Point V2 Double)
+     -> [(Name, QDiagram b V2 Double m)]
+     -> [Connection]
+     -> [(Name, QDiagram b V2 Double m)]
 rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
  where
    rotateDiagram (name, dia) = (name, diaToUse)
@ -144,7 +160,7 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
        diaToUse = if flippedDist < unflippedDist
          then rotateBy flippedAngle flippedDia
          else rotateBy unflippedAngle dia
-        minAngleForDia :: Diagram B -> (Double, Double)
+        --minAngleForDia :: Diagram B -> (Double, Double)
        minAngleForDia dia = minAngle where
        --ports = Debug.Trace.trace ((show $ names dia) ++ "\n") $ names dia
          ports = names dia
@ -158,6 +174,13 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
            (lookup (name .> x) ports)
          minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges

+type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a)
+placeNodes ::
+   (Monoid m, Semigroup m) =>
+     LayoutResult a
+     -> [(Name, QDiagram b V2 Double m)]
+     -> [Connection]
+     -> QDiagram b V2 Double m
 placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
  where
    (positionMap, _) = getGraph layoutResult
@ -167,7 +190,13 @@ 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, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r
+doGraphLayout ::
+   (Monoid m, Semigroup m) =>
+     Gr Name e
+     -> [(Name, QDiagram b V2 Double m)]
+     -> (QDiagram b V2 Double m -> r)
+     -> [Connection]
+     -> IO r
 doGraphLayout graph nameDiagramMap connectNodes edges = do
  layoutResult <- layoutGraph' layoutParams GVA.Neato graph
  --  layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
@ -193,7 +222,10 @@ doGraphLayout graph nameDiagramMap connectNodes edges = do
        -- to name the nodes in order
        (_, dia) = nameDiagramMap !! nodeInt

-renderDrawing :: Drawing -> IO (Diagram B)
+renderDrawing ::
+   (Renderable (Path V2 Double) b,
+      Renderable (Text Double) b) =>
+     Drawing -> IO (QDiagram b V2 Double Any)
 renderDrawing (Drawing nameIconMap edges subDrawings) = do
  subDiagramMap <- mapM subDrawingMapper subDrawings
  let diagramMap = makeNamedMap subDiagramMap nameIconMap
--- a/app/Util.hs
+++ b/app/Util.hs
@ -21,6 +21,7 @@ mapFst f = map (first f)
 toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
 toNames = mapFst toName

+noEnds :: (EdgeEnd, EdgeEnd)
 noEnds = (EndNone, EndNone)

 -- Edge constructors --
@ -39,6 +40,8 @@ iconToIcon a   c   = Edge (toName a, Nothing, toName c, Nothing) noEnds
 iconToIconEnds :: (IsName a, IsName b) => a -> EdgeEnd -> b -> EdgeEnd -> Edge
 iconToIconEnds a b c d = Edge (toName a, Nothing, toName c, Nothing) (b, d)

+iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
 iconHeadToPort a endHead c d = Edge (toName a, Nothing, toName c, Just d) (EndNone, endHead)

+iconTailToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
 iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone)