{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.REST.RESTDot (
PrettyPrinter(..)
, ShowRejectsOpt(..)
, writeDot
) where
import Data.List
import Data.Hashable
import qualified Data.Set as S
import qualified Data.HashSet as HS
import Language.REST.Dot
import Language.REST.Path
data ShowRejectsOpt =
ShowRejectsWithRule
| ShowRejectsWithoutRule
| HideRejects
deriving ShowRejectsOpt -> ShowRejectsOpt -> Bool
(ShowRejectsOpt -> ShowRejectsOpt -> Bool)
-> (ShowRejectsOpt -> ShowRejectsOpt -> Bool) -> Eq ShowRejectsOpt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
== :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
$c/= :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
/= :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
Eq
data PrettyPrinter rule term ord = PrettyPrinter
{ forall rule term ord. PrettyPrinter rule term ord -> rule -> String
printRule :: rule -> String
, forall rule term ord. PrettyPrinter rule term ord -> term -> String
printTerm :: term -> String
, forall rule term ord. PrettyPrinter rule term ord -> ord -> String
printOrd :: ord -> String
, forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects :: ShowRejectsOpt
}
rejNodeID :: (Hashable rule, Hashable term, Hashable a) => GraphType -> Path rule term a -> term -> String
rejNodeID :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> term -> String
rejNodeID GraphType
gt Path rule term a
p term
term = GraphType -> Path rule term a -> String
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> String
getNodeID GraphType
gt Path rule term a
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ term -> Int
forall a. Hashable a => a -> Int
hash term
term)
rejectedNodes :: forall rule term a . (Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> S.Set Node
rejectedNodes :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
rejectedNodes GraphType
_ PrettyPrinter rule term a
pp Path rule term a
_ | PrettyPrinter rule term a -> ShowRejectsOpt
forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp ShowRejectsOpt -> ShowRejectsOpt -> Bool
forall a. Eq a => a -> a -> Bool
== ShowRejectsOpt
HideRejects = Set Node
forall a. Set a
S.empty
rejectedNodes GraphType
gt PrettyPrinter rule term a
pp p :: Path rule term a
p@([Step rule term a]
_steps, PathTerm {HashSet (term, rule)
rejected :: HashSet (term, rule)
rejected :: forall rule term. PathTerm rule term -> HashSet (term, rule)
rejected}) = [Node] -> Set Node
forall a. Ord a => [a] -> Set a
S.fromList ([Node] -> Set Node) -> [Node] -> Set Node
forall a b. (a -> b) -> a -> b
$ ((term, rule) -> Node) -> [(term, rule)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (term, rule) -> Node
go (HashSet (term, rule) -> [(term, rule)]
forall a. HashSet a -> [a]
HS.toList HashSet (term, rule)
rejected)
where
go :: (term, rule) -> Node
go :: (term, rule) -> Node
go (term
rejTerm, rule
_r) = String -> String -> String -> String -> Node
Node (GraphType -> Path rule term a -> term -> String
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> term -> String
rejNodeID GraphType
gt Path rule term a
p term
rejTerm) (PrettyPrinter rule term a -> term -> String
forall rule term ord. PrettyPrinter rule term ord -> term -> String
printTerm PrettyPrinter rule term a
pp term
rejTerm) String
"dashed" String
"red"
getNodeID :: (Hashable rule, Hashable term, Hashable a) => GraphType -> Path rule term a -> String
getNodeID :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> String
getNodeID GraphType
Tree Path rule term a
p = String
"node" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Path rule term a -> Int
forall a. Hashable a => a -> Int
hash Path rule term a
p)
getNodeID GraphType
Dag ([Step rule term a]
steps, PathTerm rule term
t) =
String
"node" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PathTerm rule term -> Int
forall a. Hashable a => a -> Int
hash PathTerm rule term
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Step rule term a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Step rule term a]
steps)
getNodeID GraphType
Min ([Step rule term a]
_, PathTerm rule term
t) = String
"node" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PathTerm rule term -> Int
forall a. Hashable a => a -> Int
hash PathTerm rule term
t)
endNode :: (Hashable rule, Hashable term, Hashable a)
=> GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode GraphType
gt PrettyPrinter rule term a
pp p :: Path rule term a
p@([Step rule term a]
_, PathTerm rule term
t) =
let
thisNodeID :: String
thisNodeID = GraphType -> Path rule term a -> String
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> String
getNodeID GraphType
gt Path rule term a
p
in
String -> String -> String -> String -> Node
Node String
thisNodeID (PrettyPrinter rule term a -> term -> String
forall rule term ord. PrettyPrinter rule term ord -> term -> String
printTerm PrettyPrinter rule term a
pp (PathTerm rule term -> term
forall rule term. PathTerm rule term -> term
pathTerm PathTerm rule term
t)) String
"solid" String
"black"
toEdges :: forall rule term a . (Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> S.Set Edge
toEdges :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Edge
toEdges GraphType
gt PrettyPrinter rule term a
pp Path rule term a
path = Set Edge
allRej Set Edge -> Set Edge -> Set Edge
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [Edge] -> Set Edge
forall a. Ord a => [a] -> Set a
S.fromList ((Path rule term a -> Path rule term a -> Edge)
-> [Path rule term a] -> [Path rule term a] -> [Edge]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Path rule term a, Path rule term a) -> Edge)
-> Path rule term a -> Path rule term a -> Edge
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Path rule term a, Path rule term a) -> Edge
toEdge) [Path rule term a]
subs ([Path rule term a] -> [Path rule term a]
forall a. HasCallStack => [a] -> [a]
tail [Path rule term a]
subs))
where
subs :: [Path rule term a]
subs = Path rule term a -> [Path rule term a]
forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path
allRej :: Set Edge
allRej = [Set Edge] -> Set Edge
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Edge] -> Set Edge) -> [Set Edge] -> Set Edge
forall a b. (a -> b) -> a -> b
$ (Path rule term a -> Set Edge) -> [Path rule term a] -> [Set Edge]
forall a b. (a -> b) -> [a] -> [b]
map Path rule term a -> Set Edge
rejEdges [Path rule term a]
subs
rejEdges :: Path rule term a -> S.Set Edge
rejEdges :: Path rule term a -> Set Edge
rejEdges p :: Path rule term a
p@([Step rule term a]
_, PathTerm term
_ HashSet (term, rule)
rej) =
if PrettyPrinter rule term a -> ShowRejectsOpt
forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp ShowRejectsOpt -> ShowRejectsOpt -> Bool
forall a. Eq a => a -> a -> Bool
/= ShowRejectsOpt
HideRejects
then [Edge] -> Set Edge
forall a. Ord a => [a] -> Set a
S.fromList ([Edge] -> Set Edge) -> [Edge] -> Set Edge
forall a b. (a -> b) -> a -> b
$ ((term, rule) -> Edge) -> [(term, rule)] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (term, rule) -> Edge
go (HashSet (term, rule) -> [(term, rule)]
forall a. HashSet a -> [a]
HS.toList HashSet (term, rule)
rej)
else Set Edge
forall a. Set a
S.empty
where
ruleText :: rule -> String
ruleText rule
r =
if PrettyPrinter rule term a -> ShowRejectsOpt
forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp ShowRejectsOpt -> ShowRejectsOpt -> Bool
forall a. Eq a => a -> a -> Bool
== ShowRejectsOpt
ShowRejectsWithRule
then PrettyPrinter rule term a -> rule -> String
forall rule term ord. PrettyPrinter rule term ord -> rule -> String
printRule PrettyPrinter rule term a
pp rule
r
else String
""
go :: (term, rule) -> Edge
go (term
rejTerm, rule
r) =
String -> String -> String -> String -> String -> String -> Edge
Edge (Node -> String
nodeID (GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode GraphType
gt PrettyPrinter rule term a
pp Path rule term a
p)) (GraphType -> Path rule term a -> term -> String
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> term -> String
rejNodeID GraphType
gt Path rule term a
p term
rejTerm) (rule -> String
ruleText rule
r) String
"red" String
" " String
"dotted"
toEdge :: (Path rule term a, Path rule term a) -> Edge
toEdge :: (Path rule term a, Path rule term a) -> Edge
toEdge (Path rule term a
p0, p1 :: Path rule term a
p1@([Step rule term a]
ts, PathTerm rule term
_)) =
let
step :: Step rule term a
step = [Step rule term a] -> Step rule term a
forall a. HasCallStack => [a] -> a
last [Step rule term a]
ts
color :: String
color = if Step rule term a -> Bool
forall rule term a. Step rule term a -> Bool
fromPLE Step rule term a
step then String
"brown" else String
"darkgreen"
esubLabel :: String
esubLabel = PrettyPrinter rule term a -> a -> String
forall rule term ord. PrettyPrinter rule term ord -> ord -> String
printOrd PrettyPrinter rule term a
pp (Step rule term a -> a
forall rule term a. Step rule term a -> a
ordering Step rule term a
step)
startNodeID :: String
startNodeID = Node -> String
nodeID (GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode GraphType
gt PrettyPrinter rule term a
pp Path rule term a
p0)
endNodeID :: String
endNodeID = Node -> String
nodeID (GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode GraphType
gt PrettyPrinter rule term a
pp Path rule term a
p1)
in
String -> String -> String -> String -> String -> String -> Edge
Edge String
startNodeID String
endNodeID (PrettyPrinter rule term a -> rule -> String
forall rule term ord. PrettyPrinter rule term ord -> rule -> String
printRule PrettyPrinter rule term a
pp (Step rule term a -> rule
forall rule term a. Step rule term a -> rule
rule Step rule term a
step)) String
color String
esubLabel String
"solid"
subPaths :: Path rule term a -> [Path rule term a]
subPaths :: forall rule term a. Path rule term a -> [Path rule term a]
subPaths p :: Path rule term a
p@([Step rule term a]
xs, PathTerm rule term
_t) = ([Step rule term a] -> Path rule term a)
-> [[Step rule term a]] -> [Path rule term a]
forall a b. (a -> b) -> [a] -> [b]
map [Step rule term a] -> Path rule term a
forall {rule} {term} {a}.
[Step rule term a] -> ([Step rule term a], PathTerm rule term)
toPath ([[Step rule term a]] -> [[Step rule term a]]
forall a. HasCallStack => [a] -> [a]
tail ([[Step rule term a]] -> [[Step rule term a]])
-> [[Step rule term a]] -> [[Step rule term a]]
forall a b. (a -> b) -> a -> b
$ [Step rule term a] -> [[Step rule term a]]
forall a. [a] -> [[a]]
inits [Step rule term a]
xs) [Path rule term a] -> [Path rule term a] -> [Path rule term a]
forall a. [a] -> [a] -> [a]
++ [Path rule term a
p]
where
toPath :: [Step rule term a] -> ([Step rule term a], PathTerm rule term)
toPath [Step rule term a]
ys = ([Step rule term a] -> [Step rule term a]
forall a. HasCallStack => [a] -> [a]
init [Step rule term a]
ys, Step rule term a -> PathTerm rule term
forall rule term a. Step rule term a -> PathTerm rule term
term ([Step rule term a] -> Step rule term a
forall a. HasCallStack => [a] -> a
last [Step rule term a]
ys))
toNodes :: (Hashable rule, Hashable term, Hashable a) => GraphType -> PrettyPrinter rule term a -> Path rule term a -> S.Set Node
toNodes :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
toNodes GraphType
gt PrettyPrinter rule term a
pp Path rule term a
path =
let
r :: Set Node
r = [Set Node] -> Set Node
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Node] -> Set Node) -> [Set Node] -> Set Node
forall a b. (a -> b) -> a -> b
$ (Path rule term a -> Set Node) -> [Path rule term a] -> [Set Node]
forall a b. (a -> b) -> [a] -> [b]
map (GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
rejectedNodes GraphType
gt PrettyPrinter rule term a
pp) (Path rule term a -> [Path rule term a]
forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path)
n :: Set Node
n = [Node] -> Set Node
forall a. Ord a => [a] -> Set a
S.fromList ((Path rule term a -> Node) -> [Path rule term a] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> PrettyPrinter rule term a -> Path rule term a -> Node
endNode GraphType
gt PrettyPrinter rule term a
pp) (Path rule term a -> [Path rule term a]
forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path))
in
Set Node -> Set Node -> Set Node
forall a. Ord a => Set a -> Set a -> Set a
S.union Set Node
r Set Node
n
toGraph :: (Hashable rule, Hashable term, Hashable a) => GraphType -> PrettyPrinter rule term a -> S.Set (Path rule term a) -> DiGraph
toGraph :: forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Set (Path rule term a) -> DiGraph
toGraph GraphType
gt PrettyPrinter rule term a
pp Set (Path rule term a)
paths =
String -> Set Node -> Set Edge -> DiGraph
DiGraph String
"Rest" (Set (Set Node) -> Set Node
forall a. (Ord a, Eq a, Hashable a) => Set (Set a) -> Set a
unions ((Path rule term a -> Set Node)
-> Set (Path rule term a) -> Set (Set Node)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Node
toNodes GraphType
gt PrettyPrinter rule term a
pp) Set (Path rule term a)
paths)) (Set (Set Edge) -> Set Edge
forall a. (Ord a, Eq a, Hashable a) => Set (Set a) -> Set a
unions ((Path rule term a -> Set Edge)
-> Set (Path rule term a) -> Set (Set Edge)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Edge
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Path rule term a -> Set Edge
toEdges GraphType
gt PrettyPrinter rule term a
pp) Set (Path rule term a)
paths))
where
unions :: (Ord a, Eq a, Hashable a) => S.Set (S.Set a) -> S.Set a
unions :: forall a. (Ord a, Eq a, Hashable a) => Set (Set a) -> Set a
unions = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set a] -> Set a)
-> (Set (Set a) -> [Set a]) -> Set (Set a) -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set a) -> [Set a]
forall a. Set a -> [a]
S.toList
writeDot :: (Hashable rule, Hashable term, Ord a, Hashable a) =>
String -> GraphType -> PrettyPrinter rule term a -> S.Set (Path rule term a) -> IO ()
writeDot :: forall rule term a.
(Hashable rule, Hashable term, Ord a, Hashable a) =>
String
-> GraphType
-> PrettyPrinter rule term a
-> Set (Path rule term a)
-> IO ()
writeDot String
name GraphType
gt PrettyPrinter rule term a
printer Set (Path rule term a)
paths = String -> DiGraph -> IO ()
mkGraph String
name (GraphType
-> PrettyPrinter rule term a -> Set (Path rule term a) -> DiGraph
forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType
-> PrettyPrinter rule term a -> Set (Path rule term a) -> DiGraph
toGraph GraphType
gt PrettyPrinter rule term a
printer Set (Path rule term a)
paths)