{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

-- | Example of Dot graph construction for the <https://hackage.haskell.org/package/numhask NumHask> class heirarchy.
module DotParse.Examples.NumHask where

import Algebra.Graph qualified as G
import Chart
import Data.Bifunctor
import Data.Map.Strict qualified as Map
import Data.Monoid
import Data.String.Interpolate
import Data.Text (Text, pack)
import DotParse
import FlatParse.Basic
import GHC.IO.Unsafe
import Optics.Core
import Prelude hiding (replicate)

-- $setup
-- >>> import DotParse
-- >>> :set -XOverloadedStrings

-- | Names of the various classes used in numhask
data Class
  = Magma
  | Unital
  | Associative
  | Commutative
  | Invertible
  | Idempotent
  | Absorbing
  | Group
  | AbelianGroup
  | Additive
  | Subtractive
  | Multiplicative
  | Divisive
  | Distributive
  | Semiring
  | Ring
  | IntegralDomain
  | Field
  | ExpField
  | QuotientField
  | UpperBoundedField
  | LowerBoundedField
  | TrigField
  | -- Higher-kinded numbers
    AdditiveAction
  | SubtractiveAction
  | MultiplicativeAction
  | DivisiveAction
  | Actions
  | -- Lattice
    JoinSemiLattice
  | MeetSemiLattice
  | Lattice
  | BoundedJoinSemiLattice
  | BoundedMeetSemiLattice
  | BoundedLattice
  | -- Number Types
    Integral
  | Ratio
  | -- Measure
    Basis
  | Direction
  | Epsilon
  deriving (Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Class] -> ShowS
$cshowList :: [Class] -> ShowS
show :: Class -> String
$cshow :: Class -> String
showsPrec :: Int -> Class -> ShowS
$cshowsPrec :: Int -> Class -> ShowS
Show, Class -> Class -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c== :: Class -> Class -> Bool
Eq, Eq Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmax :: Class -> Class -> Class
>= :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c< :: Class -> Class -> Bool
compare :: Class -> Class -> Ordering
$ccompare :: Class -> Class -> Ordering
Ord)

-- | A class dependency.
data Dependency = Dependency
  { Dependency -> Class
_class :: Class,
    Dependency -> Class
_dep :: Class
  }
  deriving (Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependency] -> ShowS
$cshowList :: [Dependency] -> ShowS
show :: Dependency -> String
$cshow :: Dependency -> String
showsPrec :: Int -> Dependency -> ShowS
$cshowsPrec :: Int -> Dependency -> ShowS
Show, Dependency -> Dependency -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dependency -> Dependency -> Bool
$c/= :: Dependency -> Dependency -> Bool
== :: Dependency -> Dependency -> Bool
$c== :: Dependency -> Dependency -> Bool
Eq, Eq Dependency
Dependency -> Dependency -> Bool
Dependency -> Dependency -> Ordering
Dependency -> Dependency -> Dependency
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Dependency -> Dependency -> Dependency
$cmin :: Dependency -> Dependency -> Dependency
max :: Dependency -> Dependency -> Dependency
$cmax :: Dependency -> Dependency -> Dependency
>= :: Dependency -> Dependency -> Bool
$c>= :: Dependency -> Dependency -> Bool
> :: Dependency -> Dependency -> Bool
$c> :: Dependency -> Dependency -> Bool
<= :: Dependency -> Dependency -> Bool
$c<= :: Dependency -> Dependency -> Bool
< :: Dependency -> Dependency -> Bool
$c< :: Dependency -> Dependency -> Bool
compare :: Dependency -> Dependency -> Ordering
$ccompare :: Dependency -> Dependency -> Ordering
Ord)

