{-# 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
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
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
(>:) :: 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