{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
$c/= :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
== :: ShowRejectsOpt -> ShowRejectsOpt -> Bool
$c== :: 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 = forall rule term a.
(Hashable rule, Hashable term, Hashable a) =>
GraphType -> Path rule term a -> String
getNodeID GraphType
gt Path rule term a
p forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ 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
_ | forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp forall a. Eq a => a -> a -> Bool
== ShowRejectsOpt
HideRejects = 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 :: forall rule term. PathTerm rule term -> HashSet (term, rule)
rejected :: HashSet (term, rule)
rejected}) = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (term, rule) -> Node
go (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 (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) (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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ 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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash PathTerm rule term
t) forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ 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 = 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 (forall rule term ord. PrettyPrinter rule term ord -> term -> String
printTerm PrettyPrinter rule term a
pp (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 forall a. Ord a => Set a -> Set a -> Set a
`S.union` forall a. Ord a => [a] -> Set a
S.fromList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (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 (forall a. [a] -> [a]
tail [Path rule term a]
subs))
    where
        subs :: [Path rule term a]
subs = forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path

        allRej :: Set Edge
allRej = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ 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 forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp forall a. Eq a => a -> a -> Bool
/= ShowRejectsOpt
HideRejects
          then forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (term, rule) -> Edge
go (forall a. HashSet a -> [a]
HS.toList HashSet (term, rule)
rej)
          else forall a. Set a
S.empty
            where
                ruleText :: rule -> String
ruleText rule
r =
                  if forall rule term ord. PrettyPrinter rule term ord -> ShowRejectsOpt
showRejects PrettyPrinter rule term a
pp forall a. Eq a => a -> a -> Bool
== ShowRejectsOpt
ShowRejectsWithRule
                  then 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 (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)) (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        = forall a. [a] -> a
last [Step rule term a]
ts
                color :: String
color       = if forall rule term a. Step rule term a -> Bool
fromPLE Step rule term a
step then String
"brown" else String
"darkgreen"
                esubLabel :: String
esubLabel    = forall rule term ord. PrettyPrinter rule term ord -> ord -> String
printOrd PrettyPrinter rule term a
pp (forall rule term a. Step rule term a -> a
ordering Step rule term a
step)
                startNodeID :: String
startNodeID = Node -> String
nodeID (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 (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 (forall rule term ord. PrettyPrinter rule term ord -> rule -> String
printRule PrettyPrinter rule term a
pp (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) = forall a b. (a -> b) -> [a] -> [b]
map forall {rule} {term} {a}.
[Step rule term a] -> ([Step rule term a], PathTerm rule term)
toPath (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
inits [Step rule term a]
xs) 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 = (forall a. [a] -> [a]
init [Step rule term a]
ys, forall rule term a. Step rule term a -> PathTerm rule term
term (forall a. [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 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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) (forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path)
        n :: Set Node
n = forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map (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) (forall rule term a. Path rule term a -> [Path rule term a]
subPaths Path rule term a
path))
    in
        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" (forall a. (Ord a, Eq a, Hashable a) => Set (Set a) -> Set a
unions (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (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)) (forall a. (Ord a, Eq a, Hashable a) => Set (Set a) -> Set a
unions (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (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 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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)