{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.IOTasks.Internal.OutputPattern (
  PatternKind (..),
  OutputPattern(..),
  convert,
  wildcard, text, resultOf,
  valueTerms,
  showPattern, showPatternSimple,
  evalPattern,
  AddLinebreaks, evalPatternSet, evalPatternSet',
  (>:),
  ) where

import Prelude hiding (all)

import Test.IOTasks.Overflow
import Test.IOTasks.Internal.Term
import Test.IOTasks.ValueMap

import Data.Either (isRight)
import Data.Bifunctor (second)
import Type.Reflection
import Data.Set as Set (Set)
import qualified Data.Set as Set

import Text.Parsec
import Data.Char (isPrint, showLitChar)
import Control.Monad (void)
import Data.GADT.Compare

data OutputPattern (k :: PatternKind) where
  Wildcard :: OutputPattern k
  Text :: String -> OutputPattern k
  Sequence :: OutputPattern k -> OutputPattern k -> OutputPattern k
  ResultOf :: forall (tk :: TermKind) a. (Typeable a, Show a) => Term tk a -> OutputPattern 'SpecificationP

data PatternKind = SpecificationP | TraceP

-- k ~ 'SpecificationP is the biggest possible version of OutputPattern
convert :: OutputPattern k -> OutputPattern 'SpecificationP
convert :: forall (k :: PatternKind).
OutputPattern k -> OutputPattern 'SpecificationP
convert OutputPattern k
Wildcard = OutputPattern 'SpecificationP
forall (k :: PatternKind). OutputPattern k
Wildcard
convert (Text String
s) = String -> OutputPattern 'SpecificationP
forall (k :: PatternKind). String -> OutputPattern k
Text String
s
convert (Sequence OutputPattern k
x OutputPattern k
y) = OutputPattern 'SpecificationP
-> OutputPattern 'SpecificationP -> OutputPattern 'SpecificationP
forall (k :: PatternKind).
OutputPattern k -> OutputPattern k -> OutputPattern k
Sequence (OutputPattern k -> OutputPattern 'SpecificationP
forall (k :: PatternKind).
OutputPattern k -> OutputPattern 'SpecificationP
convert OutputPattern k
x) (OutputPattern k -> OutputPattern 'SpecificationP
forall (k :: PatternKind).
OutputPattern k -> OutputPattern 'SpecificationP
convert OutputPattern k
y)
convert (ResultOf Term tk a
t) = Term tk a -> OutputPattern 'SpecificationP
forall (tk :: TermKind) a.
(Typeable a, Show a) =>
Term tk a -> OutputPattern 'SpecificationP
ResultOf Term tk a
t

wildcard :: OutputPattern k
wildcard :: forall (k :: PatternKind). OutputPattern k
wildcard = OutputPattern k
forall (k :: PatternKind). OutputPattern k
Wildcard

text :: String -> OutputPattern k
text :: forall (k :: PatternKind). String -> OutputPattern k
text = String -> OutputPattern k
forall (k :: PatternKind). String -> OutputPattern k
Text

resultOf :: (Typeable a, Show a) => Term tk a -> OutputPattern 'SpecificationP
resultOf :: forall a (tk :: TermKind).
(Typeable a, Show a) =>
Term tk a -> OutputPattern 'SpecificationP
resultOf = Term tk a -> OutputPattern 'SpecificationP
forall (tk :: TermKind) a.
(Typeable a, Show a) =>
Term tk a -> OutputPattern 'SpecificationP
ResultOf

instance Eq (OutputPattern k) where
  OutputPattern k
x == :: OutputPattern k -> OutputPattern k -> Bool
== OutputPattern k
y = OutputPattern k -> OutputPattern k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare OutputPattern k
x OutputPattern k
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- syntactic ordering (to put OutputPatterns in Sets)
instance Ord (OutputPattern k) where
  compare :: OutputPattern k -> OutputPattern k -> Ordering
compare OutputPattern k
Wildcard OutputPattern k
Wildcard = Ordering
EQ
  compare OutputPattern k
Wildcard OutputPattern k
_ = Ordering
LT
  compare OutputPattern k
_ OutputPattern k
Wildcard = Ordering
GT
  compare (Text String
s) (Text String
t) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
s String
t
  compare Text{} OutputPattern k
_ = Ordering
LT
  compare Sequence{} Text{} = Ordering
GT
  compare (Sequence OutputPattern k
x1 OutputPattern k
x2) (Sequence OutputPattern k
y1 OutputPattern k
y2) =
    case OutputPattern k -> OutputPattern k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare OutputPattern k
x1 OutputPattern k
y1 of
      Ordering
EQ -> OutputPattern k -> OutputPattern k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare OutputPattern k
x2 OutputPattern k
y2
      Ordering
r -> Ordering
r
  compare (ResultOf (Term tk a
t :: Term k1 a)) (ResultOf (Term tk a
u :: Term k2 b)) =
    case TypeRep a -> TypeRep a -> GOrdering a a
forall a b. TypeRep a -> TypeRep b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a) (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @b) of
      GOrdering a a
