{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
module Test.IOTasks.Internal.OutputPattern (
  PatternKind (..),
  OutputPattern(..),
  convert,
  wildcard, nonEmptyWildcard, text, resultOf,
  decoratedResultOf,
  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 Control.Monad (void)

import Data.Bifunctor (second)
import Data.Char (isPrint, showLitChar, isSpace)
import Data.Either (isRight)
import Data.GADT.Compare
import Data.List (all)
import Data.Set as Set (Set)
import qualified Data.Set as Set

import Text.Parsec
import Type.Reflection

data OutputPattern (k :: PatternKind) where
  Wildcard :: WildcardType -> 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
  -- 'unevaluated' feedback group
  FeedbackGroupU :: forall (tk :: TermKind) a. (Typeable a, Show a) => Term tk a -> (a -> String) -> [OutputPattern 'SpecificationP] -> OutputPattern 'SpecificationP
  -- feedback group with constant feedback message
  FeedbackGroupE :: String -> [OutputPattern k] -> OutputPattern k

data WildcardType = NonEmpty | MaybeEmpty
  deriving (WildcardType -> WildcardType -> Bool
(WildcardType -> WildcardType -> Bool)
-> (WildcardType -> WildcardType -> Bool) -> Eq WildcardType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WildcardType -> WildcardType -> Bool
== :: WildcardType -> WildcardType -> Bool
$c/= :: WildcardType -> WildcardType -> Bool
/= :: WildcardType -> WildcardType -> Bool
Eq,Eq WildcardType
Eq WildcardType =>
(WildcardType -> WildcardType -> Ordering)
-> (WildcardType -> WildcardType -> Bool)
-> (WildcardType -> WildcardType -> Bool)
-> (WildcardType -> WildcardType -> Bool)
-> (WildcardType -> WildcardType -> Bool)
-> (WildcardType -> WildcardType -> WildcardType)
-> (WildcardType -> WildcardType -> WildcardType)
-> Ord WildcardType
WildcardType -> WildcardType -> Bool
WildcardType -> WildcardType -> Ordering
WildcardType -> WildcardType -> WildcardType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WildcardType -> WildcardType -> Ordering
compare :: WildcardType -> WildcardType -> Ordering
$c< :: WildcardType -> WildcardType -> Bool
< :: WildcardType -> WildcardType -> Bool
$c<= :: WildcardType -> WildcardType -> Bool
<= :: WildcardType -> WildcardType -> Bool
$c> :: WildcardType -> WildcardType -> Bool
> :: WildcardType -> WildcardType -> Bool
$c>= :: WildcardType -> WildcardType -> Bool
>= :: WildcardType -> WildcardType -> Bool
$cmax :: WildcardType -> WildcardType -> WildcardType
max :: WildcardType -> WildcardType -> WildcardType
$cmin :: WildcardType -> WildcardType -> WildcardType
min :: WildcardType -> WildcardType -> WildcardType
Ord,Int -> WildcardType -> ShowS
[WildcardType] -> ShowS
WildcardType -> String
(Int -> WildcardType -> ShowS)
-> (WildcardType -> String)
-> ([WildcardType] -> ShowS)
-> Show WildcardType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WildcardType -> ShowS
showsPrec :: Int -> WildcardType -> ShowS
$cshow :: WildcardType -> String
show :: WildcardType -> String
$cshowList :: [WildcardType] -> ShowS
showList :: [WildcardType] -> ShowS
Show)

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 (Wildcard WildcardType
b) = WildcardType -> OutputPattern 'SpecificationP
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard WildcardType
b
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
convert (FeedbackGroupU Term tk a
t a -> String
f [OutputPattern 'SpecificationP]
grp) = Term tk a
-> (a -> String)
-> [OutputPattern 'SpecificationP]
-> OutputPattern 'SpecificationP
forall (tk :: TermKind) a.
(Typeable a, Show a) =>
Term tk a
-> (a -> String)
-> [OutputPattern 'SpecificationP]
-> OutputPattern 'SpecificationP
FeedbackGroupU Term tk a
t a -> String
f [OutputPattern 'SpecificationP]
grp
convert (FeedbackGroupE String
str [OutputPattern k]
grp) = String
-> [OutputPattern 'SpecificationP] -> OutputPattern 'SpecificationP
forall (k :: PatternKind).
String -> [OutputPattern k] -> OutputPattern k
FeedbackGroupE String
str ([OutputPattern 'SpecificationP] -> OutputPattern 'SpecificationP)
-> [OutputPattern 'SpecificationP] -> OutputPattern 'SpecificationP
forall a b. (a -> b) -> a -> b
$ (OutputPattern k -> OutputPattern 'SpecificationP)
-> [OutputPattern k] -> [OutputPattern 'SpecificationP]
forall a b. (a -> b) -> [a] -> [b]
map OutputPattern k -> OutputPattern 'SpecificationP
forall (k :: PatternKind).
OutputPattern k -> OutputPattern 'SpecificationP
convert [OutputPattern k]
grp

wildcard :: OutputPattern k
wildcard :: forall (k :: PatternKind). OutputPattern k
wildcard = WildcardType -> OutputPattern k
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard WildcardType
MaybeEmpty

nonEmptyWildcard :: OutputPattern k
nonEmptyWildcard :: forall (k :: PatternKind). OutputPattern k
nonEmptyWildcard = WildcardType -> OutputPattern k
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard WildcardType
NonEmpty

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

-- | Mandatory decoration of some term's result
--
-- Conceptually we have
--
-- > writeOutput [decoratedResultOf t]
-- > = writeOutput [nonEmptyWildcard <> resultOf t <> wildcard, wildcard <> resultOf t <> nonEmptyWildcard]
--
-- but matching failure will produce a specialized message
decoratedResultOf :: (Typeable a, Show a) => Term tk a -> OutputPattern 'SpecificationP
decoratedResultOf :: forall a (tk :: TermKind).
(Typeable a, Show a) =>
Term tk a -> OutputPattern 'SpecificationP
decoratedResultOf Term tk a
t = Term tk a
-> (a -> String)
-> (OutputPattern 'SpecificationP
    -> [OutputPattern 'SpecificationP])
-> OutputPattern 'SpecificationP
forall a (tk :: TermKind).
(Typeable a, Show a) =>
Term tk a
-> (a -> String)
-> (OutputPattern 'SpecificationP
    -> [OutputPattern 'SpecificationP])
-> OutputPattern 'SpecificationP
patternGroup Term tk a
t
  (\a
v -> String
"<output containing "String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" and some decoration>")
  (\OutputPattern 'SpecificationP
p -> [OutputPattern 'SpecificationP
forall (k :: PatternKind). OutputPattern k
nonEmptyWildcard OutputPattern 'SpecificationP
-> OutputPattern 'SpecificationP -> OutputPattern 'SpecificationP
forall a. Semigroup a => a -> a -> a
<> OutputPattern 'SpecificationP
p OutputPattern 'SpecificationP
-> OutputPattern 'SpecificationP -> OutputPattern 'SpecificationP
forall a. Semigroup a => a -> a -> a
<> OutputPattern 'SpecificationP
forall (k :: PatternKind). OutputPattern k
wildcard, OutputPattern 'SpecificationP
forall (k :: PatternKind). OutputPattern k
wildcard OutputPattern 'SpecificationP
-> OutputPattern 'SpecificationP -> OutputPattern 'SpecificationP
forall a. Semigroup a => a -> a -> a
<> OutputPattern 'SpecificationP
p OutputPattern 'SpecificationP
-> OutputPattern 'SpecificationP -> OutputPattern 'SpecificationP
forall a. Semigroup a => a -> a -> a
<> OutputPattern 'SpecificationP
forall (k :: PatternKind). OutputPattern k
nonEmptyWildcard])

patternGroup :: (Typeable a, Show a) => Term tk a -> (a -> String) -> (OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP]) -> OutputPattern 'SpecificationP
patternGroup :: forall a (tk :: TermKind).
(Typeable a, Show a) =>
Term tk a
-> (a -> String)
-> (OutputPattern 'SpecificationP
    -> [OutputPattern 'SpecificationP])
-> OutputPattern 'SpecificationP
patternGroup Term tk a
t a -> String
f OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP]
ps
  | (OutputPattern 'SpecificationP -> Bool)
-> [OutputPattern 'SpecificationP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([SomeTermK] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([SomeTermK] -> Bool)
-> (OutputPattern 'SpecificationP -> [SomeTermK])
-> OutputPattern 'SpecificationP
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputPattern 'SpecificationP -> [SomeTermK]
forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms) (OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP]
ps OutputPattern 'SpecificationP
forall a. Monoid a => a
mempty) = Term tk a
-> (a -> String)
-> [OutputPattern 'SpecificationP]
-> OutputPattern 'SpecificationP
forall (tk :: TermKind) a.
(Typeable a, Show a) =>
Term tk a
-> (a -> String)
-> [OutputPattern 'SpecificationP]
-> OutputPattern 'SpecificationP
FeedbackGroupU Term tk a
t a -> String
f (OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP]
ps (OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP])
-> OutputPattern 'SpecificationP -> [OutputPattern 'SpecificationP]
forall a b. (a -> b) -> a -> b
$ Term tk a -> OutputPattern 'SpecificationP
forall a (tk :: TermKind).
(Typeable a, Show a) =>
Term tk a -> OutputPattern 'SpecificationP
resultOf Term tk a
t)
  | Bool
otherwise = String -> OutputPattern 'SpecificationP
forall a. HasCallStack => String -> a
error String
"patternGroup: patterns contain terms not specified in the first argument"

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)
-- Wildcard < Text < Sequence < ResultOf < FeedbackGroupU < FeedbackGroupE
instance Ord (OutputPattern k) where
  compare :: OutputPattern k -> OutputPattern k -> Ordering
compare (Wildcard WildcardType
t) (Wildcard WildcardType
u) = WildcardType -> WildcardType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WildcardType
t WildcardType
u
  compare (Text String
s) (Text String
t) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
s String
t
  compare (Sequence OutputPattern k
x1 OutputPattern k
x2) (Sequence OutputPattern k
y1 OutputPattern k
y2) = (OutputPattern k, OutputPattern k)
-> (OutputPattern k, OutputPattern k) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (OutputPattern k
x1,OutputPattern k
x2) (OutputPattern k
y1,OutputPattern k
y2)
  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 (FeedbackGroupU Term tk a
_ a -> String
_ [OutputPattern 'SpecificationP]
grp1) (FeedbackGroupU Term tk a
_ a -> String
_ [OutputPattern 'SpecificationP]
grp2) = [OutputPattern 'SpecificationP]
-> [OutputPattern 'SpecificationP] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [OutputPattern 'SpecificationP]
grp1 [OutputPattern 'SpecificationP]
grp2 -- ASSUMPTION: groups are uniquely determined by their patterns
  compare (FeedbackGroupE String
x [OutputPattern k]
grp1) (FeedbackGroupE String
y [OutputPattern k]
grp2) = (String, [OutputPattern k])
-> (String, [OutputPattern k]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (String
x,[OutputPattern k]
grp1) (String
y,[OutputPattern k]
grp2)
  --
  compare (Wildcard WildcardType
_) OutputPattern k
_ = Ordering
LT     -- Wildcard < {Text,Sequence,ResultOf,FeedbackGroup}
  compare OutputPattern k
_ (Wildcard WildcardType
_) = Ordering
GT     -- {Text,Sequence,ResultOf,FeedbackGroup} > Wildcard
  compare Text{} OutputPattern k
_ = Ordering
LT           -- Text < {Sequence,ResultOf,FeedbackGroup}
  compare OutputPattern k
_ Text{} = Ordering
GT           -- {Sequence,ResultOf,FeedbackGroup} > Text
  compare Sequence{} OutputPattern k
_ = Ordering
LT       -- Sequence < {ResultOf,FeedbackGroup}
  compare OutputPattern k
_ Sequence{} = Ordering
GT       -- {ResultOf,FeedbackGroup} > Sequence
  compare ResultOf{} OutputPattern k
_ = Ordering
LT       -- ResultOf < {FeedbackGroup}
  compare OutputPattern k
_ ResultOf{} = Ordering
GT       -- {FeedbackGroup} > ResultOf
  compare FeedbackGroupU{} OutputPattern k
_ = Ordering
LT -- FeedbackGroupU < {FeedbackGroupE}
  compare OutputPattern k
_ FeedbackGroupU{} = Ordering
GT -- {FeedbackGroupE} > FeedbackGroupU

deriving instance Show (OutputPattern 'TraceP)

instance Semigroup WildcardType where
  WildcardType
NonEmpty <> :: WildcardType -> WildcardType -> WildcardType
<> WildcardType
_ = WildcardType
NonEmpty
  WildcardType
_ <> WildcardType
NonEmpty = WildcardType
NonEmpty
  WildcardType
MaybeEmpty <> WildcardType
MaybeEmpty = WildcardType
MaybeEmpty

instance Semigroup (OutputPattern k) where
  Wildcard WildcardType
t <> :: OutputPattern k -> OutputPattern k -> OutputPattern k
<> Wildcard WildcardType
u = WildcardType -> OutputPattern k
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard (WildcardType
t WildcardType -> WildcardType -> WildcardType
forall a. Semigroup a => a -> a -> a
<> WildcardType
u)
  Wildcard WildcardType
t <> Sequence (Wildcard WildcardType
u) OutputPattern k
y = OutputPattern k -> OutputPattern k -> OutputPattern k
forall (k :: PatternKind).
OutputPattern k -> OutputPattern k -> OutputPattern k
Sequence (WildcardType -> OutputPattern k
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard (WildcardType
t WildcardType -> WildcardType -> WildcardType
forall a. Semigroup a => a -> a -> a
<> WildcardType
u)) 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 (Wildcard WildcardType
_) = []
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) = [Term tk a -> SomeTermK
forall a (k :: TermKind). Typeable a => Term k a -> SomeTermK
someTermK Term tk a
t]
valueTerms (FeedbackGroupU Term tk a
_ a -> String
_ [OutputPattern 'SpecificationP]
grp) = (OutputPattern 'SpecificationP -> [SomeTermK])
-> [OutputPattern 'SpecificationP] -> [SomeTermK]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OutputPattern 'SpecificationP -> [SomeTermK]
forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms [OutputPattern 'SpecificationP]
grp
valueTerms (FeedbackGroupE String
_ [OutputPattern k]
grp) = (OutputPattern k -> [SomeTermK])
-> [OutputPattern k] -> [SomeTermK]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OutputPattern k -> [SomeTermK]
forall (k :: PatternKind). OutputPattern k -> [SomeTermK]
valueTerms [OutputPattern k]
grp

evalPattern :: ValueMap -> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern :: forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
_ (Wildcard WildcardType
t) = (OverflowWarning
NoOverflow, WildcardType -> OutputPattern 'TraceP
forall (k :: PatternKind). WildcardType -> OutputPattern k
Wildcard WildcardType
t)
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
evalPattern ValueMap
e (FeedbackGroupE String
str [OutputPattern k]
grp) = String -> [OutputPattern 'TraceP] -> OutputPattern 'TraceP
forall (k :: PatternKind).
String -> [OutputPattern k] -> OutputPattern k
FeedbackGroupE String
str ([OutputPattern 'TraceP] -> OutputPattern 'TraceP)
-> (OverflowWarning, [OutputPattern 'TraceP])
-> (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` (OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP))
-> [OutputPattern k] -> (OverflowWarning, [OutputPattern 'TraceP])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
e) [OutputPattern k]
grp
evalPattern ValueMap
e (FeedbackGroupU Term tk a
t a -> String
f [OutputPattern 'SpecificationP]
grp) = String -> [OutputPattern 'TraceP] -> OutputPattern 'TraceP
forall (k :: PatternKind).
String -> [OutputPattern k] -> OutputPattern k
FeedbackGroupE String
str ([OutputPattern 'TraceP] -> OutputPattern 'TraceP)
-> (OverflowWarning, [OutputPattern 'TraceP])
-> (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` (OutputPattern 'SpecificationP
 -> (OverflowWarning, OutputPattern 'TraceP))
-> [OutputPattern 'SpecificationP]
-> (OverflowWarning, [OutputPattern 'TraceP])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ValueMap
-> OutputPattern 'SpecificationP
-> (OverflowWarning, OutputPattern 'TraceP)
forall (k :: PatternKind).
ValueMap
-> OutputPattern k -> (OverflowWarning, OutputPattern 'TraceP)
evalPattern ValueMap
e) [OutputPattern 'SpecificationP]
grp
  where
    -- ASSUMPTION: t is already part of the pattern os overflows are ignored here
    str :: String
str = a -> String
f (a -> String)
-> ((OverflowWarning, a) -> a) -> (OverflowWarning, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OverflowWarning, a) -> a
forall a b. (a, b) -> b
snd ((OverflowWarning, a) -> String) -> (OverflowWarning, a) -> String
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 (Wildcard WildcardType
NonEmpty) = String
"<some text>"
showPattern (Wildcard WildcardType
MaybeEmpty) = String
"<anything>"
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
showPattern (FeedbackGroupU Term tk a
_ a -> String
_ [OutputPattern 'SpecificationP]
grp) = String
"<unevaluated group: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show ((OutputPattern 'SpecificationP -> String)
-> [OutputPattern 'SpecificationP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map OutputPattern 'SpecificationP -> String
forall (k :: PatternKind). OutputPattern k -> String
showPattern [OutputPattern 'SpecificationP]
grp) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">"
showPattern (FeedbackGroupE String
str [OutputPattern k]
_) = String
str

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
showPatternInternal OutputPattern 'TraceP
q

-- hack to allow coverage check through parsing
-- (during coverage testing this functions is only called with Text arguments produced by the tested program)
showPatternInternal :: OutputPattern 'TraceP -> String
showPatternInternal :: OutputPattern 'TraceP -> String
showPatternInternal (Wildcard WildcardType
NonEmpty) = String
"_"
showPatternInternal (Wildcard WildcardType
MaybeEmpty) = String
" "
showPatternInternal (Text String
s) = String
s
showPatternInternal (Sequence OutputPattern 'TraceP
x OutputPattern 'TraceP
y) = OutputPattern 'TraceP -> String
showPatternInternal OutputPattern 'TraceP
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ OutputPattern 'TraceP -> String
showPatternInternal OutputPattern 'TraceP
y
showPatternInternal OutputPattern 'TraceP
_ = ShowS
forall a. HasCallStack => String -> a
error String
"showPatternInternal: not intended"

patternParser :: OutputPattern 'TraceP -> Parsec String () ()
patternParser :: OutputPattern 'TraceP -> Parsec String () ()
patternParser (Wildcard WildcardType
NonEmpty) = Parsec String () () -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec String () () -> Parsec String () ())
-> Parsec 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 (ParsecT String () Identity Char
whitespace ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
nonPrintable) ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
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
>> ParsecT String () Identity Char
printableNonWhitespace 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
forall (k :: PatternKind). OutputPattern k
wildcard
patternParser (Wildcard WildcardType
MaybeEmpty) = 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 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
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 String
s
patternParser (Sequence (Wildcard WildcardType
NonEmpty) OutputPattern 'TraceP
q) = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
whitespace ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
nonPrintable) ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
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
>> ParsecT String () Identity Char
printableNonWhitespace 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
forall (k :: PatternKind). OutputPattern k
wildcard OutputPattern 'TraceP
-> OutputPattern 'TraceP -> OutputPattern 'TraceP
forall a. Semigroup a => a -> a -> a
<> OutputPattern 'TraceP
q)
patternParser p :: OutputPattern 'TraceP
p@(Sequence (Wildcard WildcardType
MaybeEmpty) 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
patternParser (FeedbackGroupE String
_ [OutputPattern 'TraceP]
grp) = [Parsec String () ()] -> Parsec String () ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parsec String () ()] -> Parsec String () ())
-> [Parsec String () ()] -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ (OutputPattern 'TraceP -> Parsec String () ())
-> [OutputPattern 'TraceP] -> [Parsec String () ()]
forall a b. (a -> b) -> [a] -> [b]
map (Parsec String () () -> Parsec String () ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parsec String () () -> Parsec String () ())
-> (OutputPattern 'TraceP -> Parsec String () ())
-> OutputPattern 'TraceP
-> Parsec String () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputPattern 'TraceP -> Parsec String () ()
patternParser) [OutputPattern 'TraceP]
grp

printableNonWhitespace :: Parsec String () Char
printableNonWhitespace :: ParsecT String () Identity Char
printableNonWhitespace = (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy ((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c

whitespace :: Parsec String () Char
whitespace :: ParsecT String () Identity Char
whitespace = (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy ((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c

nonPrintable :: Parsec String () Char
nonPrintable :: ParsecT String () Identity Char
nonPrintable = (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPrint)