> {-# OPTIONS_HADDOCK hide,show-extensions #-}
> {-|
> Module    : LTK.Porters.SyntacticSemilattice
> Copyright : (c) 2025 Dakotah Lambert
> License   : MIT
>
> This module provides a mechanism to display the syntactic semilattice
> of a language.  This is an export-only format, as information
> is lost.
>
> @since 1.3
> -}
> module LTK.Porters.SyntacticSemilattice
>     ( exportSyntacticSemilattice )
>     where

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

> import LTK.FSA

> exportSyntacticSemilattice :: (Ord e, Show e) =>
>                               Map (Set [e]) (Set (Set [e]))
>                            -> String
> exportSyntacticSemilattice :: forall e.
(Ord e, Show e) =>
Map (Set [e]) (Set (Set [e])) -> [Char]
exportSyntacticSemilattice
>     = [(Set [e], Set [e])] -> [Char]
forall {a}. (Show a, Ord a) => [(Set [a], Set [a])] -> [Char]
pr ([(Set [e], Set [e])] -> [Char])
-> (Map (Set [e]) (Set (Set [e])) -> [(Set [e], Set [e])])
-> Map (Set [e]) (Set (Set [e]))
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Set [e], Set [e])] -> [(Set [e], Set [e])]
forall a. Eq a => [(a, a)] -> [(a, a)]
reduce ([(Set [e], Set [e])] -> [(Set [e], Set [e])])
-> (Map (Set [e]) (Set (Set [e])) -> [(Set [e], Set [e])])
-> Map (Set [e]) (Set (Set [e]))
-> [(Set [e], Set [e])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set [e], Set [e]) -> Bool)
-> [(Set [e], Set [e])] -> [(Set [e], Set [e])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Set [e] -> Set [e] -> Bool) -> (Set [e], Set [e]) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Set [e] -> Set [e] -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) ([(Set [e], Set [e])] -> [(Set [e], Set [e])])
-> (Map (Set [e]) (Set (Set [e])) -> [(Set [e], Set [e])])
-> Map (Set [e]) (Set (Set [e]))
-> [(Set [e], Set [e])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Set [e], Set (Set [e]))] -> [(Set [e], Set [e])]
forall {a} {a}. [(a, Set a)] -> [(a, a)]
expand ([(Set [e], Set (Set [e]))] -> [(Set [e], Set [e])])
-> (Map (Set [e]) (Set (Set [e])) -> [(Set [e], Set (Set [e]))])
-> Map (Set [e]) (Set (Set [e]))
-> [(Set [e], Set [e])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Set [e]) (Set (Set [e])) -> [(Set [e], Set (Set [e]))]
forall k a. Map k a -> [(k, a)]
Map.assocs
>     where expand :: [(a, Set a)] -> [(a, a)]
expand ((a
x,Set a
s):[(a, Set a)]
ys) = (a -> (a, a)) -> [a] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) a
x) (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s) [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, Set a)] -> [(a, a)]
expand [(a, Set a)]
ys
>           expand [] = []
>           pr :: [(Set [a], Set [a])] -> [Char]
pr [(Set [a], Set [a])]
xs = [[Char]] -> [Char]
unlines
>                   ([ [Char]
"digraph {", [Char]
"graph [rankdir=BT]"
>                    , [Char]
"node [shape=box]", [Char]
"edge [dir=none]" ]
>                    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
sts
>                    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> [Char]) -> ([Char], [Char]) -> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> [Char]
showtr) [([Char], [Char])]
rel
>                    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"}"]
>                   )
>               where ss :: [([Char], Set [a])]
ss = [[Char]] -> [Set [a]] -> [([Char], Set [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show [Int
1::Int ..]) ([Set [a]] -> [([Char], Set [a])])
-> (Set (Set [a]) -> [Set [a]])
-> Set (Set [a])
-> [([Char], Set [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set [a]) -> [Set [a]]
forall a. Set a -> [a]
Set.toList
>                          (Set (Set [a]) -> [([Char], Set [a])])
-> Set (Set [a]) -> [([Char], Set [a])]
forall a b. (a -> b) -> a -> b
$ [Set [a]] -> Set (Set [a])
forall a. Ord a => [a] -> Set a
Set.fromList (((Set [a], Set [a]) -> Set [a])
-> [(Set [a], Set [a])] -> [Set [a]]
forall a b. (a -> b) -> [a] -> [b]
map (Set [a], Set [a]) -> Set [a]
forall a b. (a, b) -> a
fst [(Set [a], Set [a])]
xs [Set [a]] -> [Set [a]] -> [Set [a]]
forall a. [a] -> [a] -> [a]
++ ((Set [a], Set [a]) -> Set [a])
-> [(Set [a], Set [a])] -> [Set [a]]
forall a b. (a -> b) -> [a] -> [b]
map (Set [a], Set [a]) -> Set [a]
forall a b. (a, b) -> b
snd [(Set [a], Set [a])]
xs)
>                     rel :: [([Char], [Char])]
rel = [ (([Char], Set [a]) -> [Char]
forall a b. (a, b) -> a
fst ([Char], Set [a])
x, ([Char], Set [a]) -> [Char]
forall a b. (a, b) -> a
fst ([Char], Set [a])
y)
>                           | ([Char], Set [a])
x <- [([Char], Set [a])]
ss, ([Char], Set [a])
y <- [([Char], Set [a])]
ss, (([Char], Set [a]) -> Set [a]
forall a b. (a, b) -> b
snd ([Char], Set [a])
x, ([Char], Set [a]) -> Set [a]
forall a b. (a, b) -> b
snd ([Char], Set [a])
y) (Set [a], Set [a]) -> [(Set [a], Set [a])] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Set [a], Set [a])]
xs
>                           ]
>                     sts :: [[Char]]
sts = (([Char], Set [a]) -> [Char]) -> [([Char], Set [a])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
>                           (\([Char]
x,Set [a]
y) ->
>                            [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
x
>                                   , [Char]
" [label=\""
>                                   , Set [a] -> [Char]
showset Set [a]
y
>                                   , [Char]
"\"];"]
>                           ) [([Char], Set [a])]
ss
>                     showset :: Set [a] -> [Char]
showset Set [a]
ys = Char
'{' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [[a]] -> [Char]
showcl (Set [a] -> [[a]]
forall a. Set a -> [a]
Set.toList Set [a]
ys) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"
>                     showcl :: [[a]] -> [Char]
showcl = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [Char]) -> ([[a]] -> [[Char]]) -> [[a]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [Char]) -> [[a]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [Char]
showlist
>                     showlist :: [a] -> [Char]
showlist = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\x2009" ([[Char]] -> [Char]) -> ([a] -> [[Char]]) -> [a] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [Char]) -> [a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [Char]
showish
>                     showish :: a -> [Char]
showish = [Char] -> [Char]
deescape ([Char] -> [Char]) -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') ([Char] -> [Char]) -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show
>                     showtr :: [Char] -> [Char] -> [Char]
showtr [Char]
x [Char]
y = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y [Char] -> [Char] -> [Char]
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)
>     | [Char] -> Bool
forall c a. Container c a => c -> Bool
isEmpty [Char]
digits = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
>     | Bool
otherwise      = Int -> Char
forall a. Enum a => Int -> a
toEnum ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
digits) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
others
>     where ([Char]
digits, [Char]
others) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ([Char] -> Char -> Bool
forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn [Char]
"0123456789") (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs)
> deescape (Char
x:[Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
> deescape [Char]
_      = []

Compute the transitive reduction of a transitively closed 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
y) <- [(a, a)]
ps, (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> a -> Bool
good a
x a
y) [a]
nodes]
>     where nodes :: [a]
nodes = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> a
fst [(a, a)]
ps [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd [(a, a)]
ps
>           good :: a -> a -> a -> Bool
good a
x a
y a
z = (a
x,a
z) (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(a, a)]
ps Bool -> Bool -> Bool
|| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
z
>                        Bool -> Bool -> Bool
|| (a
z,a
y) (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(a, a)]
ps