GLT -> Ordering
LT
      GOrdering a a
GEQ -> Term tk a -> Term tk a -> Ordering
forall a (k1 :: TermKind) (k2 :: TermKind).
Typeable a =>
Term k1 a -> Term k2 a -> Ordering
compareK Term tk a
t Term tk a
Term tk a
u
      GOrdering a a
GGT -> Ordering
GT
  compare ResultOf{} OutputPattern k
_ = Ordering
GT
  compare OutputPattern k
_ ResultOf{} = Ordering
LT

deriving instance Show (OutputPattern k)

instance Semigroup (OutputPattern k) where
  OutputPattern k
Wildcard <> :: OutputPattern k -> OutputPattern k -> OutputPattern k
<> OutputPattern k
Wildcard = OutputPattern k
forall (k :: PatternKind). OutputPattern k
Wildcard
  OutputPattern k
Wildcard <> Sequence OutputPattern k
Wildcard OutputPattern k
y = OutputPattern k -> OutputPattern k -> OutputPattern k
forall (k :: PatternKind).
OutputPattern k -> OutputPattern k -> OutputPattern k
Sequence OutputPattern k
forall (k :: PatternKind). OutputPattern k
Wildcard OutputPattern k
y
  Text String
"" <> OutputPattern k
y = OutputPattern k
y
  OutputPattern k
x <> Text String
"" = OutputPattern k
x
  Text String
s <> Text String
t = String -> OutputPattern k
forall (k :: PatternKind). String -> OutputPattern k
Text (String -> OutputPattern k) -> String -> OutputPattern k
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
  Sequence OutputPattern k
x OutputPattern k
y <> OutputPattern k
z = OutputPattern k -> OutputPattern k -> OutputPattern k
forall (k :: PatternKind).
OutputPattern k -> OutputPattern k -> OutputPattern k
Sequence OutputPattern k
x (OutputPattern k -> OutputPattern k)
-> OutputPattern k -> OutputPattern k
forall a b. (a -> b) -> a -> b
$ OutputPattern k
y OutputPattern k -> OutputPattern k -> OutputPattern k
forall a. Semigroup a => a -> a -> a
<> OutputPattern k
z
  OutputPattern k
x <> OutputPattern k
y = OutputPattern k -> OutputPattern k -> OutputPattern k
forall (k :: PatternKind).
OutputPattern k -> OutputPattern k -> OutputPattern k
Sequence OutputPattern k
x OutputPattern k
y

instance Monoid (OutputPattern k) where
  mempty :: OutputPattern k
mempty = String -> OutputPattern k
forall (k :: PatternKind). String -> OutputPattern k
Text String
""

valueTerms :: OutputPattern k -> [SomeTermK]
valueTerms :: forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms OutputPattern k
Wildcard = []
valueTerms Text{} = []
valueTerms (Sequence OutputPattern k
x OutputPattern k
y) = OutputPattern k -> [SomeTermK]
forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms OutputPattern k
x [SomeTermK] -> [SomeTermK] -> [SomeTermK]
forall a. [a] -> [a] -> [a]
++ OutputPattern k -> [SomeTermK]
forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms OutputPattern k
y
valueTerms (ResultOf Term tk a
t) = [SomeTerm tk -> SomeTermK
forall (k :: TermKind). SomeTerm k -> SomeTermK
SomeTermK (SomeTerm tk -> SomeTermK) -> SomeTerm tk -> SomeTermK
forall a b. (a -> b) -> a -> b
$ Term tk a -> SomeTerm tk
forall a (k :: TermKind). Typeable a => Term k a -> SomeTerm k
SomeTerm Term tk a
t]

