{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use ?~" #-}

-- | Example of Dot graph construction for the NumHask class heirarchy.
module DotParse.Examples.NumHask where

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

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

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
  | Module
  | -- Lattice
    JoinSemiLattice
  | MeetSemiLattice
  | Lattice
  | BoundedJoinSemiLattice
  | BoundedMeetSemiLattice
  | BoundedLattice
  | -- Number Types
    Integral
  | Ratio
  | -- Measure
    Signed
  | Norm
  | 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)

data Family
  = Addition
  | Multiplication
  | Actor
  deriving (Int -> Family -> ShowS
[Family] -> ShowS
Family -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Family] -> ShowS
$cshowList :: [Family] -> ShowS
show :: Family -> String
$cshow :: Family -> String
showsPrec :: Int -> Family -> ShowS
$cshowsPrec :: Int -> Family -> ShowS
Show, Family -> Family -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Family -> Family -> Bool
$c/= :: Family -> Family -> Bool
== :: Family -> Family -> Bool
$c== :: Family -> Family -> Bool
Eq, Eq Family
Family -> Family -> Bool
Family -> Family -> Ordering
Family -> Family -> Family
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 :: Family -> Family -> Family
$cmin :: Family -> Family -> Family
max :: Family -> Family -> Family
$cmax :: Family -> Family -> Family
>= :: Family -> Family -> Bool
$c>= :: Family -> Family -> Bool
> :: Family -> Family -> Bool
$c> :: Family -> Family -> Bool
<= :: Family -> Family -> Bool
$c<= :: Family -> Family -> Bool
< :: Family -> Family -> Bool
$c< :: Family -> Family -> Bool
compare :: Family -> Family -> Ordering
$ccompare :: Family -> Family -> Ordering
Ord)

data Dependency = Dependency
  { Dependency -> Class
_class :: Class,
    Dependency -> Class
_dep :: Class,
    Dependency -> Maybe Family
_op :: Maybe Family
  }
  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)

dependencies :: [Dependency]
dependencies :: [Dependency]
dependencies =
  [ Class -> Class -> Maybe Family -> Dependency
Dependency Class
Unital Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Associative Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Commutative Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Invertible Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Idempotent Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Absorbing Class
Magma forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Group Class
Unital forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Group Class
Invertible forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Group Class
Associative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
AbelianGroup Class
Unital forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
AbelianGroup Class
Invertible forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
AbelianGroup Class
Associative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
AbelianGroup Class
Commutative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Additive Class
Commutative (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Additive Class
Unital (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Additive Class
Associative (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Subtractive Class
Invertible (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Subtractive Class
Additive (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Multiplicative Class
Unital (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Multiplicative Class
Associative (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Multiplicative Class
Commutative (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Divisive Class
Invertible (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Divisive Class
Multiplicative (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Distributive Class
Additive (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Distributive Class
Multiplicative (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Distributive Class
Absorbing forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Ring Class
Distributive forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Ring Class
Subtractive (forall a. a -> Maybe a
Just Family
Addition),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
IntegralDomain Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Field Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Field Class
Divisive (forall a. a -> Maybe a
Just Family
Multiplication),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
ExpField Class
Field forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
QuotientField Class
Field forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
QuotientField Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
TrigField Class
Field forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
UpperBoundedField Class
Field forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
LowerBoundedField Class
Field forall a. Maybe a
Nothing,
    -- higher-kinded relationships
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
AdditiveAction Class
Additive (forall a. a -> Maybe a
Just Family
Actor),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
SubtractiveAction Class
Subtractive (forall a. a -> Maybe a
Just Family
Actor),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
MultiplicativeAction Class
Multiplicative (forall a. a -> Maybe a
Just Family
Actor),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
DivisiveAction Class
Divisive (forall a. a -> Maybe a
Just Family
Actor),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Module Class
Distributive (forall a. a -> Maybe a
Just Family
Actor),
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Module Class
MultiplicativeAction forall a. Maybe a
Nothing,
    -- Lattice
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
JoinSemiLattice Class
Associative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
JoinSemiLattice Class
Commutative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
JoinSemiLattice Class
Idempotent forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
MeetSemiLattice Class
Associative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
MeetSemiLattice Class
Commutative forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
MeetSemiLattice Class
Idempotent forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Lattice Class
JoinSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Lattice Class
MeetSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedJoinSemiLattice Class
JoinSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedJoinSemiLattice Class
Unital forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedMeetSemiLattice Class
MeetSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedMeetSemiLattice Class
Unital forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedLattice Class
BoundedJoinSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
BoundedLattice Class
BoundedMeetSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Signed Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Norm Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Basis Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Direction Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Epsilon Class
Subtractive forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Epsilon Class
MeetSemiLattice forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Integral Class
Ring forall a. Maybe a
Nothing,
    Class -> Class -> Maybe Family -> Dependency
Dependency Class
Ratio Class
Field forall a. Maybe a
Nothing
  ]

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
Signed,
    Class
Norm,
    Class
Direction,
    Class
MultiplicativeAction,
    Class
Module,
    Class
UpperBoundedField,
    Class
LowerBoundedField,
    Class
Integral,
    Class
Ratio
  ]

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
Signed, Text
"NumHask-Algebra-Metric"),
    (Class
Norm, Text
"NumHask-Algebra-Metric"),
    (Class
Direction, Text
"NumHask-Algebra-Metric"),
    (Class
MultiplicativeAction, Text
"NumHask-Algebra-Module"),
    (Class
Module, Text
"NumHask-Algebra-Module"),
    (Class
UpperBoundedField, Text
"NumHask-Algebra-Field"),
    (Class
LowerBoundedField, Text
"NumHask-Algebra-Field"),
    (Class
Integral, Text
"NumHask-Data-Integral"),
    (Class
Ratio, Text
"NumHask-Data-Rational")
  ]

dependenciesNH :: [Dependency] -> [Dependency]
dependenciesNH :: [Dependency] -> [Dependency]
dependenciesNH = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Dependency Class
x0 Class
x1 Maybe Family
_) -> 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 Maybe Family
_) -> (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) (Directed -> Graph
dotGraphNH' Directed
Directed))