> {-# OPTIONS_HADDOCK hide,show-extensions #-}
> {-|
> Module    : LTK.Porters.SyntacticOrder
> Copyright : (c) 2022,2023 Dakotah Lambert
> License   : MIT
>
> This module provides a mechanism to display the syntactic order
> of a syntactic monoid.  This is an export-only format, as information
> is lost.
>
> @since 1.1
> -}
> module LTK.Porters.SyntacticOrder ( exportSyntacticOrder ) where

> import Data.List (intercalate, nub)
> import qualified Data.Set as Set

> import LTK.FSA
> import LTK.Algebra (SynMon, syntacticOrder)

> -- |Draw the Hasse diagram of the syntactic order of the given monoid
> -- in GraphViz @dot@ format.
> exportSyntacticOrder :: (Ord n, Ord e, Show e) => SynMon n e -> String
> exportSyntacticOrder :: forall n e. (Ord n, Ord e, Show e) => SynMon n e -> [Char]
exportSyntacticOrder SynMon n e
m
>     = [[Char]] -> [Char]
unlines
>       ([ [Char]
"digraph {", [Char]
"graph [rankdir=BT]"
>        , [Char]
"node [shape=box]", [Char]
"edge [dir=none]" ]
>       forall a. [a] -> [a] -> [a]
++ [[Char]]
sts
>       forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> [Char]
showtr) (forall a. Eq a => [(a, a)] -> [(a, a)]
reduce [([Char], [Char])]
rel)
>       forall a. [a] -> [a] -> [a]
++ [[Char]
"}"]
>       )
>     where g :: FSA [e] ()
g = forall n e. (Ord n, Ord e) => SynMon n e -> FSA [e] ()
syntacticOrder SynMon n e
m
>           qs :: [([Char], State [e])]
qs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Integer
1::Integer ..]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states FSA [e] ()
g
>           rel :: [([Char], [Char])]
rel = [ (forall a b. (a, b) -> a
fst ([Char], State [e])
x, forall a b. (a, b) -> a
fst ([Char], State [e])
y)
>                 | ([Char], State [e])
x <- [([Char], State [e])]
qs, ([Char], State [e])
y <- [([Char], State [e])]
qs
>                 , ([Char], State [e])
x forall a. Eq a => a -> a -> Bool
/= ([Char], State [e])
y
>                 , Transition { source :: State [e]
source = forall a b. (a, b) -> b
snd ([Char], State [e])
x
>                              , destination :: State [e]
destination = forall a b. (a, b) -> b
snd ([Char], State [e])
y
>                              , edgeLabel :: Symbol ()
edgeLabel = forall e. e -> Symbol e
Symbol () }
>                   forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall n e. FSA n e -> Set (Transition n e)
transitions FSA [e] ()
g
>                 ]
>           sts :: [[Char]]
sts = forall a b. (a -> b) -> [a] -> [b]
map
>                 (\([Char]
x,State [e]
y) ->
>                  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
x
>                         , [Char]
" [label=\""
>                         , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\x2009"
>                           (forall a b. (a -> b) -> [a] -> [b]
map e -> [Char]
showish forall a b. (a -> b) -> a -> b
$ forall n. State n -> n
nodeLabel State [e]
y)
>                         , [Char]
"\"];"]
>                 ) [([Char], State [e])]
qs
>           showish :: e -> [Char]
showish = [Char] -> [Char]
deescape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'"') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
>           showtr :: [Char] -> [Char] -> [Char]
showtr [Char]
x [Char]
y = [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ [Char]
y forall a. [a] -> [a] -> [a]
++ [Char]
";"

If you show a string, quotes and some other symbols get escaped.
Undo that.  A better approach would be to not use Show to begin with,
but that makes the system less generic, so we accept the burden.

> deescape :: String -> String
> deescape :: [Char] -> [Char]
deescape (Char
'\\' : Char
'&' : [Char]
xs) = [Char] -> [Char]
deescape [Char]
xs
> deescape (Char
'\\' : Char
x : [Char]
xs)
>     | forall c a. Container c a => c -> Bool
isEmpty [Char]
digits = Char
x forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
>     | Bool
otherwise      = forall a. Enum a => Int -> a
toEnum (forall a. Read a => [Char] -> a
read [Char]
digits) forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
others
>     where ([Char]
digits, [Char]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn [Char]
"0123456789") (Char
xforall a. a -> [a] -> [a]
:[Char]
xs)
> deescape (Char
x:[Char]
xs) = Char
x forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
> deescape [Char]
_      = []

Compute the transitive reduction of an acyclic graph
which is specified by source/destination pairs.
The precondition, that the graph be acyclic, is not checked.

> reduce :: (Eq a) => [(a,a)] -> [(a,a)]
> reduce :: forall a. Eq a => [(a, a)] -> [(a, a)]
reduce [(a, a)]
ps = [(a
x,a
y) | a
x <- [a]
nodes, a
y <- [a]
nodes, a
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a -> [a]
expand a
x,
>              forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(a, a)]
ps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) a
y) (a -> [a]
expand a
x)]
>     where nodes :: [a]
nodes = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, a)]
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, a)]
ps
>           expand :: a -> [a]
expand a
p = let n :: [a]
n = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((a
p forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, a)]
ps
>                      in [a]
n forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [a]
expand [a]
n