evalPattern :: ValueMap -> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern :: forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
_ OutputPattern k
Wildcard = (OverflowWarning
NoOverflow, OutputPattern 'TraceP
forall (k :: PatternKind). OutputPattern k
Wildcard)
evalPattern ValueMap
_ (Text String
s) = (OverflowWarning
NoOverflow, String -> OutputPattern 'TraceP
forall (k :: PatternKind). String -> OutputPattern k
Text String
s)
evalPattern ValueMap
e (Sequence OutputPattern k
x OutputPattern k
y) = ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
e OutputPattern k
x (OverflowWarning, OutputPattern 'TraceP)
-> (OverflowWarning, OutputPattern 'TraceP)
-> (OverflowWarning, OutputPattern 'TraceP)
forall a. Semigroup a => a -> a -> a
<> ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
e OutputPattern k
y
evalPattern ValueMap
e (ResultOf Term tk a
t) = (a -> OutputPattern 'TraceP)
-> (OverflowWarning, a) -> (OverflowWarning, OutputPattern 'TraceP)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (String -> OutputPattern 'TraceP
forall (k :: PatternKind). String -> OutputPattern k
Text (String -> OutputPattern 'TraceP)
-> (a -> String) -> a -> OutputPattern 'TraceP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. (Show a, Typeable a) => a -> String
showResult) ((OverflowWarning, a) -> (OverflowWarning, OutputPattern 'TraceP))
-> (OverflowWarning, a) -> (OverflowWarning, OutputPattern 'TraceP)
forall a b. (a -> b) -> a -> b
$ ValueMap -> Term tk a -> (OverflowWarning, a)
forall a (k :: TermKind).
Typeable a =>
ValueMap -> Term k a -> (OverflowWarning, a)
oEval ValueMap
e Term tk a
t

type AddLinebreaks = Bool

evalPatternSet :: ValueMap -> Set (OutputPattern k) -> (OverflowWarning, Set (OutputPattern 'TraceP))
evalPatternSet :: forall (k :: PatternKind).
ValueMap
-> Set (OutputPattern k)
-> (OverflowWarning, Set (OutputPattern 'TraceP))
evalPatternSet = Bool
-> ValueMap
-> Set (OutputPattern k)
-> (OverflowWarning, Set (OutputPattern 'TraceP))
forall (k :: PatternKind).
Bool
-> ValueMap
-> Set (OutputPattern k)
-> (OverflowWarning, Set (OutputPattern 'TraceP))
evalPatternSet' Bool
True

evalPatternSet' :: AddLinebreaks -> ValueMap -> Set (OutputPattern k) -> (OverflowWarning, Set (OutputPattern 'TraceP))
evalPatternSet' :: forall (k :: PatternKind).
Bool
-> ValueMap
-> Set (OutputPattern k)
-> (OverflowWarning, Set (OutputPattern 'TraceP))
evalPatternSet' Bool
addLinebreaks ValueMap
e = (OutputPattern k
 -> (OverflowWarning, Set (OutputPattern 'TraceP))
 -> (OverflowWarning, Set (OutputPattern 'TraceP)))
-> (OverflowWarning, Set (OutputPattern 'TraceP))
-> Set (OutputPattern k)
-> (OverflowWarning, Set (OutputPattern 'TraceP))
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr OutputPattern k
-> (OverflowWarning, Set (OutputPattern 'TraceP))
-> (OverflowWarning, Set (OutputPattern 'TraceP))
forall (k :: PatternKind).
OutputPattern k
-> (OverflowWarning, Set (OutputPattern 'TraceP))
-> (OverflowWarning, Set (OutputPattern 'TraceP))
phi (OverflowWarning
forall a. Monoid a => a
mempty, Set (OutputPattern 'TraceP)
forall a. Set a
Set.empty)
  where
    phi :: OutputPattern k -> (OverflowWarning, Set (OutputPattern 'TraceP)) -> (OverflowWarning, Set (OutputPattern 'TraceP))
    phi :: forall (k :: PatternKind).
OutputPattern k
-> (OverflowWarning, Set (OutputPattern 'TraceP))
-> (OverflowWarning, Set (OutputPattern 'TraceP))
phi OutputPattern k
p (OverflowWarning
w,Set (OutputPattern 'TraceP)
set) =
      let (OverflowWarning
w', OutputPattern 'TraceP
p') = ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
e OutputPattern k
p
      in (OverflowWarning
w' OverflowWarning -> OverflowWarning -> OverflowWarning
forall a. Semigroup a => a -> a -> a
<> OverflowWarning
w, [OutputPattern 'TraceP] -> Set (OutputPattern 'TraceP)
forall a. Ord a => [a] -> Set a
Set.fromList (OutputPattern 'TraceP
p' OutputPattern 'TraceP
-> [OutputPattern 'TraceP] -> [OutputPattern 'TraceP]
forall a. a -> [a] -> [a]
: [OutputPattern 'TraceP
p'OutputPattern 'TraceP
-> OutputPattern 'TraceP -> OutputPattern 'TraceP
forall a. Semigroup a => a -> a -> a
<>String -> OutputPattern 'TraceP
forall (k :: PatternKind). String -> OutputPattern k
text String
"\n" | Bool
addLinebreaks]) Set (OutputPattern 'TraceP)
-> Set (OutputPattern 'TraceP) -> Set (OutputPattern 'TraceP)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (OutputPattern 'TraceP)
set)

showPattern :: OutputPattern k -> String
showPattern :: forall (k :: PatternKind). OutputPattern k -> String
showPattern OutputPattern k
Wildcard = String
"_"
showPattern (Text String
s) = (Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
showLitChar String
"" String
s
showPattern (Sequence OutputPattern k
x OutputPattern k
y) = OutputPattern k -> String
forall (k :: PatternKind). OutputPattern k -> String
showPattern OutputPattern k
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ OutputPattern k -> String
forall (k :: PatternKind). OutputPattern k -> String
showPattern OutputPattern k
y
showPattern (ResultOf Term tk a
t) = Term tk a -> String
forall a. Show a => a -> String
show Term tk a
t

showPatternSimple :: OutputPattern k -> String
showPatternSimple :: forall (k :: PatternKind). OutputPattern k -> String
showPatternSimple OutputPattern k
p =
  case ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ OutputPattern k -> String
forall (k :: PatternKind). OutputPattern k -> String
showPattern OutputPattern k
p of
  (Char
'n':Char
'\\':String
s) -> ShowS
forall a. [a] -> [a]
reverse String
s
  String
s -> ShowS
forall a. [a] -> [a]
reverse String
s

-- | coverage relation on patterns
(>:) :: OutputPattern 'TraceP -> OutputPattern 'TraceP -> Bool
OutputPattern 'TraceP
p >: :: OutputPattern 'TraceP -> OutputPattern 'TraceP -> Bool
>: OutputPattern 'TraceP
q = Either ParseError () -> Bool
forall a b. Either a b -> Bool
isRight (Either ParseError () -> Bool) -> Either ParseError () -> Bool
forall a b. (a -> b) -> a -> b
$ Parsec String () () -> String -> String -> Either ParseError ()
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
p Parsec String () () -> Parsec String () () -> Parsec String () ()
forall a. Semigroup a => a -> a -> a
<> Parsec String () ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) String
"" (String -> Either ParseError ()) -> String -> Either ParseError ()
forall a b. (a -> b) -> a -> b
$ OutputPattern 'TraceP -> String
forall (k :: PatternKind). OutputPattern k -> String
showPattern OutputPattern 'TraceP
q

patternParser :: OutputPattern 'TraceP -> Parsec String () ()
patternParser :: OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
Wildcard = ParsecT String () Identity String -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String -> Parsec String () ())
-> ParsecT String () Identity String -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isPrint)
patternParser (Text String
s) = ParsecT String () Identity String -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String -> Parsec String () ())
-> ParsecT String () Identity String -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string ((Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
showLitChar String
"" String
s)
patternParser p :: OutputPattern 'TraceP
p@(Sequence OutputPattern 'TraceP
Wildcard OutputPattern 'TraceP
q) = Parsec String () () -> Parsec String () ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity Char
-> Parsec String () () -> Parsec String () ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
p) Parsec String () () -> Parsec String () () -> Parsec String () ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
q
patternParser (Sequence OutputPattern 'TraceP
p OutputPattern 'TraceP
q) = OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
p Parsec String () () -> Parsec String () () -> Parsec String () ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputPattern 'TraceP -> Parsec String () ()
patternParser OutputPattern 'TraceP
q