-- | List of all dependencies (as at v0.11)
dependencies :: [Dependency]
dependencies :: [Dependency]
dependencies =
  [ Class -> Class -> Dependency
Dependency Class
Unital Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Associative Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Commutative Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Invertible Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Idempotent Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Absorbing Class
Magma,
    Class -> Class -> Dependency
Dependency Class
Group Class
Unital,
    Class -> Class -> Dependency
Dependency Class
Group Class
Invertible,
    Class -> Class -> Dependency
Dependency Class
Group Class
Associative,
    Class -> Class -> Dependency
Dependency Class
AbelianGroup Class
Unital,
    Class -> Class -> Dependency
Dependency Class
AbelianGroup Class
Invertible,
    Class -> Class -> Dependency
Dependency Class
AbelianGroup Class
Associative,
    Class -> Class -> Dependency
Dependency Class
AbelianGroup Class
Commutative,
    Class -> Class -> Dependency
Dependency Class
Additive Class
Commutative,
    Class -> Class -> Dependency
Dependency Class
Additive Class
Unital,
    Class -> Class -> Dependency
Dependency Class
Additive Class
Associative,
    Class -> Class -> Dependency
Dependency Class
Subtractive Class
Invertible,
    Class -> Class -> Dependency
Dependency Class
Subtractive Class
Additive,
    Class -> Class -> Dependency
Dependency Class
Multiplicative Class
Unital,
    Class -> Class -> Dependency
Dependency Class
Multiplicative Class
Associative,
    Class -> Class -> Dependency
Dependency Class
Multiplicative Class
Commutative,
    Class -> Class -> Dependency
Dependency Class
Divisive Class
Invertible,
    Class -> Class -> Dependency
Dependency Class
Divisive Class
Multiplicative,
    Class -> Class -> Dependency
Dependency Class
Distributive Class
Additive,
    Class -> Class -> Dependency
Dependency Class
Distributive Class
Multiplicative,
    Class -> Class -> Dependency
Dependency Class
Distributive Class
Absorbing,
    Class -> Class -> Dependency
Dependency Class
Ring Class
Distributive,
    Class -> Class -> Dependency
Dependency Class
Ring Class
Subtractive,
    Class -> Class -> Dependency
Dependency Class
IntegralDomain Class
Ring,
    Class -> Class -> Dependency
Dependency Class
Field Class
Ring,
    Class -> Class -> Dependency
Dependency Class
Field Class
Divisive,
    Class -> Class -> Dependency
Dependency Class
ExpField Class
Field,
    Class -> Class -> Dependency
Dependency Class
QuotientField Class
Field,
    Class -> Class -> Dependency
Dependency Class
QuotientField Class
Ring,
    Class -> Class -> Dependency
Dependency Class
TrigField Class
Field,
    Class -> Class -> Dependency
Dependency Class
UpperBoundedField Class
Field,
    Class -> Class -> Dependency
Dependency Class
LowerBoundedField Class
Field,
    -- higher-kinded relationships
    Class -> Class -> Dependency
Dependency Class
AdditiveAction Class
Additive,
    Class -> Class -> Dependency
Dependency Class
SubtractiveAction Class
Subtractive,
    Class -> Class -> Dependency
Dependency Class
MultiplicativeAction Class
Multiplicative,
    Class -> Class -> Dependency
Dependency Class
DivisiveAction Class
Divisive,
    Class -> Class -> Dependency
Dependency Class
Actions Class
Distributive,
    -- Lattice
    Class -> Class -> Dependency
Dependency Class
JoinSemiLattice Class
Associative,
    Class -> Class -> Dependency
Dependency Class
JoinSemiLattice Class
Commutative,
    Class -> Class -> Dependency
Dependency Class
JoinSemiLattice Class
Idempotent,
    Class -> Class -> Dependency
Dependency Class
MeetSemiLattice Class
Associative,
    Class -> Class -> Dependency
Dependency Class
MeetSemiLattice Class
Commutative,
    Class -> Class -> Dependency
Dependency Class
MeetSemiLattice Class
Idempotent,
    Class -> Class -> Dependency
Dependency Class
Lattice Class
JoinSemiLattice,
    Class -> Class -> Dependency
Dependency Class
Lattice Class
MeetSemiLattice,
    Class -> Class -> Dependency
Dependency Class
BoundedJoinSemiLattice Class
JoinSemiLattice,
    Class -> Class -> Dependency
Dependency Class
BoundedJoinSemiLattice Class
Unital,
    Class -> Class -> Dependency
Dependency Class
BoundedMeetSemiLattice Class
MeetSemiLattice,
    Class -> Class -> Dependency
Dependency Class
BoundedMeetSemiLattice Class
Unital,
    Class -> Class -> Dependency
Dependency Class
BoundedLattice Class
BoundedJoinSemiLattice,
    Class -> Class -> Dependency
Dependency Class
BoundedLattice Class
BoundedMeetSemiLattice,
    Class -> Class -> Dependency
Dependency Class
Basis Class
Distributive,
    Class -> Class -> Dependency
Dependency Class
Direction Class
Distributive,
    Class -> Class -> Dependency
Dependency Class
Epsilon Class
Subtractive,
    Class -> Class -> Dependency
Dependency Class
Epsilon Class
MeetSemiLattice,
    Class -> Class -> Dependency
Dependency Class
Integral Class
Ring,
    Class -> Class -> Dependency
Dependency Class
Ratio Class
Field
  ]

-- | List of classes to use in diagram.
classesNH :: [Class]
classesNH :: [Class]
classesNH =
  [ Class
Additive,
    Class
Subtractive,
    Class
Multiplicative,
    Class
Divisive,
    Class
Distributive,
    Class
Ring,
    Class
Field,
    Class
ExpField,
    Class
QuotientField,
    Class
TrigField,
    Class
Basis,
    Class
Direction,
    Class
Actions,
    Class
Integral,
    Class
Ratio
  ]

