{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module is responsible for rendering GraphViz graphs corresponding to an
--   execution of the REST algorithm.
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

-- | Controls how rejected paths should be visualized
data ShowRejectsOpt =
    ShowRejectsWithRule     -- ^ Display rejected paths, and the rule that generated them
  | ShowRejectsWithoutRule  -- ^ Display rejected paths, but don't display the rule that generated them
  | HideRejects             -- ^ Do not show rejected paths
  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

-- | Controls how rules, terms, orderings, and rejected paths should be displayed
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)

-- This determines how to layout
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 name gt printer paths@ generates a graphViz graph from @paths@ with name @name@.
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)