summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeroenBransen <>2020-09-15 19:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-09-15 19:42:00 (GMT)
commit7c641e70ab9fca5b189e42210a347f4ec02e52a5 (patch)
tree5f17e0f7e758e00ad3a952a3918fa3b8a85f9580
parent4774f3d533be82f06f5f7aa3a3c5b90c07ba4f3f (diff)
version 0.1.2.0HEAD0.1.2.0master
-rwxr-xr-x[-rw-r--r--]LICENSE60
-rwxr-xr-x[-rw-r--r--]Setup.hs4
-rwxr-xr-x[-rw-r--r--]UU/UUAGC/Diagrams.hs287
-rwxr-xr-x[-rw-r--r--]uuagc-diagrams.cabal42
4 files changed, 199 insertions, 194 deletions
diff --git a/LICENSE b/LICENSE
index 5340da5..e8e4923 100644..100755
--- a/LICENSE
+++ b/LICENSE
@@ -1,30 +1,30 @@
-Copyright (c) 2014, Jeroen Bransen
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Jeroen Bransen nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2014, Jeroen Bransen
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Jeroen Bransen nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
index 9a994af..833b4c6 100644..100755
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/UU/UUAGC/Diagrams.hs b/UU/UUAGC/Diagrams.hs
index 60a1ede..f0704d4 100644..100755
--- a/UU/UUAGC/Diagrams.hs
+++ b/UU/UUAGC/Diagrams.hs
@@ -1,141 +1,146 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-
------------------------------------------------------------------------------
--- |
--- Example usage of this package:
---
--- > import UU.UUAGC.Diagrams
--- >
--- > dia :: AGBackend b => AGDiagram b
--- > dia = production ["count", "level"] "Docs" ["html", "count"]
--- > [ child ["count", "level"] "hd" ["html", "count"]
--- > , child ["count", "level"] "tl" ["html", "count"]
--- > ]
--- > # agrule shaftL "lhs.count" "hd.count"
--- > # agrule shaftL "lhs.level" "hd.level"
--- > # agrule shaftR "lhs.level" "tl.level"
--- > # agrule shaftL "hd.html" "lhs.html"
--- > # agrule shaftR "tl.html" "lhs.html"
--- > # agrule shaftR "tl.count" "lhs.count"
--- > # agrule shaftT "hd.count" "tl.count"
---
------------------------------------------------------------------------------
-
-module UU.UUAGC.Diagrams
- (production, child, agrule, indrule,
- shaftL, shaftR, shaftT, shaftB, shaftD,
- (#),
- AGDiagram, AGBackend, Child) where
-
-import Diagrams.Prelude
-import Graphics.SVGFonts (textSVG_, Spacing (..), TextOpts (..), lin2, Mode (..))
-import Data.List (isPrefixOf)
-
--- | Construct a diagram for a full production, given its inherited attributes,
--- name, synthesized attributes and children
-production :: AGBackend b =>
- [String] -> String -> [String] -> [Child b] -> AGDiagram b
-production = node True
-
--- | Child with backend @b@, this type has been left abstract on purpose.
-newtype Child b = Child { unChild :: AGDiagram b }
-
--- | Construct a child given its inherited attributes, name and sythesized
--- attributes.
-child :: AGBackend b => [String] -> String -> [String] -> Child b
-child i n s = Child $ node False i n s []
-
--- | Construct an arrow between two attributes. The first argument specifies
--- the shape of the arrow and can be 'shaftL', 'shaftR', 'shaftT', 'shaftB'
--- of 'shaftD', or a special trial constructed with the diagrams library.
-agrule :: AGBackend b =>
- Trail R2 -> String -> String -> AGDiagram b -> AGDiagram b
-agrule sh s1 s2 = connectPerim' (with & headLength .~ (Normalized 0.025) & arrowShaft .~ sh) n1 n2 (tb t1) (tb t2) where
- t1 = "lhs." `isPrefixOf` s1
- t2 = "lhs." `isPrefixOf` s2
- n1 | '.' `notElem` s1 = s1 -- terminal
- | t1 = s1 ++ ".inh"
- | otherwise = s1 ++ ".syn"
- n2 = if t2 then s2 ++ ".syn" else s2 ++ ".inh"
- tb False = 90 @@ deg
- tb True = 270 @@ deg
-
--- | Construct an induced dependency arrow between two attributes, similar to
--- 'agrule' but with an explicit trial.
-indrule :: AGBackend b => String -> String -> AGDiagram b -> AGDiagram b
-indrule s1 s2 = connectPerim' (with & headLength .~ (Normalized 0.025) & arrowShaft .~ shaftB & shaftStyle %~ dashed . opacity 0.5) n1 n2 tb tb where
- t = "lhs." `isPrefixOf` s1
- n1 = if t then s1 ++ ".syn" else s1 ++ ".inh"
- n2 = if t then s2 ++ ".inh" else s2 ++ ".syn"
- tb = if t then 90 @@ deg else 270 @@ deg
- dashed = dashingN [0.01,0.01] 0
-
-shaftL, shaftR, shaftT, shaftB, shaftD :: Trail R2
-
--- | Line that first moves left and then right
-shaftL = fromSegments [bezier3 (r2 (0.5,0.3)) (r2 (0.5,-0.3)) (r2 (1,0))]
-
--- | Line that first moves right and then left
-shaftR = fromSegments [bezier3 (r2 (0.5,-0.3)) (r2 (0.5,0.3)) (r2 (1,0))]
-
--- | Top half of a circle
-shaftT = arcCW (0 @@ turn) (3/5 @@ turn)
-
--- | Bottom half of a circle
-shaftB = arc (0 @@ turn) (2/5 @@ turn)
-
--- | Straight line
-shaftD = straightShaft
-
-
--- A bit ugly, but now user doesn't need to import diagrams package for just the types
-type AGDiagram b = Diagram b R2
-class (Renderable (Path R2) b, Backend b R2) => AGBackend b where
-instance (Renderable (Path R2) b, Backend b R2) => AGBackend b
-
-
-attr :: AGBackend b =>
- String -> Bool -> (String -> String) -> AGDiagram b
-attr s t f = stack t (unitSquare # named (f s) # lc black) (text' 0.7 s) where
- stack True a b = beside unitY a (b === strutY 0.2)
- stack False a b = beside (negateV unitY) a (strutY 0.2 === b)
-
--- | Helper function for drawing a node
-node :: AGBackend b =>
- Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
-node top inh s syn ch = res # applyAll lines where
- res = toprow
- ===
- (if null ch then mempty else strutY 2)
- ===
- (hcats 1.5 $ map unChild ch) # centerX
- lines = alines ++ chLines
- chLines = [ line name (getName $ unChild c) # lc grey | c <- ch ]
- hcats s = hcat' (with & sep .~ s)
- els = inhs ++ [lhs] ++ syns
- toprow = beside unitX (
- beside (negateV unitX) lhs
- (hcats 0.3 inhs ||| strutX 0.3))
- (strutX 0.3 ||| hcats 0.3 syns)
- inhs = map (\i -> attr i top (\n -> name ++ "." ++ n ++ ".inh")) inh
- syns = map (\s -> attr s top (\n -> name ++ "." ++ n ++ ".syn")) syn
- alines = zipWith line (map getName els) (map getName $ tail els) # lc grey
- name = if top then "lhs" else s
- lhs = beside (negateV unitY) (
- beside unitY
- (circle 0.5 # named name # lc grey)
- (if top then (text' 0.9 s === strutY 0.1) else mempty))
- (strutY 0.1 === text' 0.9 name)
-
-text' :: AGBackend b =>
- Double -> String -> AGDiagram b
-text' d s = (textSVG_ (TextOpts s lin2 INSIDE_H KERN False d d)) # lw none # fc black # centerX
-
-line :: (IsName n1, IsName n2, AGBackend b) =>
- n1 -> n2 -> AGDiagram b -> AGDiagram b
-line a b = connectOutside' (with & arrowHead .~ noHead) a b
-
-getName :: AGDiagram b -> Name
-getName = fst . head . names
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Example usage of this package:
+--
+-- > import UU.UUAGC.Diagrams
+-- >
+-- > dia :: AGBackend b => AGDiagram b
+-- > dia = production ["count", "level"] "Docs" ["html", "count"]
+-- > [ child ["count", "level"] "hd" ["html", "count"]
+-- > , child ["count", "level"] "tl" ["html", "count"]
+-- > ]
+-- > # agrule shaftL "lhs.count" "hd.count"
+-- > # agrule shaftL "lhs.level" "hd.level"
+-- > # agrule shaftR "lhs.level" "tl.level"
+-- > # agrule shaftL "hd.html" "lhs.html"
+-- > # agrule shaftR "tl.html" "lhs.html"
+-- > # agrule shaftR "tl.count" "lhs.count"
+-- > # agrule shaftT "hd.count" "tl.count"
+--
+-----------------------------------------------------------------------------
+
+module UU.UUAGC.Diagrams
+ (production, child, agrule, indrule,
+ shaftL, shaftR, shaftT, shaftB, shaftD,
+ (#),
+ AGDiagram, AGBackend, Child) where
+
+import Diagrams.Prelude
+import Graphics.SVGFonts (textSVG_, Spacing (..), TextOpts (..), lin2, Mode (..))
+import Data.List (isPrefixOf)
+import System.IO.Unsafe (unsafePerformIO)
+
+-- | Construct a diagram for a full production, given its inherited attributes,
+-- name, synthesized attributes and children
+production :: AGBackend b =>
+ [String] -> String -> [String] -> [Child b] -> AGDiagram b
+production = node True
+
+-- | Child with backend @b@, this type has been left abstract on purpose.
+newtype Child b = Child { unChild :: AGDiagram b }
+
+-- | Construct a child given its inherited attributes, name and sythesized
+-- attributes.
+child :: AGBackend b => [String] -> String -> [String] -> Child b
+child i n s = Child $ node False i n s []
+
+-- | Construct an arrow between two attributes. The first argument specifies
+-- the shape of the arrow and can be 'shaftL', 'shaftR', 'shaftT', 'shaftB'
+-- of 'shaftD', or a special trial constructed with the diagrams library.
+agrule :: AGBackend b =>
+ Trail V2 Double -> String -> String -> AGDiagram b -> AGDiagram b
+agrule sh s1 s2 = connectPerim' (with & headLength .~ (normalized 0.025) & arrowShaft .~ sh) n1 n2 (tb t1) (tb t2) where
+ t1 = "lhs." `isPrefixOf` s1
+ t2 = "lhs." `isPrefixOf` s2
+ n1 | '.' `notElem` s1 = s1 -- terminal
+ | t1 = s1 ++ ".inh"
+ | otherwise = s1 ++ ".syn"
+ n2 = if t2 then s2 ++ ".syn" else s2 ++ ".inh"
+ tb False = 90 @@ deg
+ tb True = 270 @@ deg
+
+-- | Construct an induced dependency arrow between two attributes, similar to
+-- 'agrule' but with an explicit trial.
+indrule :: AGBackend b => String -> String -> AGDiagram b -> AGDiagram b
+indrule s1 s2 = connectPerim' (with & headLength .~ (normalized 0.025) & arrowShaft .~ shaftB & shaftStyle %~ dashed . opacity 0.5) n1 n2 tb tb where
+ t = "lhs." `isPrefixOf` s1
+ n1 = if t then s1 ++ ".syn" else s1 ++ ".inh"
+ n2 = if t then s2 ++ ".inh" else s2 ++ ".syn"
+ tb = if t then 90 @@ deg else 270 @@ deg
+ dashed = dashingN [0.01,0.01] 0
+
+shaftL, shaftR, shaftT, shaftB, shaftD :: Trail V2 Double
+
+-- | Line that first moves left and then right
+shaftL = fromSegments [bezier3 (r2 (0.5,0.3)) (r2 (0.5,-0.3)) (r2 (1,0))]
+
+-- | Line that first moves right and then left
+shaftR = fromSegments [bezier3 (r2 (0.5,-0.3)) (r2 (0.5,0.3)) (r2 (1,0))]
+
+-- | Top half of a circle
+shaftT = arc xDir (-3/5 @@ turn)
+
+-- | Bottom half of a circle
+shaftB = arc xDir (2/5 @@ turn)
+
+-- | Straight line
+shaftD = straightShaft
+
+
+-- A bit ugly, but now user doesn't need to import diagrams package for just the types
+type AGDiagram b = QDiagram b V2 Double Any
+class (Renderable (Path V2 Double) b, Backend b (V b) Double) => AGBackend b where
+instance (Renderable (Path V2 Double) b, Backend b (V b) Double) => AGBackend b
+
+
+attr :: AGBackend b =>
+ String -> Bool -> (String -> String) -> AGDiagram b
+attr s t f = stack t (unitSquare # named (f s) # lc black) (text' 0.7 s) where
+ stack True a b = beside unitY a (b === strutY 0.2)
+ stack False a b = beside (-unitY) a (strutY 0.2 === b)
+
+-- | Helper function for drawing a node
+node :: AGBackend b =>
+ Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
+node top inh s syn ch = res # applyAll lines where
+ res = toprow
+ ===
+ (if null ch then mempty else strutY 2)
+ ===
+ (hcats 1.5 $ map unChild ch) # centerX
+ lines = alines ++ chLines
+ chLines = [ line name (getName $ unChild c) # lc grey | c <- ch ]
+ hcats s = hcat' (with & sep .~ s)
+ els = inhs ++ [lhs] ++ syns
+ toprow = beside unitX (
+ beside (-unitX) lhs
+ (hcats 0.3 inhs ||| strutX 0.3))
+ (strutX 0.3 ||| hcats 0.3 syns)
+ inhs = map (\i -> attr i top (\n -> name ++ "." ++ n ++ ".inh")) inh
+ syns = map (\s -> attr s top (\n -> name ++ "." ++ n ++ ".syn")) syn
+ alines = zipWith line (map getName els) (map getName $ tail els) # lc grey
+ name = if top then "lhs" else s
+ lhs = beside (-unitY) (
+ beside unitY
+ (circle 0.5 # named name # lc grey)
+ (if top then (text' 0.9 s === strutY 0.1) else mempty))
+ (strutY 0.1 === text' 0.9 name)
+
+{-# NOINLINE lin2' #-}
+lin2' = unsafePerformIO lin2
+
+text' :: AGBackend b =>
+ Double -> String -> AGDiagram b
+text' d s = (textSVG_ (TextOpts lin2' INSIDE_H KERN False d d) s) # lw none # fc black # centerX
+
+line :: (IsName n1, IsName n2, AGBackend b) =>
+ n1 -> n2 -> AGDiagram b -> AGDiagram b
+line a b = connectOutside' (with & arrowHead .~ noHead) a b
+
+getName :: AGDiagram b -> Name
+getName = fst . head . names
diff --git a/uuagc-diagrams.cabal b/uuagc-diagrams.cabal
index e4b62a7..6cbfe12 100644..100755
--- a/uuagc-diagrams.cabal
+++ b/uuagc-diagrams.cabal
@@ -1,21 +1,21 @@
-name: uuagc-diagrams
-version: 0.1.1.0
-synopsis: Utility for drawing attribute grammar pictures with the diagrams package
--- description:
-license: BSD3
-license-file: LICENSE
-author: Jeroen Bransen
-maintainer: J.Bransen@uu.nl
--- copyright:
-category: Graphics
-build-type: Simple
--- extra-source-files:
-cabal-version: >=1.10
-
-library
- exposed-modules: UU.UUAGC.Diagrams
- -- other-modules:
- -- other-extensions:
- build-depends: base >=4.7 && <4.8, diagrams-lib >= 1.1, SVGFonts >= 1.4
- -- hs-source-dirs:
- default-language: Haskell2010 \ No newline at end of file
+name: uuagc-diagrams
+version: 0.1.2.0
+synopsis: Utility for drawing attribute grammar pictures with the diagrams package
+-- description:
+license: BSD3
+license-file: LICENSE
+author: Jeroen Bransen
+maintainer: J.Bransen@uu.nl
+-- copyright:
+category: Graphics
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+
+library
+ exposed-modules: UU.UUAGC.Diagrams
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base >=4.7 && <4.15, diagrams-lib >= 1.4 && <1.5, SVGFonts >= 1.7 && <1.8
+ -- hs-source-dirs:
+ default-language: Haskell2010