{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Modelling.CdOd.Output (
  cacheCd,
  cacheOd,
  drawCd,
  drawOdFromInstance,
  drawOd,
  ) where

import qualified Data.ByteString.Lazy.UTF8        as LBS (fromString)
import qualified Data.Bimap                       as BM (fromList, lookupR)
import qualified Data.Map                         as M (
  foldrWithKey,
  )
import qualified Diagrams.TwoD.GraphViz           as GV (getGraph)

import Capabilities.Cache               (MonadCache, cache, short)
import Capabilities.Diagrams            (MonadDiagrams (lin, renderDiagram))
import Capabilities.Graphviz (
  MonadGraphviz (errorWithoutGraphviz, layoutGraph'),
  )
import Capabilities.WriteFile           (MonadWriteFile (writeToFile))
import Modelling.Auxiliary.Diagrams (
  arrowheadDiamond,
  arrowheadFilledDiamond,
  arrowheadTriangle,
  arrowheadVee,
  connectWithPath,
  flipArrow,
  text',
  textU,
  veeArrow,
  )
import Modelling.CdOd.Auxiliary.Util (
  alloyInstanceToOd,
  emptyArr,
  underlinedLabel,
  )
import Modelling.CdOd.Types (
  AnyCd,
  AnyClassDiagram (..),
  AnyRelationship,
  CdDrawSettings (..),
  InvalidRelationship (..),
  LimitedLinking (..),
  Link (..),
  Object (..),
  ObjectDiagram (..),
  Od,
  OmittedDefaultMultiplicities (..),
  Relationship (..),
  anonymiseObjects,
  calculateThickAnyRelationships,
  rangeWithDefault,
  )

import Control.Lens                     ((.~))
import Control.Monad                    (guard)
import Control.Monad.Catch              (MonadCatch, MonadThrow)
import Control.Monad.Random (
  RandT,
  RandomGen,
  )
import Control.Monad.Trans              (MonadTrans(lift))
import Data.Bifunctor                   (Bifunctor (second))
import Data.ByteString                  (ByteString)
import Data.Digest.Pure.SHA             (sha1, showDigest)
import Data.Graph.Inductive             (Gr, mkGraph)
import Data.GraphViz (
  DirType (Back, Forward, NoDir),
  GraphvizParams (..),
  Shape (BoxShape),
  arrowFrom,
  arrowTo,
  diamond,
  dirCommand,
  edgeEnds,
  noArrow,
  nonClusteredParams,
  oDiamond,
  shape,
  toLabel,
  toLabelValue,
  undirCommand,
  vee,
  )
import Data.GraphViz.Attributes.Complete (Attribute (..), DPoint (..), Label)
import Data.Function                    ((&))
import Data.List                        (elemIndex)
import Data.Maybe                       (fromJust, fromMaybe, maybeToList)
import Data.Ratio                       ((%))
import Data.Tuple.Extra                 (both)
import Diagrams.Align                   (center)
import Diagrams.Angle                   ((@@), cosA, deg, halfTurn)
import Diagrams.Attributes              (lineWidth, lwL)
import Diagrams.Backend.SVG             (B, svgClass)
import Diagrams.Combinators             (atop, frame)
import Diagrams.Names                   (IsName, named)
import Diagrams.Path                    (Path, reversePath)
import Diagrams.Points                  (Point(..))
import Diagrams.Prelude (
  Diagram,
  Style,
  (^-^),
  applyStyle,
  black,
  local,
  white,
  )
import Diagrams.Transform               (translate)
import Diagrams.TwoD                    (V2, bg, snugCenterXY)
import Diagrams.TwoD.Arrow (
  arrowHead,
  arrowTail,
  headGap,
  headLength,
  tailLength,
  )
import Diagrams.TwoD.Arrowheads         (lineTail)
import Diagrams.TwoD.Attributes         (fc, lc)
import Diagrams.Util                    ((#), with)
import Graphics.SVGFonts.ReadFont       (PreparedFont)
import Language.Alloy.Call              (AlloyInstance)

relationshipArrow
  :: CdDrawSettings
  -> Maybe Attribute
  -> Bool
  -> AnyRelationship String String
  -> [Attribute]
relationshipArrow :: CdDrawSettings
-> Maybe Attribute
-> Bool
-> AnyRelationship String String
-> [Attribute]
relationshipArrow CdDrawSettings {Bool
OmittedDefaultMultiplicities
omittedDefaults :: OmittedDefaultMultiplicities
printNames :: Bool
printNavigations :: Bool
omittedDefaults :: CdDrawSettings -> OmittedDefaultMultiplicities
printNames :: CdDrawSettings -> Bool
printNavigations :: CdDrawSettings -> Bool
..} Maybe Attribute
marking Bool
isThick =
  (InvalidRelationship String String -> [Attribute])
-> (Relationship String String -> [Attribute])
-> AnyRelationship String String
-> [Attribute]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either InvalidRelationship String String -> [Attribute]
forall {nodeName} {relationshipName}.
InvalidRelationship nodeName relationshipName -> [Attribute]
getInvalidArrow Relationship String String -> [Attribute]
forall {nodeName}. Relationship nodeName String -> [Attribute]
getArrow
  where
    getInvalidArrow :: InvalidRelationship nodeName relationshipName -> [Attribute]
getInvalidArrow = \case
      InvalidInheritance {LimitedLinking nodeName
invalidSubClass :: LimitedLinking nodeName
invalidSuperClass :: LimitedLinking nodeName
invalidSubClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSuperClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
..} -> [
        Arrow -> Attribute
arrowTo Arrow
emptyArr,
        Label -> Attribute
TailLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity Maybe (Int, Maybe Int)
forall a. Maybe a
Nothing ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
invalidSubClass,
        Label -> Attribute
HeadLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity Maybe (Int, Maybe Int)
forall a. Maybe a
Nothing ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
invalidSuperClass
        ]
    getArrow :: Relationship nodeName String -> [Attribute]
getArrow = \case
      Inheritance {} -> [Arrow -> Attribute
arrowTo Arrow
emptyArr]
      Composition {String
LimitedLinking nodeName
compositionName :: String
compositionPart :: LimitedLinking nodeName
compositionWhole :: LimitedLinking nodeName
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> [
          Arrow -> Attribute
arrowFrom Arrow
diamond,
          DirType -> Attribute
edgeEnds DirType
Back,
          Label -> Attribute
TailLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
compositionWholeOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
compositionWhole,
          Label -> Attribute
HeadLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
compositionPart
          ]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Maybe Attribute -> [Attribute]
forall a. Maybe a -> [a]
maybeToList Maybe Attribute
marking | Bool
isThick]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
compositionName | Bool
printNames]
      Aggregation {String
LimitedLinking nodeName
aggregationName :: String
aggregationPart :: LimitedLinking nodeName
aggregationWhole :: LimitedLinking nodeName
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> [
          Arrow -> Attribute
arrowFrom Arrow
oDiamond,
          DirType -> Attribute
edgeEnds DirType
Back,
          Label -> Attribute
TailLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
aggregationWholeOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
aggregationWhole,
          Label -> Attribute
HeadLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
aggregationPart
          ]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Maybe Attribute -> [Attribute]
forall a. Maybe a -> [a]
maybeToList Maybe Attribute
marking | Bool
isThick]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
aggregationName | Bool
printNames]
      Association {String
LimitedLinking nodeName
associationName :: String
associationFrom :: LimitedLinking nodeName
associationTo :: LimitedLinking nodeName
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> [Attribute]
associationArrow [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [
          Label -> Attribute
TailLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
associationFrom,
          Label -> Attribute
HeadLabel (Label -> Attribute) -> Label -> Attribute
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity
            (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
            ((Int, Maybe Int) -> Label) -> (Int, Maybe Int) -> Label
forall a b. (a -> b) -> a -> b
$ LimitedLinking nodeName -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking nodeName
associationTo
          ]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Maybe Attribute -> [Attribute]
forall a. Maybe a -> [a]
maybeToList Maybe Attribute
marking | Bool
isThick]
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
associationName | Bool
printNames]
    associationArrow :: [Attribute]
associationArrow
      | Bool
printNavigations = [Arrow -> Attribute
arrowTo Arrow
vee, Double -> Attribute
ArrowSize Double
0.4]
      | Bool
otherwise        = [Arrow -> Attribute
ArrowHead Arrow
noArrow]

multiplicity :: Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity :: Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Label
multiplicity Maybe (Int, Maybe Int)
def = String -> Label
forall a. Labellable a => a -> Label
toLabelValue (String -> Label)
-> ((Int, Maybe Int) -> String) -> (Int, Maybe Int) -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ((Int, Maybe Int) -> Maybe String) -> (Int, Maybe Int) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault Maybe (Int, Maybe Int)
def

cacheCd
  :: (MonadCache m, MonadDiagrams m, MonadGraphviz m)
  => CdDrawSettings
  -> Style V2 Double
  -> AnyCd
  -> FilePath
  -> m FilePath
cacheCd :: forall (m :: * -> *).
(MonadCache m, MonadDiagrams m, MonadGraphviz m) =>
CdDrawSettings -> Style V2 Double -> AnyCd -> String -> m String
cacheCd config :: CdDrawSettings
config@CdDrawSettings{Bool
OmittedDefaultMultiplicities
omittedDefaults :: CdDrawSettings -> OmittedDefaultMultiplicities
printNames :: CdDrawSettings -> Bool
printNavigations :: CdDrawSettings -> Bool
omittedDefaults :: OmittedDefaultMultiplicities
printNames :: Bool
printNavigations :: Bool
..} Style V2 Double
marking AnyCd
syntax String
path =
  String
-> String -> String -> AnyCd -> (AnyCd -> m ByteString) -> m String
forall (m :: * -> *) a.
(MonadCache m, Show a) =>
String -> String -> String -> a -> (a -> m ByteString) -> m String
cache String
path String
ext String
"cd" AnyCd
syntax ((AnyCd -> m ByteString) -> m String)
-> (AnyCd -> m ByteString) -> m String
forall a b. (a -> b) -> a -> b
$ CdDrawSettings -> Style V2 Double -> AnyCd -> m ByteString
forall (m :: * -> *).
(MonadDiagrams m, MonadGraphviz m) =>
CdDrawSettings -> Style V2 Double -> AnyCd -> m ByteString
drawCd CdDrawSettings
config Style V2 Double
marking
  where
    ext :: String
ext = Bool -> String
forall a. Enum a => a -> String
short Bool
printNavigations
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Enum a => a -> String
short Bool
printNames
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Digest SHA1State -> String
forall t. Digest t -> String
showDigest (ByteString -> Digest SHA1State
sha1 (ByteString -> Digest SHA1State)
-> (String -> ByteString) -> String -> Digest SHA1State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
LBS.fromString (String -> Digest SHA1State) -> String -> Digest SHA1State
forall a b. (a -> b) -> a -> b
$ Style V2 Double -> String
forall a. Show a => a -> String
show Style V2 Double
marking)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".svg"

drawCd
  :: (MonadDiagrams m, MonadGraphviz m)
  => CdDrawSettings
  -> Style V2 Double
  -> AnyCd
  -> m ByteString
drawCd :: forall (m :: * -> *).
(MonadDiagrams m, MonadGraphviz m) =>
CdDrawSettings -> Style V2 Double -> AnyCd -> m ByteString
drawCd CdDrawSettings
config Style V2 Double
marking cd :: AnyCd
cd@AnyClassDiagram {[String]
[AnyRelationship String String]
anyClassNames :: [String]
anyRelationships :: [AnyRelationship String String]
anyClassNames :: forall className relationshipName.
AnyClassDiagram className relationshipName -> [className]
anyRelationships :: forall className relationshipName.
AnyClassDiagram className relationshipName
-> [AnyRelationship className relationshipName]
..} = do
  let theNodes :: [String]
theNodes = [String]
anyClassNames
  let toIndexed :: [(a,
  Either
    (InvalidRelationship String relationshipName)
    (Relationship String relationshipName))]
-> [(Int, Int,
     (a,
      Either
        (InvalidRelationship String relationshipName)
        (Relationship String relationshipName)))]
toIndexed [(a,
  Either
    (InvalidRelationship String relationshipName)
    (Relationship String relationshipName))]
xs = [(
          Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
from [String]
theNodes),
          Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
to [String]
theNodes),
          (a,
 Either
   (InvalidRelationship String relationshipName)
   (Relationship String relationshipName))
x
          )
        | x :: (a,
 Either
   (InvalidRelationship String relationshipName)
   (Relationship String relationshipName))
x@(a
_, Either
  (InvalidRelationship String relationshipName)
  (Relationship String relationshipName)
r) <- [(a,
  Either
    (InvalidRelationship String relationshipName)
    (Relationship String relationshipName))]
xs
        , let (String
from, String
to) = (InvalidRelationship String relationshipName -> (String, String))
-> (Relationship String relationshipName -> (String, String))
-> Either
     (InvalidRelationship String relationshipName)
     (Relationship String relationshipName)
-> (String, String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either InvalidRelationship String relationshipName -> (String, String)
forall {b} {relationshipName}.
InvalidRelationship b relationshipName -> (b, b)
getFromToInvalid Relationship String relationshipName -> (String, String)
forall {b} {relationshipName}.
Relationship b relationshipName -> (b, b)
getFromTo Either
  (InvalidRelationship String relationshipName)
  (Relationship String relationshipName)
r
        ]
  let thickenedRelationships :: [(Int, Int, (Bool, AnyRelationship String String))]
thickenedRelationships = [(Bool, AnyRelationship String String)]
-> [(Int, Int, (Bool, AnyRelationship String String))]
forall {a} {relationshipName} {relationshipName}.
[(a,
  Either
    (InvalidRelationship String relationshipName)
    (Relationship String relationshipName))]
-> [(Int, Int,
     (a,
      Either
        (InvalidRelationship String relationshipName)
        (Relationship String relationshipName)))]
toIndexed ([(Bool, AnyRelationship String String)]
 -> [(Int, Int, (Bool, AnyRelationship String String))])
-> [(Bool, AnyRelationship String String)]
-> [(Int, Int, (Bool, AnyRelationship String String))]
forall a b. (a -> b) -> a -> b
$ AnyCd -> [(Bool, AnyRelationship String String)]
calculateThickAnyRelationships AnyCd
cd
  let graph :: Gr String (Bool, AnyRelationship String String)
graph = [LNode String]
-> [(Int, Int, (Bool, AnyRelationship String String))]
-> Gr String (Bool, AnyRelationship String String)
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph ([Int] -> [String] -> [LNode String]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [String]
theNodes) [(Int, Int, (Bool, AnyRelationship String String))]
thickenedRelationships
        :: Gr String (Bool, AnyRelationship String String)
  let params :: GraphvizParams
  n String (Bool, AnyRelationship String String) () String
params = GraphvizParams n String Any () String
forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams {
        fmtNode :: (n, String) -> [Attribute]
fmtNode = \(n
_,String
l) -> [
          String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
l,
          Shape -> Attribute
shape Shape
BoxShape,
          DPoint -> Attribute
Margin (DPoint -> Attribute) -> DPoint -> Attribute
forall a b. (a -> b) -> a -> b
$ Double -> DPoint
DVal Double
0.02,
          Double -> Attribute
Width Double
0,
          Double -> Attribute
Height Double
0,
          Double -> Attribute
FontSize Double
16
          ],
        fmtEdge :: (n, n, (Bool, AnyRelationship String String)) -> [Attribute]
fmtEdge = \(n
_,n
_,(Bool
isThick, AnyRelationship String String
r)) -> Double -> Attribute
FontSize Double
16
          Attribute -> [Attribute] -> [Attribute]
forall a. a -> [a] -> [a]
: CdDrawSettings
-> Maybe Attribute
-> Bool
-> AnyRelationship String String
-> [Attribute]
relationshipArrow CdDrawSettings
config Maybe Attribute
forall a. Maybe a
Nothing Bool
isThick AnyRelationship String String
r
        }
  m ()
forall (m :: * -> *). MonadGraphviz m => m ()
errorWithoutGraphviz
  Gr
  (AttributeNode String)
  (AttributeEdge (Bool, AnyRelationship String String))
graph' <- GraphvizParams
  Int String (Bool, AnyRelationship String String) () String
-> GraphvizCommand
-> Gr String (Bool, AnyRelationship String String)
-> m (Gr
        (AttributeNode String)
        (AttributeEdge (Bool, AnyRelationship String String)))
forall cl (gr :: * -> * -> *) v e l.
(Ord cl, Graph gr) =>
GraphvizParams Int v e cl l
-> GraphvizCommand
-> gr v e
-> m (gr (AttributeNode v) (AttributeEdge e))
forall (m :: * -> *) cl (gr :: * -> * -> *) v e l.
(MonadGraphviz m, Ord cl, Graph gr) =>
GraphvizParams Int v e cl l
-> GraphvizCommand
-> gr v e
-> m (gr (AttributeNode v) (AttributeEdge e))
layoutGraph' GraphvizParams
  Int String (Bool, AnyRelationship String String) () String
forall {n}.
GraphvizParams
  n String (Bool, AnyRelationship String String) () String
params GraphvizCommand
dirCommand Gr String (Bool, AnyRelationship String String)
graph
  PreparedFont Double
font <- m (PreparedFont Double)
forall n. (Read n, RealFloat n) => m (PreparedFont n)
forall (m :: * -> *) n.
(MonadDiagrams m, Read n, RealFloat n) =>
m (PreparedFont n)
lin
  let (Map String (P2 Double)
nodes, [(String, String, (Bool, AnyRelationship String String),
  Path V2 Double)]
edges) = Gr
  (AttributeNode String)
  (AttributeEdge (Bool, AnyRelationship String String))
-> (Map String (P2 Double),
    [(String, String, (Bool, AnyRelationship String String),
      Path V2 Double)])
forall v e.
Ord v =>
Gr (AttributeNode v) (AttributeEdge e)
-> (Map v (P2 Double), [(v, v, e, Path V2 Double)])
GV.getGraph Gr
  (AttributeNode String)
  (AttributeEdge (Bool, AnyRelationship String String))
graph'
      graphNodes :: QDiagram B V2 Double Any
graphNodes = (String
 -> P2 Double
 -> QDiagram B V2 Double Any
 -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
-> Map String (P2 Double)
-> QDiagram B V2 Double Any
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
        (\String
l P2 Double
p QDiagram B V2 Double Any
g -> PreparedFont Double -> String -> P2 Double -> Diagram B
drawClass PreparedFont Double
font String
l P2 Double
p QDiagram B V2 Double Any
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop` QDiagram B V2 Double Any
g)
        QDiagram B V2 Double Any
forall a. Monoid a => a
mempty
        Map String (P2 Double)
nodes
      graphEdges :: QDiagram B V2 Double Any
graphEdges = ((String, String, (Bool, AnyRelationship String String),
  Path V2 Double)
 -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
-> [(String, String, (Bool, AnyRelationship String String),
     Path V2 Double)]
-> QDiagram B V2 Double Any
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(String
s, String
t, (Bool
isThick, AnyRelationship String String
r), Path V2 Double
p) QDiagram B V2 Double Any
g -> QDiagram B V2 Double Any
g QDiagram B V2 Double Any
-> (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
forall a b. a -> (a -> b) -> b
# PreparedFont Double
-> String
-> String
-> Bool
-> AnyRelationship String String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
forall {n}.
IsName n =>
PreparedFont Double
-> n
-> n
-> Bool
-> AnyRelationship n String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
drawEdge PreparedFont Double
font String
s String
t Bool
isThick AnyRelationship String String
r Path V2 Double
p)
        QDiagram B V2 Double Any
graphNodes
        [(String, String, (Bool, AnyRelationship String String),
  Path V2 Double)]
edges
  QDiagram B V2 Double Any -> m ByteString
forall n o.
(Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram B V2 n o -> m ByteString
forall (m :: * -> *) n o.
(MonadDiagrams m, Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram B V2 n o -> m ByteString
renderDiagram QDiagram B V2 Double Any
graphEdges
  where
    getFromToInvalid :: InvalidRelationship b relationshipName -> (b, b)
getFromToInvalid = \case
      InvalidInheritance {LimitedLinking b
invalidSubClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSuperClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSubClass :: LimitedLinking b
invalidSuperClass :: LimitedLinking b
..} -> (LimitedLinking b -> b)
-> (LimitedLinking b, LimitedLinking b) -> (b, b)
forall a b. (a -> b) -> (a, a) -> (b, b)
both LimitedLinking b -> b
forall nodeName. LimitedLinking nodeName -> nodeName
linking (LimitedLinking b
invalidSubClass, LimitedLinking b
invalidSuperClass)
    getFromTo :: Relationship b relationshipName -> (b, b)
getFromTo Relationship b relationshipName
x = case Relationship b relationshipName
x of
      Inheritance {b
subClass :: b
superClass :: b
subClass :: forall className relationshipName.
Relationship className relationshipName -> className
superClass :: forall className relationshipName.
Relationship className relationshipName -> className
..} -> (b
subClass, b
superClass)
      Association {relationshipName
LimitedLinking b
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationName :: relationshipName
associationFrom :: LimitedLinking b
associationTo :: LimitedLinking b
..} -> (LimitedLinking b -> b)
-> (LimitedLinking b, LimitedLinking b) -> (b, b)
forall a b. (a -> b) -> (a, a) -> (b, b)
both LimitedLinking b -> b
forall nodeName. LimitedLinking nodeName -> nodeName
linking (LimitedLinking b
associationFrom, LimitedLinking b
associationTo)
      Aggregation {relationshipName
LimitedLinking b
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationName :: relationshipName
aggregationPart :: LimitedLinking b
aggregationWhole :: LimitedLinking b
..} -> (LimitedLinking b -> b)
-> (LimitedLinking b, LimitedLinking b) -> (b, b)
forall a b. (a -> b) -> (a, a) -> (b, b)
both LimitedLinking b -> b
forall nodeName. LimitedLinking nodeName -> nodeName
linking (LimitedLinking b
aggregationWhole, LimitedLinking b
aggregationPart)
      Composition {relationshipName
LimitedLinking b
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionName :: relationshipName
compositionPart :: LimitedLinking b
compositionWhole :: LimitedLinking b
..} -> (LimitedLinking b -> b)
-> (LimitedLinking b, LimitedLinking b) -> (b, b)
forall a b. (a -> b) -> (a, a) -> (b, b)
both LimitedLinking b -> b
forall nodeName. LimitedLinking nodeName -> nodeName
linking (LimitedLinking b
compositionWhole, LimitedLinking b
compositionPart)
    drawEdge :: PreparedFont Double
-> n
-> n
-> Bool
-> AnyRelationship n String
-> Path V2 Double
-> Diagram B
-> Diagram B
drawEdge PreparedFont Double
f = PreparedFont Double
-> CdDrawSettings
-> Style V2 Double
-> n
-> n
-> Bool
-> AnyRelationship n String
-> Path V2 Double
-> Diagram B
-> Diagram B
forall n.
IsName n =>
PreparedFont Double
-> CdDrawSettings
-> Style V2 Double
-> n
-> n
-> Bool
-> AnyRelationship n String
-> Path V2 Double
-> Diagram B
-> Diagram B
drawRelationship PreparedFont Double
f CdDrawSettings
config Style V2 Double
marking

drawRelationship
  :: IsName n
  => PreparedFont Double
  -> CdDrawSettings
  -> Style V2 Double
  -> n
  -> n
  -> Bool
  -> AnyRelationship n String
  -> Path V2 Double
  -> Diagram B
  -> Diagram B
drawRelationship :: forall n.
IsName n =>
PreparedFont Double
-> CdDrawSettings
-> Style V2 Double
-> n
-> n
-> Bool
-> AnyRelationship n String
-> Path V2 Double
-> Diagram B
-> Diagram B
drawRelationship PreparedFont Double
font CdDrawSettings {Bool
OmittedDefaultMultiplicities
omittedDefaults :: CdDrawSettings -> OmittedDefaultMultiplicities
printNames :: CdDrawSettings -> Bool
printNavigations :: CdDrawSettings -> Bool
omittedDefaults :: OmittedDefaultMultiplicities
printNames :: Bool
printNavigations :: Bool
..} Style V2 Double
marking n
fl n
tl Bool
isThick AnyRelationship n String
relationship Path V2 Double
path =
  ArrowOpts Double
-> PreparedFont Double
-> DirType
-> n
-> n
-> Maybe String
-> Maybe String
-> Maybe String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
forall n1 n2.
(IsName n1, IsName n2) =>
ArrowOpts Double
-> PreparedFont Double
-> DirType
-> n1
-> n2
-> Maybe String
-> Maybe String
-> Maybe String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
connectWithPath ArrowOpts Double
opts PreparedFont Double
font DirType
dir n
from n
to Maybe String
ml Maybe String
fromLimits Maybe String
toLimits Path V2 Double
path'
  # applyStyle (if isThick then marking else mempty)
  # lwL 0.5
  where
    angle :: Angle Double
angle = Double
150 Double -> AReview (Angle Double) Double -> Angle Double
forall b a. b -> AReview a b -> a
@@ AReview (Angle Double) Double
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle Double) Double
deg
    opts :: ArrowOpts Double
opts = ArrowOpts Double
forall d. Default d => d
with
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (ArrowHT Double -> Identity (ArrowHT Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowTail ((ArrowHT Double -> Identity (ArrowHT Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> ArrowHT Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Angle Double -> ArrowHT Double
forall {b}. b -> ArrowHT Double
theTail Angle Double
angle
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (ArrowHT Double -> Identity (ArrowHT Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowHead ((ArrowHT Double -> Identity (ArrowHT Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> ArrowHT Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Angle Double -> ArrowHT Double
theHead Angle Double
angle
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
headSize
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headGap ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
0
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailLength ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
tailSize
    startLimits :: Maybe String
startLimits = case AnyRelationship n String
relationship of
      Left InvalidInheritance {LimitedLinking n
invalidSubClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSuperClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSubClass :: LimitedLinking n
invalidSuperClass :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault Maybe (Int, Maybe Int)
forall a. Maybe a
Nothing ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
invalidSubClass
      Right Inheritance {} -> Maybe String
forall a. Maybe a
Nothing
      Right Composition {String
LimitedLinking n
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionName :: String
compositionPart :: LimitedLinking n
compositionWhole :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
compositionWholeOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
compositionWhole
      Right Aggregation {String
LimitedLinking n
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationName :: String
aggregationPart :: LimitedLinking n
aggregationWhole :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
aggregationWholeOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
aggregationWhole
      Right Association {String
LimitedLinking n
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationName :: String
associationFrom :: LimitedLinking n
associationTo :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
associationFrom
    endLimits :: Maybe String
endLimits = case AnyRelationship n String
relationship of
      Left InvalidInheritance {LimitedLinking n
invalidSubClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSuperClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSubClass :: LimitedLinking n
invalidSuperClass :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault Maybe (Int, Maybe Int)
forall a. Maybe a
Nothing ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
invalidSuperClass
      Right Inheritance {} -> Maybe String
forall a. Maybe a
Nothing
      Right Composition {String
LimitedLinking n
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionName :: String
compositionPart :: LimitedLinking n
compositionWhole :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
compositionPart
      Right Aggregation {String
LimitedLinking n
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationName :: String
aggregationPart :: LimitedLinking n
aggregationWhole :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
aggregationPart
      Right Association {String
LimitedLinking n
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationName :: String
associationFrom :: LimitedLinking n
associationTo :: LimitedLinking n
..} ->
        Maybe (Int, Maybe Int) -> (Int, Maybe Int) -> Maybe String
rangeWithDefault
          (OmittedDefaultMultiplicities -> Maybe (Int, Maybe Int)
associationOmittedDefaultMultiplicity OmittedDefaultMultiplicities
omittedDefaults)
          ((Int, Maybe Int) -> Maybe String)
-> (Int, Maybe Int) -> Maybe String
forall a b. (a -> b) -> a -> b
$ LimitedLinking n -> (Int, Maybe Int)
forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits LimitedLinking n
associationTo
    (n
from, n
to, Maybe String
fromLimits, Maybe String
toLimits, Path V2 Double
path')
      | Bool
flipEdge  = (n
tl, n
fl, Maybe String
endLimits, Maybe String
startLimits, Path V2 Double -> Path V2 Double
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Path v n -> Path v n
reversePath Path V2 Double
path)
      | Bool
otherwise = (n
fl, n
tl, Maybe String
startLimits, Maybe String
endLimits, Path V2 Double
path)
    (Double
tailSize, Double
headSize) = (Double
7 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
tailScaleFactor, Double
7)
    theTail :: b -> ArrowHT Double
theTail = ArrowHT Double -> b -> ArrowHT Double
forall a b. a -> b -> a
const ArrowHT Double
forall n. RealFloat n => ArrowHT n
lineTail
    triangleFactor :: Double
triangleFactor = Angle Double -> Double
forall n. Floating n => Angle n -> n
cosA (Angle Double
forall v. Floating v => Angle v
halfTurn Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
angle)
    diamondFactor :: Double
diamondFactor = Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Angle Double -> Double
forall n. Floating n => Angle n -> n
cosA (Angle Double
forall v. Floating v => Angle v
halfTurn Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
angle)
    (Bool
flipEdge, Angle Double -> ArrowHT Double
theHead, Double
tailScaleFactor) = case AnyRelationship n String
relationship of
      Left InvalidInheritance {} -> (Bool
False, Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle, Double
0.9)
      Right Inheritance {} -> (Bool
False, Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle, Double
0.9)
      Right Association {} -> (
          Bool
False,
          if Bool
printNavigations then Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadVee else ArrowHT Double -> Angle Double -> ArrowHT Double
forall a b. a -> b -> a
const (ArrowHT Double -> ArrowHT Double
forall n. OrderedField n => ArrowHT n -> ArrowHT n
flipArrow ArrowHT Double
forall n. RealFloat n => ArrowHT n
lineTail),
          Double
triangleFactor
          )
      Right (Aggregation {}) -> (Bool
True, Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadDiamond, Double
diamondFactor)
      Right (Composition {}) -> (Bool
True, Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadFilledDiamond, Double
diamondFactor)
    dir :: DirType
dir = case AnyRelationship n String
relationship of
      Left InvalidInheritance {} -> DirType
Forward
      Right Association {} ->
        if Bool
printNavigations then DirType
Forward else DirType
NoDir
      Right Aggregation {} -> DirType
Forward
      Right Composition {} -> DirType
Forward
      Right Inheritance {} -> DirType
Forward
    ml :: Maybe String
ml = do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
printNames
      case AnyRelationship n String
relationship of
        Left InvalidInheritance {} -> Maybe String
forall a. Maybe a
Nothing
        Right Inheritance {} -> Maybe String
forall a. Maybe a
Nothing
        Right Association {String
LimitedLinking n
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationName :: String
associationFrom :: LimitedLinking n
associationTo :: LimitedLinking n
..} -> String -> Maybe String
forall a. a -> Maybe a
Just String
associationName
        Right Aggregation {String
LimitedLinking n
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationName :: String
aggregationPart :: LimitedLinking n
aggregationWhole :: LimitedLinking n
..} -> String -> Maybe String
forall a. a -> Maybe a
Just String
aggregationName
        Right Composition {String
LimitedLinking n
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionName :: String
compositionPart :: LimitedLinking n
compositionWhole :: LimitedLinking n
..} -> String -> Maybe String
forall a. a -> Maybe a
Just String
compositionName

drawClass
  :: PreparedFont Double
  -> String
  -> Point V2 Double
  -> Diagram B
drawClass :: PreparedFont Double -> String -> P2 Double -> Diagram B
drawClass PreparedFont Double
font String
l (P V2 Double
p) = Vn (Diagram B) -> Diagram B -> Diagram B
forall t. Transformable t => Vn t -> t -> t
translate Vn (Diagram B)
V2 Double
p
  (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Diagram B -> Diagram B
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ String -> Diagram B -> Diagram B
blackFrame String
l (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Diagram B -> Diagram B
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center
  (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ PreparedFont Double -> Double -> String -> Diagram B
text' PreparedFont Double
font Double
16 String
l
  # snugCenterXY
  # lineWidth 0.6
  # svgClass "label"

{-|
Parses an Alloy object diagram instance, draws it and saves it to a file.
(the path where it has been stored is returned)
-}
drawOdFromInstance
  :: (MonadCatch m, MonadDiagrams m, MonadGraphviz m, MonadWriteFile m, RandomGen g)
  => AlloyInstance
  -- ^ the Alloy object diagram instance
  -> Maybe [String]
  -- ^ all possible object names, for @ExtendsAnd FieldPlacement@
  --
  -- see 'alloyInstanceToOd' for more details.
  -> [String]
  -- ^ possible link names
  -> Maybe Rational
  -- ^ ratio of anonymous objects
  -> DirType
  -- ^ direction of links
  -> Bool
  -- ^ whether to print link names
  -> FilePath
  -- ^ where to store the object diagram
  -> RandT g m FilePath
drawOdFromInstance :: forall (m :: * -> *) g.
(MonadCatch m, MonadDiagrams m, MonadGraphviz m, MonadWriteFile m,
 RandomGen g) =>
AlloyInstance
-> Maybe [String]
-> [String]
-> Maybe Rational
-> DirType
-> Bool
-> String
-> RandT g m String
drawOdFromInstance
  AlloyInstance
alloyInstance
  Maybe [String]
possibleClassNames
  [String]
possibleLinkNames
  Maybe Rational
anonymous
  DirType
direction
  Bool
printNames
  String
path
  = do
  Od
g <- Maybe [String] -> [String] -> AlloyInstance -> RandT g m Od
forall (m :: * -> *).
MonadCatch m =>
Maybe [String] -> [String] -> AlloyInstance -> m Od
alloyInstanceToOd Maybe [String]
possibleClassNames [String]
possibleLinkNames AlloyInstance
alloyInstance
  Od
od <- Rational -> Od -> RandT g m Od
forall (m :: * -> *) className relationshipName linkLabel.
MonadRandom m =>
Rational
-> ObjectDiagram className relationshipName linkLabel
-> m (ObjectDiagram className relationshipName linkLabel)
anonymiseObjects (Rational -> Maybe Rational -> Rational
forall a. a -> Maybe a -> a
fromMaybe (Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
3) Maybe Rational
anonymous) Od
g
  m String -> RandT g m String
forall (m :: * -> *) a. Monad m => m a -> RandT g m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m String -> RandT g m String) -> m String -> RandT g m String
forall a b. (a -> b) -> a -> b
$ do
    ByteString
renderedOd <- Od -> DirType -> Bool -> m ByteString
forall (m :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m) =>
Od -> DirType -> Bool -> m ByteString
drawOd Od
od DirType
direction Bool
printNames
    String -> ByteString -> m ()
forall (m :: * -> *).
MonadWriteFile m =>
String -> ByteString -> m ()
writeToFile String
path ByteString
renderedOd
    String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
path

cacheOd
  :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m)
  => Od
  -> DirType
  -> Bool
  -> FilePath
  -> m FilePath
cacheOd :: forall (m :: * -> *).
(MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m) =>
Od -> DirType -> Bool -> String -> m String
cacheOd Od
od DirType
direction Bool
printNames String
path =
  String
-> String -> String -> Od -> (Od -> m ByteString) -> m String
forall (m :: * -> *) a.
(MonadCache m, Show a) =>
String -> String -> String -> a -> (a -> m ByteString) -> m String
cache String
path String
ext String
"od" Od
od ((Od -> m ByteString) -> m String)
-> (Od -> m ByteString) -> m String
forall a b. (a -> b) -> a -> b
$ \Od
od' ->
    Od -> DirType -> Bool -> m ByteString
forall (m :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m) =>
Od -> DirType -> Bool -> m ByteString
drawOd Od
od' DirType
direction Bool
printNames
  where
    ext :: String
ext = Bool -> String
forall a. Enum a => a -> String
short Bool
printNames
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ DirType -> String
forall a. Enum a => a -> String
short DirType
direction
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".svg"

drawOd
  :: (MonadDiagrams m, MonadGraphviz m, MonadThrow m)
  => Od
  -> DirType
  -> Bool
  -> m ByteString
drawOd :: forall (m :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m) =>
Od -> DirType -> Bool -> m ByteString
drawOd ObjectDiagram {[Link String String]
[Object String String]
objects :: [Object String String]
links :: [Link String String]
objects :: forall objectName className linkLabel.
ObjectDiagram objectName className linkLabel
-> [Object objectName className]
links :: forall objectName className linkLabel.
ObjectDiagram objectName className linkLabel
-> [Link objectName linkLabel]
..} DirType
direction Bool
printNames = do
  let numberedObjects :: [(Int, Object String String)]
numberedObjects = [Int] -> [Object String String] -> [(Int, Object String String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Object String String]
objects
      bmObjects :: Bimap Int String
bmObjects = [LNode String] -> Bimap Int String
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([LNode String] -> Bimap Int String)
-> [LNode String] -> Bimap Int String
forall a b. (a -> b) -> a -> b
$ ((Int, Object String String) -> LNode String)
-> [(Int, Object String String)] -> [LNode String]
forall a b. (a -> b) -> [a] -> [b]
map ((Object String String -> String)
-> (Int, Object String String) -> LNode String
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Object String String -> String
forall objectName className.
Object objectName className -> objectName
objectName) [(Int, Object String String)]
numberedObjects
      toEdge :: Link String linkLabel -> f (Int, Int, Link String linkLabel)
toEdge l :: Link String linkLabel
l@Link {linkLabel
String
linkLabel :: linkLabel
linkFrom :: String
linkTo :: String
linkLabel :: forall objectName linkLabel. Link objectName linkLabel -> linkLabel
linkFrom :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
linkTo :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
..} = (,,)
        (Int
 -> Int
 -> Link String linkLabel
 -> (Int, Int, Link String linkLabel))
-> f Int
-> f (Int
      -> Link String linkLabel -> (Int, Int, Link String linkLabel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bimap Int String -> f Int
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
BM.lookupR String
linkFrom Bimap Int String
bmObjects
        f (Int
   -> Link String linkLabel -> (Int, Int, Link String linkLabel))
-> f Int
-> f (Link String linkLabel -> (Int, Int, Link String linkLabel))
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Bimap Int String -> f Int
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
BM.lookupR String
linkTo Bimap Int String
bmObjects
        f (Link String linkLabel -> (Int, Int, Link String linkLabel))
-> f (Link String linkLabel) -> f (Int, Int, Link String linkLabel)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Link String linkLabel -> f (Link String linkLabel)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Link String linkLabel
l
  [(Int, Int, Link String String)]
linkEdges <- (Link String String -> m (Int, Int, Link String String))
-> [Link String String] -> m [(Int, Int, Link String String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Link String String -> m (Int, Int, Link String String)
forall {f :: * -> *} {linkLabel}.
MonadThrow f =>
Link String linkLabel -> f (Int, Int, Link String linkLabel)
toEdge [Link String String]
links
  let graph :: Gr (Object String String) (Link String String)
graph = [(Int, Object String String)]
-> [(Int, Int, Link String String)]
-> Gr (Object String String) (Link String String)
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Int, Object String String)]
numberedObjects [(Int, Int, Link String String)]
linkEdges
  let objectNames :: [(String, String)]
objectNames = (Object String String -> (String, String))
-> [Object String String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Object String String
x -> (Object String String -> String
forall objectName className.
Object objectName className -> objectName
objectName Object String String
x, Object String String -> String
forall objectName className.
Object objectName className -> objectName
objectName Object String String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "))
        ([Object String String] -> [(String, String)])
-> [Object String String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Object String String -> Bool)
-> [Object String String] -> [Object String String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Object String String -> Bool) -> Object String String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object String String -> Bool
forall objectName className. Object objectName className -> Bool
isAnonymous) [Object String String]
objects
  let params :: GraphvizParams
  n
  (Object String String)
  (Link objectName String)
  ()
  (Object String String)
params = GraphvizParams
  n (Object String String) Any () (Object String String)
forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams {
        fmtNode :: (n, Object String String) -> [Attribute]
fmtNode = \(n
_, Object {Bool
String
objectName :: forall objectName className.
Object objectName className -> objectName
isAnonymous :: forall objectName className. Object objectName className -> Bool
isAnonymous :: Bool
objectName :: String
objectClass :: String
objectClass :: forall objectName className.
Object objectName className -> className
..}) -> [
          String -> Attribute
underlinedLabel (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
objectName [(String, String)]
objectNames)
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objectClass,
          Shape -> Attribute
shape Shape
BoxShape,
          DPoint -> Attribute
Margin (DPoint -> Attribute) -> DPoint -> Attribute
forall a b. (a -> b) -> a -> b
$ Double -> DPoint
DVal Double
0.02,
          Double -> Attribute
Width Double
0,
          Double -> Attribute
Height Double
0,
          Double -> Attribute
FontSize Double
16
          ],
        fmtEdge :: (n, n, Link objectName String) -> [Attribute]
fmtEdge = \(n
_,n
_,Link {objectName
String
linkLabel :: forall objectName linkLabel. Link objectName linkLabel -> linkLabel
linkFrom :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
linkTo :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
linkLabel :: String
linkFrom :: objectName
linkTo :: objectName
..}) -> [Attribute]
arrowHeads
          [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Double -> Attribute
ArrowSize Double
0.4, Double -> Attribute
FontSize Double
16]
          [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
linkLabel | Bool
printNames] }
  m ()
forall (m :: * -> *). MonadGraphviz m => m ()
errorWithoutGraphviz
  Gr
  (AttributeNode (Object String String))
  (AttributeEdge (Link String String))
graph' <- GraphvizParams
  Int
  (Object String String)
  (Link String String)
  ()
  (Object String String)
-> GraphvizCommand
-> Gr (Object String String) (Link String String)
-> m (Gr
        (AttributeNode (Object String String))
        (AttributeEdge (Link String String)))
forall cl (gr :: * -> * -> *) v e l.
(Ord cl, Graph gr) =>
GraphvizParams Int v e cl l
-> GraphvizCommand
-> gr v e
-> m (gr (AttributeNode v) (AttributeEdge e))
forall (m :: * -> *) cl (gr :: * -> * -> *) v e l.
(MonadGraphviz m, Ord cl, Graph gr) =>
GraphvizParams Int v e cl l
-> GraphvizCommand
-> gr v e
-> m (gr (AttributeNode v) (AttributeEdge e))
layoutGraph' GraphvizParams
  Int
  (Object String String)
  (Link String String)
  ()
  (Object String String)
forall {n} {objectName}.
GraphvizParams
  n
  (Object String String)
  (Link objectName String)
  ()
  (Object String String)
params GraphvizCommand
undirCommand Gr (Object String String) (Link String String)
graph
  PreparedFont Double
font <- m (PreparedFont Double)
forall n. (Read n, RealFloat n) => m (PreparedFont n)
forall (m :: * -> *) n.
(MonadDiagrams m, Read n, RealFloat n) =>
m (PreparedFont n)
lin
  let (Map (Object String String) (P2 Double)
nodes, [(Object String String, Object String String, Link String String,
  Path V2 Double)]
edges) = Gr
  (AttributeNode (Object String String))
  (AttributeEdge (Link String String))
-> (Map (Object String String) (P2 Double),
    [(Object String String, Object String String, Link String String,
      Path V2 Double)])
forall v e.
Ord v =>
Gr (AttributeNode v) (AttributeEdge e)
-> (Map v (P2 Double), [(v, v, e, Path V2 Double)])
GV.getGraph Gr
  (AttributeNode (Object String String))
  (AttributeEdge (Link String String))
graph'
      graphNodes :: QDiagram B V2 Double Any
graphNodes = (Object String String
 -> P2 Double
 -> QDiagram B V2 Double Any
 -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
-> Map (Object String String) (P2 Double)
-> QDiagram B V2 Double Any
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
        (\Object String String
l P2 Double
p QDiagram B V2 Double Any
g -> PreparedFont Double
-> [(String, String)]
-> Object String String
-> P2 Double
-> Diagram B
drawObject PreparedFont Double
font [(String, String)]
objectNames Object String String
l P2 Double
p QDiagram B V2 Double Any
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop` QDiagram B V2 Double Any
g)
        QDiagram B V2 Double Any
forall a. Monoid a => a
mempty
        Map (Object String String) (P2 Double)
nodes
      graphEdges :: QDiagram B V2 Double Any
graphEdges = ((Object String String, Object String String, Link String String,
  Path V2 Double)
 -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
-> [(Object String String, Object String String,
     Link String String, Path V2 Double)]
-> QDiagram B V2 Double Any
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(Object {objectName :: forall objectName className.
Object objectName className -> objectName
objectName = String
s}, Object {objectName :: forall objectName className.
Object objectName className -> objectName
objectName = String
t}, Link String String
l, Path V2 Double
p) QDiagram B V2 Double Any
g ->
           QDiagram B V2 Double Any
g QDiagram B V2 Double Any
-> (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
forall a b. a -> (a -> b) -> b
# PreparedFont Double
-> DirType
-> Bool
-> String
-> String
-> Link String String
-> Path V2 Double
-> Diagram B
-> Diagram B
forall n1 n2.
(IsName n1, IsName n2) =>
PreparedFont Double
-> DirType
-> Bool
-> n1
-> n2
-> Link String String
-> Path V2 Double
-> Diagram B
-> Diagram B
drawLink PreparedFont Double
font DirType
direction Bool
printNames String
s String
t Link String String
l Path V2 Double
p)
        QDiagram B V2 Double Any
graphNodes
        [(Object String String, Object String String, Link String String,
  Path V2 Double)]
edges
  QDiagram B V2 Double Any -> m ByteString
forall n o.
(Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram B V2 n o -> m ByteString
forall (m :: * -> *) n o.
(MonadDiagrams m, Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram B V2 n o -> m ByteString
renderDiagram QDiagram B V2 Double Any
graphEdges
  where
    arrowHeads :: [Attribute]
arrowHeads = case DirType
direction of
      DirType
NoDir  -> [DirType -> Attribute
edgeEnds DirType
NoDir]
      DirType
dir -> [DirType -> Attribute
edgeEnds DirType
dir, Arrow -> Attribute
arrowFrom Arrow
vee, Arrow -> Attribute
arrowTo Arrow
vee]

drawLink
  :: (IsName n1, IsName n2)
  => PreparedFont Double
  -> DirType
  -> Bool
  -> n1
  -> n2
  -> Link String String
  -> Path V2 Double
  -> Diagram B
  -> Diagram B
drawLink :: forall n1 n2.
(IsName n1, IsName n2) =>
PreparedFont Double
-> DirType
-> Bool
-> n1
-> n2
-> Link String String
-> Path V2 Double
-> Diagram B
-> Diagram B
drawLink PreparedFont Double
font DirType
direction Bool
printNames n1
fl n2
tl Link {String
linkLabel :: forall objectName linkLabel. Link objectName linkLabel -> linkLabel
linkFrom :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
linkTo :: forall objectName linkLabel.
Link objectName linkLabel -> objectName
linkLabel :: String
linkFrom :: String
linkTo :: String
..} =
  ArrowOpts Double
-> PreparedFont Double
-> DirType
-> n1
-> n2
-> Maybe String
-> Maybe String
-> Maybe String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
forall n1 n2.
(IsName n1, IsName n2) =>
ArrowOpts Double
-> PreparedFont Double
-> DirType
-> n1
-> n2
-> Maybe String
-> Maybe String
-> Maybe String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
connectWithPath ArrowOpts Double
opts PreparedFont Double
font DirType
direction n1
fl n2
tl Maybe String
ml Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
  # lwL 0.5
  where
    opts :: ArrowOpts Double
opts = ArrowOpts Double
forall d. Default d => d
with
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (ArrowHT Double -> Identity (ArrowHT Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowTail ((ArrowHT Double -> Identity (ArrowHT Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> ArrowHT Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowHT Double
forall n. RealFloat n => ArrowHT n
lineTail
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (ArrowHT Double -> Identity (ArrowHT Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowHead ((ArrowHT Double -> Identity (ArrowHT Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> ArrowHT Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowHT Double
veeArrow
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
7
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headGap ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
0
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailLength ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
7
    ml :: Maybe String
ml
      | Bool
printNames = String -> Maybe String
forall a. a -> Maybe a
Just String
linkLabel
      | Bool
otherwise  = Maybe String
forall a. Maybe a
Nothing

drawObject
  :: PreparedFont Double
  -> [(String, String)]
  -> Object String String
  -> Point V2 Double
  -> Diagram B
drawObject :: PreparedFont Double
-> [(String, String)]
-> Object String String
-> P2 Double
-> Diagram B
drawObject PreparedFont Double
font [(String, String)]
objectNames Object {Bool
String
objectName :: forall objectName className.
Object objectName className -> objectName
isAnonymous :: forall objectName className. Object objectName className -> Bool
objectClass :: forall objectName className.
Object objectName className -> className
isAnonymous :: Bool
objectName :: String
objectClass :: String
..} (P V2 Double
p) = Vn (Diagram B) -> Diagram B -> Diagram B
forall t. Transformable t => Vn t -> t -> t
translate Vn (Diagram B)
V2 Double
p
  (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Diagram B -> Diagram B
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ String -> Diagram B -> Diagram B
blackFrame String
objectName (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Diagram B -> Diagram B
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center
  (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ PreparedFont Double -> Double -> String -> Diagram B
textU PreparedFont Double
font Double
16
      (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
objectName [(String, String)]
objectNames) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objectClass)
  # snugCenterXY
  # lineWidth 0.6
  # svgClass "label"

blackFrame
  :: String
  -> Diagram B
  -> Diagram B
blackFrame :: String -> Diagram B -> Diagram B
blackFrame String
t Diagram B
object =
  Double -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
1 (
    Double -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
2 Diagram B
QDiagram B V2 Double Any
object
      # fc black
      # lc black
      # bg white
      # svgClass "bg"
    )
  # bg black
  # named t
  # svgClass "node"