-- | Names of the modules where each class is located.
classesModule :: [(Class, Text)]
classesModule :: [(Class, Text)]
classesModule =
  [ (Class
Additive, Text
"NumHask-Algebra-Additive"),
    (Class
Subtractive, Text
"NumHask-Algebra-Additive"),
    (Class
Multiplicative, Text
"NumHask-Algebra-Multiplicative"),
    (Class
Divisive, Text
"NumHask-Algebra-Multiplicative"),
    (Class
Distributive, Text
"NumHask-Algebra-Distributive"),
    (Class
Ring, Text
"NumHask-Algebra-Ring"),
    (Class
Field, Text
"NumHask-Algebra-Field"),
    (Class
ExpField, Text
"NumHask-Algebra-Field"),
    (Class
QuotientField, Text
"NumHask-Algebra-Field"),
    (Class
TrigField, Text
"NumHask-Algebra-Field"),
    (Class
Basis, Text
"NumHask-Algebra-Metric"),
    (Class
Direction, Text
"NumHask-Algebra-Metric"),
    (Class
Actions, Text
"NumHask-Algebra-Action"),
    (Class
UpperBoundedField, Text
"NumHask-Algebra-Field"),
    (Class
LowerBoundedField, Text
"NumHask-Algebra-Field"),
    (Class
Integral, Text
"NumHask-Data-Integral"),
    (Class
Ratio, Text
"NumHask-Data-Rational")
  ]

-- | List of dependencies to draw.
dependenciesNH :: [Dependency] -> [Dependency]
dependenciesNH :: [Dependency] -> [Dependency]
dependenciesNH = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Dependency Class
x0 Class
x1) -> Class
x0 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Class]
classesNH Bool -> Bool -> Bool
&& Class
x1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Class]
classesNH)

-- | NumHask Classes as an algebraic graph
graphNHG :: G.Graph Class
graphNHG :: Graph Class
graphNHG =
  forall a. [(a, a)] -> Graph a
G.edges ((\(Dependency Class
x Class
y) -> (Class
x, Class
y)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dependency] -> [Dependency]
dependenciesNH [Dependency]
dependencies)
    forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Graph a
G.vertices [Class]
classesNH

-- | NumHask statements in a dot Graph with box shapes for the nodes.
dotGraphNH :: Directed -> Graph
dotGraphNH :: Directed -> Graph
dotGraphNH Directed
d =
  Graph
defaultGraph
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "directed" a => a
#directed forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Directed
d)
    forall a b. a -> (a -> b) -> b
& [Statement] -> Graph -> Graph
addStatements (Directed -> Graph ByteString -> [Statement]
toStatements Directed
d (String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph Class
graphNHG))
    forall a b. a -> (a -> b) -> b
& AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape") forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (ByteString -> ID
ID ByteString
"box")
    forall a b. a -> (a -> b) -> b
& ID -> Lens' Graph (Maybe ID)
gattL (ByteString -> ID
ID ByteString
"rankdir") forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (ByteString -> ID
IDQuoted ByteString
"BT")

-- | 'dotGraphNH' after being positionally processed via 'processGraph'
dotGraphNH' :: Directed -> Graph
dotGraphNH' :: Directed -> Graph
dotGraphNH' Directed
d = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ Graph -> IO Graph
processGraph (Directed -> Graph
dotGraphNH Directed
d)
{-# NOINLINE dotGraphNH' #-}

-- | Convert a node ID to a label for chart-svg charts
-- Doing this directly in dot doesn't quite work because the engines get the width of the link wrong.
toLink :: ID -> Text
toLink :: ID -> Text
toLink ID
id_ = [i|<a href="https://hackage.haskell.org/package/numhask/docs/#{m}.html\#t:#{t}">#{t}</a>|]
  where
    t :: Text
t = String -> Text
pack (ID -> String
label ID
id_)
    m :: Text
m = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Class, Text)]
classesModule) forall k a. Ord k => Map k a -> k -> a
Map.! Text
t

-- | A chart-svg chart with label links
--
-- > writeChartOptions "other/nh.svg" (graphToChart toLink (dotGraphNH' Directed))
--
-- ![NumHask Example](other/nh.svg)
writeNHChart :: IO ()
writeNHChart :: IO ()
writeNHChart = String -> ChartOptions -> IO ()
writeChartOptions String
"other/nh.svg" (ChartConfig -> Graph -> ChartOptions
graphToChartWith (ChartConfig
defaultChartConfig forall a b. a -> (a -> b) -> b
& forall a. IsLabel "labelf" a => a
#labelf forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ID -> Text
toLink forall a b. a -> (a -> b) -> b
& forall a. IsLabel "chartColor" a => a
#chartColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' Colour Double
lightness' (forall a. Num a => a -> a -> a
* Double
0.5) (Int -> Colour
palette1 Int
2) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "chartBackgroundColor" a => a
#chartBackgroundColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' Colour Double
opac' Double
0.1 (Int -> Colour
palette1 Int
1)) (Directed -> Graph
dotGraphNH' Directed
Directed))