{-# 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 (svgText, Spacing (..), TextOpts (..), lin2
                         ,fit_height, set_envelope)
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 :: forall b.
AGBackend b =>
[String] -> String -> [String] -> [Child b] -> AGDiagram b
production = forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
True

-- | Child with backend @b@, this type has been left abstract on purpose.
newtype Child b = Child { forall b. Child b -> AGDiagram b
unChild :: AGDiagram b }

-- | Construct a child given its inherited attributes, name and sythesized
--   attributes.
child :: AGBackend b => [String] -> String -> [String] -> Child b
child :: forall b. AGBackend b => [String] -> String -> [String] -> Child b
child [String]
i String
n [String]
s = forall b. AGDiagram b -> Child b
Child forall a b. (a -> b) -> a -> b
$ forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
False [String]
i String
n [String]
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 :: forall b.
AGBackend b =>
Trail V2 Double -> String -> String -> AGDiagram b -> AGDiagram b
agrule Trail V2 Double
sh String
s1 String
s2 = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
 IsName n2) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
connectPerim' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Measure n)
headLength forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall n. Num n => n -> Measure n
normalized Double
0.025) forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Trail V2 n)
arrowShaft forall s t a b. ASetter s t a b -> b -> s -> t
.~ Trail V2 Double
sh) String
n1 String
n2 (forall {b}. Floating b => Bool -> Angle b
tb Bool
t1) (forall {b}. Floating b => Bool -> Angle b
tb Bool
t2) where
  t1 :: Bool
t1 = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s1
  t2 :: Bool
t2 = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s2
  n1 :: String
n1 | Char
'.' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
s1 = String
s1 -- terminal
     | Bool
t1               = String
s1 forall a. [a] -> [a] -> [a]
++ String
".inh"
     | Bool
otherwise        = String
s1 forall a. [a] -> [a] -> [a]
++ String
".syn"
  n2 :: String
n2 = if Bool
t2 then String
s2 forall a. [a] -> [a] -> [a]
++ String
".syn" else String
s2 forall a. [a] -> [a] -> [a]
++ String
".inh"
  tb :: Bool -> Angle b
tb Bool
False  = b
90 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg
  tb Bool
True   = b
270 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
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 :: forall b.
AGBackend b =>
String -> String -> AGDiagram b -> AGDiagram b
indrule String
s1 String
s2 = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
 IsName n2) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
connectPerim' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Measure n)
headLength forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall n. Num n => n -> Measure n
normalized Double
0.025) forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Trail V2 n)
arrowShaft forall s t a b. ASetter s t a b -> b -> s -> t
.~ Trail V2 Double
shaftB forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Style V2 n)
shaftStyle forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Style V2 Double -> Style V2 Double
dashed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Double -> a -> a
opacity Double
0.5) String
n1 String
n2 Angle Double
tb Angle Double
tb where
  t :: Bool
t = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s1
  n1 :: String
n1 = if Bool
t then String
s1 forall a. [a] -> [a] -> [a]
++ String
".syn" else String
s1 forall a. [a] -> [a] -> [a]
++ String
".inh"
  n2 :: String
n2 = if Bool
t then String
s2 forall a. [a] -> [a] -> [a]
++ String
".inh" else String
s2 forall a. [a] -> [a] -> [a]
++ String
".syn"
  tb :: Angle Double
tb = if Bool
t then Double
90 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg else Double
270 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg
  dashed :: Style V2 Double -> Style V2 Double
dashed  = forall a n.
(N a ~ n, HasStyle a, Typeable n, Num n) =>
[n] -> n -> a -> a
dashingN [N (Style V2 Double)
0.01,N (Style V2 Double)
0.01] N (Style V2 Double)
0

shaftL, shaftR, shaftT, shaftB, shaftD :: Trail V2 Double

-- | Line that first moves left and then right
shaftL :: Trail V2 Double
shaftL = forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments [forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (forall n. (n, n) -> V2 n
r2 (Double
0.5,Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
0.5,-Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
1,Double
0))]

-- | Line that first moves right and then left
shaftR :: Trail V2 Double
shaftR = forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments [forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (forall n. (n, n) -> V2 n
r2 (Double
0.5,-Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
0.5,Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
1,Double
0))]

-- | Top half of a circle
shaftT :: Trail V2 Double
shaftT = forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
Direction V2 n -> Angle n -> t
arc forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir (-Double
3forall a. Fractional a => a -> a -> a
/Double
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | Bottom half of a circle
shaftB :: Trail V2 Double
shaftB = forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
Direction V2 n -> Angle n -> t
arc forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir (Double
2forall a. Fractional a => a -> a -> a
/Double
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | Straight line
shaftD :: Trail V2 Double
shaftD = forall n. OrderedField n => Trail V2 n
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 :: forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
s Bool
t String -> String
f = forall {m} {n} {b}.
(Monoid m, Ord n, Floating n) =>
Bool -> QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
stack Bool
t (forall n t. (InSpace V2 n t, TrailLike t) => t
unitSquare forall a b. a -> (a -> b) -> b
# forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named (String -> String
f String
s) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. Num a => Colour a
black) (forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.7 String
s) where
  stack :: Bool -> QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
stack Bool
True  QDiagram b V2 n m
a QDiagram b V2 n m
b = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside   forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY  QDiagram b V2 n m
a (QDiagram b V2 n m
b forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY n
0.2)
  stack Bool
False QDiagram b V2 n m
a QDiagram b V2 n m
b = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY) QDiagram b V2 n m
a (forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY n
0.2 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== QDiagram b V2 n m
b)

-- | Helper function for drawing a node
node :: AGBackend b =>
        Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node :: forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
top [String]
inh String
s [String]
syn [Child b]
ch = QDiagram b V2 Double Any
res forall a b. a -> (a -> b) -> b
# forall a. [a -> a] -> a -> a
applyAll [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
lines where
  res :: QDiagram b V2 Double Any
res = QDiagram b V2 Double Any
toprow
        forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
===
        (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Child b]
ch then forall a. Monoid a => a
mempty else forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
2)
        forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
===
        (forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
 Monoid a) =>
N a -> [a] -> a
hcats Double
1.5 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall b. Child b -> AGDiagram b
unChild [Child b]
ch) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerX
  lines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
lines = [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
alines forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
chLines
  chLines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
chLines = [ forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line String
name (forall b. AGDiagram b -> Name
getName forall a b. (a -> b) -> a -> b
$ forall b. Child b -> AGDiagram b
unChild Child b
c) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey | Child b
c <- [Child b]
ch ]
  hcats :: N a -> [a] -> a
hcats N a
s = forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
 Monoid' a) =>
CatOpts n -> [a] -> a
hcat' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (CatOpts n) n
sep forall s t a b. ASetter s t a b -> b -> s -> t
.~ N a
s)
  els :: [QDiagram b V2 Double Any]
els = [QDiagram b V2 Double Any]
inhs forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any
lhs] forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any]
syns
  toprow :: QDiagram b V2 Double Any
toprow = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX (
             forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX) QDiagram b V2 Double Any
lhs
               (forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
 Monoid a) =>
N a -> [a] -> a
hcats Double
0.3 [QDiagram b V2 Double Any]
inhs forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
||| forall (v :: * -> *) n b m.
(Metric v, R1 v, OrderedField n) =>
n -> QDiagram b v n m
strutX Double
0.3))
             (forall (v :: * -> *) n b m.
(Metric v, R1 v, OrderedField n) =>
n -> QDiagram b v n m
strutX Double
0.3 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
||| forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
 Monoid a) =>
N a -> [a] -> a
hcats Double
0.3 [QDiagram b V2 Double Any]
syns)
  inhs :: [QDiagram b V2 Double Any]
inhs = forall a b. (a -> b) -> [a] -> [b]
map (\String
i -> forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
i Bool
top (\String
n -> String
name forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
".inh")) [String]
inh
  syns :: [QDiagram b V2 Double Any]
syns = forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
s Bool
top (\String
n -> String
name forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
".syn")) [String]
syn
  alines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
alines = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line (forall a b. (a -> b) -> [a] -> [b]
map forall b. AGDiagram b -> Name
getName [QDiagram b V2 Double Any]
els) (forall a b. (a -> b) -> [a] -> [b]
map forall b. AGDiagram b -> Name
getName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [QDiagram b V2 Double Any]
els) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey
  name :: String
name = if Bool
top then String
"lhs" else String
s
  lhs :: QDiagram b V2 Double Any
lhs = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY) (
          forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY
          (forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle Double
0.5 forall a b. a -> (a -> b) -> b
# forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named String
name forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey)
          (if Bool
top then (forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.9 String
s forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
0.1) else forall a. Monoid a => a
mempty))
        (forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
0.1 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.9 String
name)

{-# NOINLINE lin2' #-}
lin2' :: PreparedFont Double
lin2' = forall a. IO a -> a
unsafePerformIO forall n. (Read n, RealFloat n) => IO (PreparedFont n)
lin2

text' :: AGBackend b =>
         Double -> String -> AGDiagram b
text' :: forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
d String
s = String
s forall a b. a -> (a -> b) -> b
# forall n. RealFloat n => TextOpts n -> String -> PathInRect n
svgText forall d. Default d => d
def { textFont :: PreparedFont Double
textFont = PreparedFont Double
lin2' } forall a b. a -> (a -> b) -> b
# forall n. RealFloat n => n -> PathInRect n -> PathInRect n
fit_height Double
d forall a b. a -> (a -> b) -> b
# forall b n.
(TypeableFloat n, Renderable (Path V2 n) b) =>
PathInRect n -> QDiagram b V2 n Any
set_envelope forall a b. a -> (a -> b) -> b
# forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw forall n. OrderedField n => Measure n
none forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc forall a. Num a => Colour a
black forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerX

line :: (IsName n1, IsName n2, AGBackend b) =>
        n1 -> n2 -> AGDiagram b -> AGDiagram b
line :: forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line n1
a n2
b = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
 IsName n2) =>
ArrowOpts n
-> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any
connectOutside' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (ArrowHT n)
arrowHead forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall n. ArrowHT n
noHead) n1
a n2
b

getName :: AGDiagram b -> Name
getName :: forall b. AGDiagram b -> Name
getName = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) m n b.
(Metric v, Semigroup m, OrderedField n) =>
QDiagram b v n m -> [(Name, [Point v n])]
names