{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
-- | utility methods for Predicate / methods for displaying the evaluation tree

module Predicate.Util (
 -- ** Val

    Val(..)
  , _Fail
  , _Val
  , _ValEither

  -- ** TT typed tree

  , TT
  , ttVal
  , ttValBool
  , ttString
  , ttForest

 -- ** PE untyped tree

  , PE(..)
  , peValP
  , peString

 -- ** ValP

  , ValP(..)
  , _FailP
  , _TrueP
  , _FalseP
  , _ValP

 -- ** create tree

  , mkNode
  , mkNodeB
  , mkNodeCopy

 -- ** tree manipulation

  , getValAndPE
  , getValLRFromTT
  , getValueLR
  , Inline (..)
  , prefixNumberToTT
  , prefixMsg
  , splitAndAlign
  , verboseList
  , fixTTBool
  , topMessage
  , hasNoTree

 -- ** options

  , POpts
  , Debug(..)
  , Disp(..)
  , Color(..)
  , isVerbose
  , colorValBool
  , colorValP
  , Long(..)
  , setOtherEffects
  , type Color1
  , type Color2
  , type Color3
  , type Color4
  , type Color5
  , type Other1
  , type Other2

  , type OZ
  , type OL
  , type OA
  , type OAB
  , type OAN
  , type OAV
  , type OANV
  , type OU
  , type OUB
  , type OUN
  , type OUV
  , type OUNV

  , HOpts(..)
  , Opt(..)
  , OptC
  , type OptT
  , getOpt
  , subopts
  , _DVerbose
  , _Debug
  , defOpts

-- ** formatting functions

  , show3
  , show3'
  , lit3
  , litVerbose
  , showVerbose
  , showL
  , litL
  , litBL
  , litBS

 -- ** printing methods

  , prtTreePure
  , formatOMsg
  , prtTree

 -- ** MonadEval

  , MonadEval(..)

 -- ** miscellaneous

  , hh
  , chkSize
  , chkSize2
  , badLength
  ) where
import Predicate.Misc
import GHC.TypeLits (Symbol, Nat, KnownSymbol, KnownNat)
import Control.Lens
import Control.Arrow (Arrow((&&&)), ArrowChoice(left))
import Data.List (intercalate, isInfixOf)
import Data.Tree (drawTree, Forest, Tree(Node))
import Data.Tree.Lens (root)
import System.Console.Pretty (Color(..))
import qualified System.Console.Pretty as C
import qualified Control.Exception as E
import Control.DeepSeq (NFData, ($!!))
import System.IO.Unsafe (unsafePerformIO)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as N
import Data.Either (partitionEithers)
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Char8 as BS8
import Data.Monoid (Last(Last))
import Data.Maybe (fromMaybe)
import Data.Coerce (coerce)
import Data.Foldable (toList)
import qualified Safe (initSafe, fromJustNote)
import Control.Monad (ap)
import Data.Bool (bool)
import GHC.Generics (Generic, Generic1)
import qualified Language.Haskell.TH.Lift as TH
import Instances.TH.Lift ()
-- $setup

-- >>> :set -XDataKinds

-- >>> :set -XTypeApplications

-- >>> :set -XTypeOperators

-- >>> :m + Control.Arrow


-- | contains the untyped result from evaluating an expression

data ValP =
    FailP !String -- ^ evaluation failed

  | FalseP       -- ^ False predicate

  | TrueP        -- ^ True predicate

  | ValP     -- ^ Any value

  deriving stock (Int -> ValP -> ShowS
[ValP] -> ShowS
ValP -> String
(Int -> ValP -> ShowS)
-> (ValP -> String) -> ([ValP] -> ShowS) -> Show ValP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValP] -> ShowS
$cshowList :: [ValP] -> ShowS
show :: ValP -> String
$cshow :: ValP -> String
showsPrec :: Int -> ValP -> ShowS
$cshowsPrec :: Int -> ValP -> ShowS
Show, Eq ValP
Eq ValP
-> (ValP -> ValP -> Ordering)
-> (ValP -> ValP -> Bool)
-> (ValP -> ValP -> Bool)
-> (ValP -> ValP -> Bool)
-> (ValP -> ValP -> Bool)
-> (ValP -> ValP -> ValP)
-> (ValP -> ValP -> ValP)
-> Ord ValP
ValP -> ValP -> Bool
ValP -> ValP -> Ordering
ValP -> ValP -> ValP
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
min :: ValP -> ValP -> ValP
$cmin :: ValP -> ValP -> ValP
max :: ValP -> ValP -> ValP
$cmax :: ValP -> ValP -> ValP
>= :: ValP -> ValP -> Bool
$c>= :: ValP -> ValP -> Bool
> :: ValP -> ValP -> Bool
$c> :: ValP -> ValP -> Bool
<= :: ValP -> ValP -> Bool
$c<= :: ValP -> ValP -> Bool
< :: ValP -> ValP -> Bool
$c< :: ValP -> ValP -> Bool
compare :: ValP -> ValP -> Ordering
$ccompare :: ValP -> ValP -> Ordering
$cp1Ord :: Eq ValP
Ord, ValP -> ValP -> Bool
(ValP -> ValP -> Bool) -> (ValP -> ValP -> Bool) -> Eq ValP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValP -> ValP -> Bool
$c/= :: ValP -> ValP -> Bool
== :: ValP -> ValP -> Bool
$c== :: ValP -> ValP -> Bool
Eq, ReadPrec [ValP]
ReadPrec ValP
Int -> ReadS ValP
ReadS [ValP]
(Int -> ReadS ValP)
-> ReadS [ValP] -> ReadPrec ValP -> ReadPrec [ValP] -> Read ValP
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ValP]
$creadListPrec :: ReadPrec [ValP]
readPrec :: ReadPrec ValP
$creadPrec :: ReadPrec ValP
readList :: ReadS [ValP]
$creadList :: ReadS [ValP]
readsPrec :: Int -> ReadS ValP
$creadsPrec :: Int -> ReadS ValP
Read, (forall x. ValP -> Rep ValP x)
-> (forall x. Rep ValP x -> ValP) -> Generic ValP
forall x. Rep ValP x -> ValP
forall x. ValP -> Rep ValP x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValP x -> ValP
$cfrom :: forall x. ValP -> Rep ValP x
Generic)
  deriving ValP -> Q Exp
ValP -> Q (TExp ValP)
(ValP -> Q Exp) -> (ValP -> Q (TExp ValP)) -> Lift ValP
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: ValP -> Q (TExp ValP)
$cliftTyped :: ValP -> Q (TExp ValP)
lift :: ValP -> Q Exp
$clift :: ValP -> Q Exp
TH.Lift

makePrisms ''ValP

-- | untyped child node for 'TT'

data PE = PE { PE -> ValP
_peValP :: !ValP -- ^ holds the result of running the predicate

             , PE -> String
_peString :: !String -- ^ optional strings to include in the results

             } deriving stock (Int -> PE -> ShowS
[PE] -> ShowS
PE -> String
(Int -> PE -> ShowS)
-> (PE -> String) -> ([PE] -> ShowS) -> Show PE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PE] -> ShowS
$cshowList :: [PE] -> ShowS
show :: PE -> String
$cshow :: PE -> String
showsPrec :: Int -> PE -> ShowS
$cshowsPrec :: Int -> PE -> ShowS
Show, ReadPrec [PE]
ReadPrec PE
Int -> ReadS PE
ReadS [PE]
(Int -> ReadS PE)
-> ReadS [PE] -> ReadPrec PE -> ReadPrec [PE] -> Read PE
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PE]
$creadListPrec :: ReadPrec [PE]
readPrec :: ReadPrec PE
$creadPrec :: ReadPrec PE
readList :: ReadS [PE]
$creadList :: ReadS [PE]
readsPrec :: Int -> ReadS PE
$creadsPrec :: Int -> ReadS PE
Read, PE -> PE -> Bool
(PE -> PE -> Bool) -> (PE -> PE -> Bool) -> Eq PE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PE -> PE -> Bool
$c/= :: PE -> PE -> Bool
== :: PE -> PE -> Bool
$c== :: PE -> PE -> Bool
Eq, (forall x. PE -> Rep PE x)
-> (forall x. Rep PE x -> PE) -> Generic PE
forall x. Rep PE x -> PE
forall x. PE -> Rep PE x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PE x -> PE
$cfrom :: forall x. PE -> Rep PE x
Generic)
               deriving PE -> Q Exp
PE -> Q (TExp PE)
(PE -> Q Exp) -> (PE -> Q (TExp PE)) -> Lift PE
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PE -> Q (TExp PE)
$cliftTyped :: PE -> Q (TExp PE)
lift :: PE -> Q Exp
$clift :: PE -> Q Exp
TH.Lift

makeLenses ''PE

instance Monoid PE where
  mempty :: PE
mempty = ValP -> String -> PE
PE ValP
forall a. Monoid a => a
mempty String
forall a. Monoid a => a
mempty

-- | concatenate two strings with delimiter

--

-- >>> jamSS "xyz" "abc"

-- "xyz | abc"

--

-- >>> jamSS "" "abc"

-- "abc"

--

-- >>> jamSS "xyz" ""

-- "xyz"

--

-- >>> jamSS "" ""

-- ""

--

jamSS :: String -> String -> String
jamSS :: String -> ShowS
jamSS String
s String
s1 = String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
s1 then String
"" else String
" | ") String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s1

instance Semigroup PE where
  PE ValP
b String
s <> :: PE -> PE -> PE
<> PE ValP
b1 String
s1 = ValP -> String -> PE
PE (ValP
b ValP -> ValP -> ValP
forall a. Semigroup a => a -> a -> a
<> ValP
b1) (String -> ShowS
jamSS String
s String
s1)

-- | semigroup for ValP

--

-- >>> TrueP <> FalseP <> ValP

-- FalseP

--

-- >>> ValP <> TrueP <> FalseP

-- FalseP

--

-- >>> ValP <> TrueP <> ValP

-- TrueP

--

-- >>> FailP "abc" <> (TrueP <> FalseP) <> FailP "def"

-- FailP "abc | def"

--

-- >>> (FailP "abc" <> TrueP) <> (FalseP <> FailP "def")

-- FailP "abc | def"

--

-- >>> FailP "" <> (TrueP <> FalseP) <> FailP "def"

-- FailP "def"

--

-- >>> FailP "abc" <> FailP "" <> FailP "def"

-- FailP "abc | def"

--

-- >>> FailP "abc" <> FailP "xyz" <> FailP "def"

-- FailP "abc | xyz | def"

--

instance Semigroup ValP where
   FailP String
s <> :: ValP -> ValP -> ValP
<> FailP String
s1 = String -> ValP
FailP (String -> ShowS
jamSS String
s String
s1)
   FailP String
s <> ValP
_ = String -> ValP
FailP String
s
   ValP
_ <> FailP String
s = String -> ValP
FailP String
s
   ValP
FalseP <> ValP
_ = ValP
FalseP
   ValP
_ <> ValP
FalseP = ValP
FalseP
   ValP
TrueP <> ValP
_ = ValP
TrueP
   ValP
_ <> ValP
TrueP = ValP
TrueP
   ValP
ValP <> ValP
ValP = ValP
ValP

instance Monoid ValP where
  mempty :: ValP
mempty = ValP
ValP

-- | contains the typed result from evaluating an expression

data Val a = Fail !String | Val !a
  deriving stock (Int -> Val a -> ShowS
[Val a] -> ShowS
Val a -> String
(Int -> Val a -> ShowS)
-> (Val a -> String) -> ([Val a] -> ShowS) -> Show (Val a)
forall a. Show a => Int -> Val a -> ShowS
forall a. Show a => [Val a] -> ShowS
forall a. Show a => Val a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Val a] -> ShowS
$cshowList :: forall a. Show a => [Val a] -> ShowS
show :: Val a -> String
$cshow :: forall a. Show a => Val a -> String
showsPrec :: Int -> Val a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Val a -> ShowS
Show, Val a -> Val a -> Bool
(Val a -> Val a -> Bool) -> (Val a -> Val a -> Bool) -> Eq (Val a)
forall a. Eq a => Val a -> Val a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Val a -> Val a -> Bool
$c/= :: forall a. Eq a => Val a -> Val a -> Bool
== :: Val a -> Val a -> Bool
$c== :: forall a. Eq a => Val a -> Val a -> Bool
Eq, Eq (Val a)
Eq (Val a)
-> (Val a -> Val a -> Ordering)
-> (Val a -> Val a -> Bool)
-> (Val a -> Val a -> Bool)
-> (Val a -> Val a -> Bool)
-> (Val a -> Val a -> Bool)
-> (Val a -> Val a -> Val a)
-> (Val a -> Val a -> Val a)
-> Ord (Val a)
Val a -> Val a -> Bool
Val a -> Val a -> Ordering
Val a -> Val a -> Val a
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
forall a. Ord a => Eq (Val a)
forall a. Ord a => Val a -> Val a -> Bool
forall a. Ord a => Val a -> Val a -> Ordering
forall a. Ord a => Val a -> Val a -> Val a
min :: Val a -> Val a -> Val a
$cmin :: forall a. Ord a => Val a -> Val a -> Val a
max :: Val a -> Val a -> Val a
$cmax :: forall a. Ord a => Val a -> Val a -> Val a
>= :: Val a -> Val a -> Bool
$c>= :: forall a. Ord a => Val a -> Val a -> Bool
> :: Val a -> Val a -> Bool
$c> :: forall a. Ord a => Val a -> Val a -> Bool
<= :: Val a -> Val a -> Bool
$c<= :: forall a. Ord a => Val a -> Val a -> Bool
< :: Val a -> Val a -> Bool
$c< :: forall a. Ord a => Val a -> Val a -> Bool
compare :: Val a -> Val a -> Ordering
$ccompare :: forall a. Ord a => Val a -> Val a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Val a)
Ord, ReadPrec [Val a]
ReadPrec (Val a)
Int -> ReadS (Val a)
ReadS [Val a]
(Int -> ReadS (Val a))
-> ReadS [Val a]
-> ReadPrec (Val a)
-> ReadPrec [Val a]
-> Read (Val a)
forall a. Read a => ReadPrec [Val a]
forall a. Read a => ReadPrec (Val a)
forall a. Read a => Int -> ReadS (Val a)
forall a. Read a => ReadS [Val a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Val a]
$creadListPrec :: forall a. Read a => ReadPrec [Val a]
readPrec :: ReadPrec (Val a)
$creadPrec :: forall a. Read a => ReadPrec (Val a)
readList :: ReadS [Val a]
$creadList :: forall a. Read a => ReadS [Val a]
readsPrec :: Int -> ReadS (Val a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Val a)
Read, a -> Val b -> Val a
(a -> b) -> Val a -> Val b
(forall a b. (a -> b) -> Val a -> Val b)
-> (forall a b. a -> Val b -> Val a) -> Functor Val
forall a b. a -> Val b -> Val a
forall a b. (a -> b) -> Val a -> Val b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Val b -> Val a
$c<$ :: forall a b. a -> Val b -> Val a
fmap :: (a -> b) -> Val a -> Val b
$cfmap :: forall a b. (a -> b) -> Val a -> Val b
Functor, Val a -> Bool
(a -> m) -> Val a -> m
(a -> b -> b) -> b -> Val a -> b
(forall m. Monoid m => Val m -> m)
-> (forall m a. Monoid m => (a -> m) -> Val a -> m)
-> (forall m a. Monoid m => (a -> m) -> Val a -> m)
-> (forall a b. (a -> b -> b) -> b -> Val a -> b)
-> (forall a b. (a -> b -> b) -> b -> Val a -> b)
-> (forall b a. (b -> a -> b) -> b -> Val a -> b)
-> (forall b a. (b -> a -> b) -> b -> Val a -> b)
-> (forall a. (a -> a -> a) -> Val a -> a)
-> (forall a. (a -> a -> a) -> Val a -> a)
-> (forall a. Val a -> [a])
-> (forall a. Val a -> Bool)
-> (forall a. Val a -> Int)
-> (forall a. Eq a => a -> Val a -> Bool)
-> (forall a. Ord a => Val a -> a)
-> (forall a. Ord a => Val a -> a)
-> (forall a. Num a => Val a -> a)
-> (forall a. Num a => Val a -> a)
-> Foldable Val
forall a. Eq a => a -> Val a -> Bool
forall a. Num a => Val a -> a
forall a. Ord a => Val a -> a
forall m. Monoid m => Val m -> m
forall a. Val a -> Bool
forall a. Val a -> Int
forall a. Val a -> [a]
forall a. (a -> a -> a) -> Val a -> a
forall m a. Monoid m => (a -> m) -> Val a -> m
forall b a. (b -> a -> b) -> b -> Val a -> b
forall a b. (a -> b -> b) -> b -> Val a -> b
forall (t :: Type -> Type).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Val a -> a
$cproduct :: forall a. Num a => Val a -> a
sum :: Val a -> a
$csum :: forall a. Num a => Val a -> a
minimum :: Val a -> a
$cminimum :: forall a. Ord a => Val a -> a
maximum :: Val a -> a
$cmaximum :: forall a. Ord a => Val a -> a
elem :: a -> Val a -> Bool
$celem :: forall a. Eq a => a -> Val a -> Bool
length :: Val a -> Int
$clength :: forall a. Val a -> Int
null :: Val a -> Bool
$cnull :: forall a. Val a -> Bool
toList :: Val a -> [a]
$ctoList :: forall a. Val a -> [a]
foldl1 :: (a -> a -> a) -> Val a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Val a -> a
foldr1 :: (a -> a -> a) -> Val a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Val a -> a
foldl' :: (b -> a -> b) -> b -> Val a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Val a -> b
foldl :: (b -> a -> b) -> b -> Val a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Val a -> b
foldr' :: (a -> b -> b) -> b -> Val a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Val a -> b
foldr :: (a -> b -> b) -> b -> Val a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Val a -> b
foldMap' :: (a -> m) -> Val a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Val a -> m
foldMap :: (a -> m) -> Val a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Val a -> m
fold :: Val m -> m
$cfold :: forall m. Monoid m => Val m -> m
Foldable, Functor Val
Foldable Val
Functor Val
-> Foldable Val
-> (forall (f :: Type -> Type) a b.
    Applicative f =>
    (a -> f b) -> Val a -> f (Val b))
-> (forall (f :: Type -> Type) a.
    Applicative f =>
    Val (f a) -> f (Val a))
-> (forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> Val a -> m (Val b))
-> (forall (m :: Type -> Type) a.
    Monad m =>
    Val (m a) -> m (Val a))
-> Traversable Val
(a -> f b) -> Val a -> f (Val b)
forall (t :: Type -> Type).
Functor t
-> Foldable t
-> (forall (f :: Type -> Type) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: Type -> Type) a.
    Applicative f =>
    t (f a) -> f (t a))
-> (forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: Type -> Type) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: Type -> Type) a. Monad m => Val (m a) -> m (Val a)
forall (f :: Type -> Type) a.
Applicative f =>
Val (f a) -> f (Val a)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Val a -> m (Val b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Val a -> f (Val b)
sequence :: Val (m a) -> m (Val a)
$csequence :: forall (m :: Type -> Type) a. Monad m => Val (m a) -> m (Val a)
mapM :: (a -> m b) -> Val a -> m (Val b)
$cmapM :: forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Val a -> m (Val b)
sequenceA :: Val (f a) -> f (Val a)
$csequenceA :: forall (f :: Type -> Type) a.
Applicative f =>
Val (f a) -> f (Val a)
traverse :: (a -> f b) -> Val a -> f (Val b)
$ctraverse :: forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Val a -> f (Val b)
$cp2Traversable :: Foldable Val
$cp1Traversable :: Functor Val
Traversable, (forall x. Val a -> Rep (Val a) x)
-> (forall x. Rep (Val a) x -> Val a) -> Generic (Val a)
forall x. Rep (Val a) x -> Val a
forall x. Val a -> Rep (Val a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Val a) x -> Val a
forall a x. Val a -> Rep (Val a) x
$cto :: forall a x. Rep (Val a) x -> Val a
$cfrom :: forall a x. Val a -> Rep (Val a) x
Generic, (forall a. Val a -> Rep1 Val a)
-> (forall a. Rep1 Val a -> Val a) -> Generic1 Val
forall a. Rep1 Val a -> Val a
forall a. Val a -> Rep1 Val a
forall k (f :: k -> Type).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall a. Rep1 Val a -> Val a
$cfrom1 :: forall a. Val a -> Rep1 Val a
Generic1)
  deriving Val a -> Q Exp
Val a -> Q (TExp (Val a))
(Val a -> Q Exp) -> (Val a -> Q (TExp (Val a))) -> Lift (Val a)
forall a. Lift a => Val a -> Q Exp
forall a. Lift a => Val a -> Q (TExp (Val a))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Val a -> Q (TExp (Val a))
$cliftTyped :: forall a. Lift a => Val a -> Q (TExp (Val a))
lift :: Val a -> Q Exp
$clift :: forall a. Lift a => Val a -> Q Exp
TH.Lift

makePrisms ''Val

instance Applicative Val where
  pure :: a -> Val a
pure = a -> Val a
forall a. a -> Val a
Val
  <*> :: Val (a -> b) -> Val a -> Val b
(<*>) = Val (a -> b) -> Val a -> Val b
forall (m :: Type -> Type) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Val where
  return :: a -> Val a
return = a -> Val a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
  Val a
a >>= :: Val a -> (a -> Val b) -> Val b
>>= a -> Val b
amb = a -> Val b
amb a
a
  Fail String
s >>= a -> Val b
_ = String -> Val b
forall a. String -> Val a
Fail String
s

-- | semigroup instance for 'Val'

--

-- >>> Val 123 <> (Val 456 <> Val 789) == (Val 123 <> Val 456) <> Val 789

-- True

--

-- >>> Val True <> Val False

-- Val False

--

-- >>> Val True <> Val True

-- Val True

--

-- >>> Fail "abc" <> (Val True <> Val False) <> Fail "def"

-- Fail "abc | def"

--

-- >>> (Fail "abc" <> Val True) <> (Val False <> Fail "def")

-- Fail "abc | def"

--

-- >>> Fail "" <> (Val True <> Val False) <> Fail "def"

-- Fail "def"

--

-- >>> Fail "abc" <> Fail "" <> Fail "def"

-- Fail "abc | def"

--

-- >>> Val False <> (Val True <> Val False) == (Val False <> Val True) <> Val False

-- True

--

instance Semigroup (Val a) where
   Fail String
s <> :: Val a -> Val a -> Val a
<> Fail String
s1 = String -> Val a
forall a. String -> Val a
Fail (String -> ShowS
jamSS String
s String
s1)
   Fail String
s <> Val a
_ = String -> Val a
forall a. String -> Val a
Fail String
s
   Val a
_ <> Fail String
s = String -> Val a
forall a. String -> Val a
Fail String
s
   Val a
_ <> Val a
b = a -> Val a
forall a. a -> Val a
Val a
b

-- | monoid instance for 'Val'

--

-- >>> mempty :: Val (Maybe [Int])

-- Val Nothing

--

-- >>> import qualified Data.Semigroup as SG

-- >>> mempty :: SG.Sum Int

-- Sum {getSum = 0}

--

instance Monoid a => Monoid (Val a) where
   mempty :: Val a
mempty = a -> Val a
forall a. a -> Val a
Val a
forall a. Monoid a => a
mempty

-- | 'Read' instance for Val

--

-- >>> reads @(Val Int) "Val 123"

-- [(Val 123,"")]

--

-- >>> reads @(Val Bool) "Val False abc"

-- [(Val False," abc")]

--

-- >>> reads @(Val Bool) "Fail \"some error message\""

-- [(Fail "some error message","")]

--

-- >>> reads @(Val Double) "Fail \"some error message\""

-- [(Fail "some error message","")]

--


-- | typed tree holding the results of evaluating a type level expression

data TT a = TT { TT a -> ValP
_ttValP :: !ValP -- ^ display value

               , TT a -> Val a
_ttVal :: !(Val a)  -- ^ the value at this root node

               , TT a -> String
_ttString :: !String  -- ^ detailed information eg input and output and text

               , TT a -> Forest PE
_ttForest :: !(Forest PE) -- ^ the child nodes

               } deriving stock (a -> TT b -> TT a
(a -> b) -> TT a -> TT b
(forall a b. (a -> b) -> TT a -> TT b)
-> (forall a b. a -> TT b -> TT a) -> Functor TT
forall a b. a -> TT b -> TT a
forall a b. (a -> b) -> TT a -> TT b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TT b -> TT a
$c<$ :: forall a b. a -> TT b -> TT a
fmap :: (a -> b) -> TT a -> TT b
$cfmap :: forall a b. (a -> b) -> TT a -> TT b
Functor, ReadPrec [TT a]
ReadPrec (TT a)
Int -> ReadS (TT a)
ReadS [TT a]
(Int -> ReadS (TT a))
-> ReadS [TT a]
-> ReadPrec (TT a)
-> ReadPrec [TT a]
-> Read (TT a)
forall a. Read a => ReadPrec [TT a]
forall a. Read a => ReadPrec (TT a)
forall a. Read a => Int -> ReadS (TT a)
forall a. Read a => ReadS [TT a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TT a]
$creadListPrec :: forall a. Read a => ReadPrec [TT a]
readPrec :: ReadPrec (TT a)
$creadPrec :: forall a. Read a => ReadPrec (TT a)
readList :: ReadS [TT a]
$creadList :: forall a. Read a => ReadS [TT a]
readsPrec :: Int -> ReadS (TT a)
$creadsPrec :: forall a. Read a => Int -> ReadS (TT a)
Read, Int -> TT a -> ShowS
[TT a] -> ShowS
TT a -> String
(Int -> TT a -> ShowS)
-> (TT a -> String) -> ([TT a] -> ShowS) -> Show (TT a)
forall a. Show a => Int -> TT a -> ShowS
forall a. Show a => [TT a] -> ShowS
forall a. Show a => TT a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TT a] -> ShowS
$cshowList :: forall a. Show a => [TT a] -> ShowS
show :: TT a -> String
$cshow :: forall a. Show a => TT a -> String
showsPrec :: Int -> TT a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> TT a -> ShowS
Show, TT a -> TT a -> Bool
(TT a -> TT a -> Bool) -> (TT a -> TT a -> Bool) -> Eq (TT a)
forall a. Eq a => TT a -> TT a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TT a -> TT a -> Bool
$c/= :: forall a. Eq a => TT a -> TT a -> Bool
== :: TT a -> TT a -> Bool
$c== :: forall a. Eq a => TT a -> TT a -> Bool
Eq, TT a -> Bool
(a -> m) -> TT a -> m
(a -> b -> b) -> b -> TT a -> b
(forall m. Monoid m => TT m -> m)
-> (forall m a. Monoid m => (a -> m) -> TT a -> m)
-> (forall m a. Monoid m => (a -> m) -> TT a -> m)
-> (forall a b. (a -> b -> b) -> b -> TT a -> b)
-> (forall a b. (a -> b -> b) -> b -> TT a -> b)
-> (forall b a. (b -> a -> b) -> b -> TT a -> b)
-> (forall b a. (b -> a -> b) -> b -> TT a -> b)
-> (forall a. (a -> a -> a) -> TT a -> a)
-> (forall a. (a -> a -> a) -> TT a -> a)
-> (forall a. TT a -> [a])
-> (forall a. TT a -> Bool)
-> (forall a. TT a -> Int)
-> (forall a. Eq a => a -> TT a -> Bool)
-> (forall a. Ord a => TT a -> a)
-> (forall a. Ord a => TT a -> a)
-> (forall a. Num a => TT a -> a)
-> (forall a. Num a => TT a -> a)
-> Foldable TT
forall a. Eq a => a -> TT a -> Bool
forall a. Num a => TT a -> a
forall a. Ord a => TT a -> a
forall m. Monoid m => TT m -> m
forall a. TT a -> Bool
forall a. TT a -> Int
forall a. TT a -> [a]
forall a. (a -> a -> a) -> TT a -> a
forall m a. Monoid m => (a -> m) -> TT a -> m
forall b a. (b -> a -> b) -> b -> TT a -> b
forall a b. (a -> b -> b) -> b -> TT a -> b
forall (t :: Type -> Type).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: TT a -> a
$cproduct :: forall a. Num a => TT a -> a
sum :: TT a -> a
$csum :: forall a. Num a => TT a -> a
minimum :: TT a -> a
$cminimum :: forall a. Ord a => TT a -> a
maximum :: TT a -> a
$cmaximum :: forall a. Ord a => TT a -> a
elem :: a -> TT a -> Bool
$celem :: forall a. Eq a => a -> TT a -> Bool
length :: TT a -> Int
$clength :: forall a. TT a -> Int
null :: TT a -> Bool
$cnull :: forall a. TT a -> Bool
toList :: TT a -> [a]
$ctoList :: forall a. TT a -> [a]
foldl1 :: (a -> a -> a) -> TT a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TT a -> a
foldr1 :: (a -> a -> a) -> TT a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> TT a -> a
foldl' :: (b -> a -> b) -> b -> TT a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TT a -> b
foldl :: (b -> a -> b) -> b -> TT a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TT a -> b
foldr' :: (a -> b -> b) -> b -> TT a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TT a -> b
foldr :: (a -> b -> b) -> b -> TT a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> TT a -> b
foldMap' :: (a -> m) -> TT a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TT a -> m
foldMap :: (a -> m) -> TT a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TT a -> m
fold :: TT m -> m
$cfold :: forall m. Monoid m => TT m -> m
Foldable, Functor TT
Foldable TT
Functor TT
-> Foldable TT
-> (forall (f :: Type -> Type) a b.
    Applicative f =>
    (a -> f b) -> TT a -> f (TT b))
-> (forall (f :: Type -> Type) a.
    Applicative f =>
    TT (f a) -> f (TT a))
-> (forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> TT a -> m (TT b))
-> (forall (m :: Type -> Type) a. Monad m => TT (m a) -> m (TT a))
-> Traversable TT
(a -> f b) -> TT a -> f (TT b)
forall (t :: Type -> Type).
Functor t
-> Foldable t
-> (forall (f :: Type -> Type) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: Type -> Type) a.
    Applicative f =>
    t (f a) -> f (t a))
-> (forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: Type -> Type) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: Type -> Type) a. Monad m => TT (m a) -> m (TT a)
forall (f :: Type -> Type) a. Applicative f => TT (f a) -> f (TT a)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> TT a -> m (TT b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> TT a -> f (TT b)
sequence :: TT (m a) -> m (TT a)
$csequence :: forall (m :: Type -> Type) a. Monad m => TT (m a) -> m (TT a)
mapM :: (a -> m b) -> TT a -> m (TT b)
$cmapM :: forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> TT a -> m (TT b)
sequenceA :: TT (f a) -> f (TT a)
$csequenceA :: forall (f :: Type -> Type) a. Applicative f => TT (f a) -> f (TT a)
traverse :: (a -> f b) -> TT a -> f (TT b)
$ctraverse :: forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> TT a -> f (TT b)
$cp2Traversable :: Foldable TT
$cp1Traversable :: Functor TT
Traversable, (forall x. TT a -> Rep (TT a) x)
-> (forall x. Rep (TT a) x -> TT a) -> Generic (TT a)
forall x. Rep (TT a) x -> TT a
forall x. TT a -> Rep (TT a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (TT a) x -> TT a
forall a x. TT a -> Rep (TT a) x
$cto :: forall a x. Rep (TT a) x -> TT a
$cfrom :: forall a x. TT a -> Rep (TT a) x
Generic, (forall a. TT a -> Rep1 TT a)
-> (forall a. Rep1 TT a -> TT a) -> Generic1 TT
forall a. Rep1 TT a -> TT a
forall a. TT a -> Rep1 TT a
forall k (f :: k -> Type).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall a. Rep1 TT a -> TT a
$cfrom1 :: forall a. TT a -> Rep1 TT a
Generic1)
                 deriving stock TT a -> Q Exp
TT a -> Q (TExp (TT a))
(TT a -> Q Exp) -> (TT a -> Q (TExp (TT a))) -> Lift (TT a)
forall a. Lift a => TT a -> Q Exp
forall a. Lift a => TT a -> Q (TExp (TT a))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TT a -> Q (TExp (TT a))
$cliftTyped :: forall a. Lift a => TT a -> Q (TExp (TT a))
lift :: TT a -> Q Exp
$clift :: forall a. Lift a => TT a -> Q Exp
TH.Lift

-- dont expose lenses for _ttValP and _ttVal as they must be kept in sync: see ttVal

makeLensesFor [("_ttString","ttString"),("_ttForest","ttForest")] ''TT

instance Semigroup (TT a) where
   TT ValP
bp Val a
bt String
ss Forest PE
ts <> :: TT a -> TT a -> TT a
<> TT ValP
bp1 Val a
bt1 String
ss1 Forest PE
ts1 =
     ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT (ValP
bp ValP -> ValP -> ValP
forall a. Semigroup a => a -> a -> a
<> ValP
bp1) (Val a
bt Val a -> Val a -> Val a
forall a. Semigroup a => a -> a -> a
<> Val a
bt1) (String -> ShowS
jamSS String
ss String
ss1) (Forest PE
ts Forest PE -> Forest PE -> Forest PE
forall a. Semigroup a => a -> a -> a
<> Forest PE
ts1)

instance Monoid a => Monoid (TT a) where
   mempty :: TT a
mempty = ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT ValP
forall a. Monoid a => a
mempty Val a
forall a. Monoid a => a
mempty String
forall a. Monoid a => a
mempty Forest PE
forall a. Monoid a => a
mempty

instance Applicative TT where
  pure :: a -> TT a
pure a
a = ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT ValP
ValP (a -> Val a
forall a. a -> Val a
Val a
a) String
"" []
  <*> :: TT (a -> b) -> TT a -> TT b
(<*>) = TT (a -> b) -> TT a -> TT b
forall (m :: Type -> Type) a b. Monad m => m (a -> b) -> m a -> m b
ap

fixTTValP :: ValP -> TT a -> TT a
fixTTValP :: ValP -> TT a -> TT a
fixTTValP ValP
bp TT a
tt = TT a
tt { _ttValP :: ValP
_ttValP = ValP
bp ValP -> ValP -> ValP
forall a. Semigroup a => a -> a -> a
<> TT a -> ValP
forall a. TT a -> ValP
_ttValP TT a
tt }

instance Monad TT where
  return :: a -> TT a
return = a -> TT a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
  z :: TT a
z@(TT ValP
bp Val a
bt String
ss Forest PE
ts) >>= :: TT a -> (a -> TT b) -> TT b
>>= a -> TT b
amb =
     case Val a
bt of
       Val a
a -> ValP -> TT b -> TT b
forall a. ValP -> TT a -> TT a
fixTTValP ValP
bp (TT b -> TT b) -> TT b -> TT b
forall a b. (a -> b) -> a -> b
$ a -> TT b
amb a
a
                  TT b -> (TT b -> TT b) -> TT b
forall a b. a -> (a -> b) -> b
& (String -> Identity String) -> TT b -> Identity (TT b)
forall a. Lens' (TT a) String
ttString ((String -> Identity String) -> TT b -> Identity (TT b))
-> ShowS -> TT b -> TT b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ String -> ShowS
jamSS String
ss
                  TT b -> (TT b -> TT b) -> TT b
forall a b. a -> (a -> b) -> b
& (Forest PE -> Identity (Forest PE)) -> TT b -> Identity (TT b)
forall a. Lens' (TT a) (Forest PE)
ttForest ((Forest PE -> Identity (Forest PE)) -> TT b -> Identity (TT b))
-> (Forest PE -> Forest PE) -> TT b -> TT b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Forest PE
ts Forest PE -> Forest PE -> Forest PE
forall a. Semigroup a => a -> a -> a
<>)
       Fail String
e -> TT a
z { _ttVal :: Val b
_ttVal = String -> Val b
forall a. String -> Val a
Fail String
e }

-- | creates a Node for the evaluation tree

mkNodeCopy :: POpts
       -> TT a
       -> String
       -> [Tree PE]
       -> TT a
mkNodeCopy :: POpts -> TT a -> String -> Forest PE -> TT a
mkNodeCopy POpts
opts = POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
forall a. POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
mkNodeImpl POpts
opts ((ValP, Val a) -> String -> Forest PE -> TT a)
-> (TT a -> (ValP, Val a)) -> TT a -> String -> Forest PE -> TT a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TT a -> ValP
forall a. TT a -> ValP
_ttValP (TT a -> ValP) -> (TT a -> Val a) -> TT a -> (ValP, Val a)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TT a -> Val a
forall a. TT a -> Val a
_ttVal)

-- | creates a Node for the evaluation tree

mkNode :: POpts
       -> Val a
       -> String
       -> [Tree PE]
       -> TT a
mkNode :: POpts -> Val a -> String -> Forest PE -> TT a
mkNode POpts
opts = POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
forall a. POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
mkNodeImpl POpts
opts ((ValP, Val a) -> String -> Forest PE -> TT a)
-> (Val a -> (ValP, Val a)) -> Val a -> String -> Forest PE -> TT a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val a -> ValP
forall a. Val a -> ValP
val2P (Val a -> ValP) -> (Val a -> Val a) -> Val a -> (ValP, Val a)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Val a -> Val a
forall a. a -> a
id)

-- | creates a Node for the evaluation tree

mkNodeImpl :: POpts
           -> (ValP, Val a)
           -> String
           -> [Tree PE]
           -> TT a
mkNodeImpl :: POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
mkNodeImpl POpts
opts (ValP
bp',Val a
bt) String
ss Forest PE
hs =
  let bp :: ValP
bp = ValP -> Val a -> ValP
forall a. ValP -> Val a -> ValP
validateValP ValP
bp' Val a
bt
  in case POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts of
      HKD Identity Debug
DZero -> ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT ValP
bp Val a
bt String
"" []
      HKD Identity Debug
DLite ->
      -- keeps the last string so we can use the root to give more details on failure (especially for Refined* types)

      -- also holds onto any failures

          let zs :: Forest PE
zs = (Tree PE -> Bool) -> Forest PE -> Forest PE
forall a. (a -> Bool) -> [a] -> [a]
filter (Getting Any (Tree PE) String -> Tree PE -> Bool
forall s a. Getting Any s a -> s -> Bool
has ((PE -> Const Any PE) -> Tree PE -> Const Any (Tree PE)
forall a. Lens' (Tree a) a
root ((PE -> Const Any PE) -> Tree PE -> Const Any (Tree PE))
-> ((String -> Const Any String) -> PE -> Const Any PE)
-> Getting Any (Tree PE) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValP -> Const Any ValP) -> PE -> Const Any PE
Lens' PE ValP
peValP ((ValP -> Const Any ValP) -> PE -> Const Any PE)
-> ((String -> Const Any String) -> ValP -> Const Any ValP)
-> (String -> Const Any String)
-> PE
-> Const Any PE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const Any String) -> ValP -> Const Any ValP
Prism' ValP String
_FailP)) Forest PE
hs
          in ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT ValP
bp Val a
bt String
ss Forest PE
zs
      HKD Identity Debug
_ -> ValP -> Val a -> String -> Forest PE -> TT a
forall a. ValP -> Val a -> String -> Forest PE -> TT a
TT ValP
bp Val a
bt String
ss Forest PE
hs

-- | check that the 'ValP' value is consistent with 'Val'

validateValP :: ValP -> Val a -> ValP
validateValP :: ValP -> Val a -> ValP
validateValP ValP
bp Val a
bt =
  case Val a
bt of
    Val a
_a -> case ValP
bp of
                     FailP String
e -> String -> ValP
forall x. HasCallStack => String -> x
errorInProgram (String -> ValP) -> String -> ValP
forall a b. (a -> b) -> a -> b
$ String
"validateValP: found Val and FailP e=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
                     ValP
_ -> ValP
bp
    Fail String
e -> case ValP
bp of
                FailP String
e1 | String
eString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
e1 -> ValP
bp
                         | Bool
otherwise -> String -> ValP
forall x. HasCallStack => String -> x
errorInProgram (String -> ValP) -> String -> ValP
forall a b. (a -> b) -> a -> b
$ String
"validateValP: found Fail and FailP but message mismatch in FailP " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String
e,String
e1)
                ValP
_ -> String -> ValP
forall x. HasCallStack => String -> x
errorInProgram (String -> ValP) -> String -> ValP
forall a b. (a -> b) -> a -> b
$ String
"validateValP: found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValP -> String
forall a. Show a => a -> String
show ValP
bp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" expected FailP e=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e

-- | fix the 'ValP' value for the Bool case: ie use 'TrueP' and 'FalseP'

--

-- >>> fixTTBool (TT ValP (Val True) "x" []) == TT TrueP (Val True) "x" []

-- True

--

-- >>> fixTTBool (TT FalseP (Fail "abc") "x" []) == TT (FailP "abc") (Fail "abc") "x" []

-- True

--

fixTTBool :: TT Bool -> TT Bool
fixTTBool :: TT Bool -> TT Bool
fixTTBool = ASetter (TT Bool) (TT Bool) (Val Bool) (Val Bool)
-> (Val Bool -> Val Bool) -> TT Bool -> TT Bool
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (TT Bool) (TT Bool) (Val Bool) (Val Bool)
forall a. (a ~ Bool) => Lens' (TT a) (Val Bool)
ttValBool Val Bool -> Val Bool
forall a. a -> a
id

-- | creates a Boolean node for a predicate type

mkNodeB :: POpts
        -> Bool
        -> String
        -> [Tree PE]
        -> TT Bool
mkNodeB :: POpts -> Bool -> String -> Forest PE -> TT Bool
mkNodeB POpts
opts = POpts -> (ValP, Val Bool) -> String -> Forest PE -> TT Bool
forall a. POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
mkNodeImpl POpts
opts ((ValP, Val Bool) -> String -> Forest PE -> TT Bool)
-> (Bool -> (ValP, Val Bool))
-> Bool
-> String
-> Forest PE
-> TT Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValP -> ValP -> Bool -> ValP
forall a. a -> a -> Bool -> a
bool ValP
FalseP ValP
TrueP (Bool -> ValP) -> (Bool -> Val Bool) -> Bool -> (ValP, Val Bool)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Bool -> Val Bool
forall a. a -> Val a
Val)

-- | convenience method to pull parts out of 'TT'

getValAndPE :: TT a -> (Either String a, Tree PE)
getValAndPE :: TT a -> (Either String a, Tree PE)
getValAndPE = TT a -> Either String a
forall a. TT a -> Either String a
getValLRFromTT (TT a -> Either String a)
-> (TT a -> Tree PE) -> TT a -> (Either String a, Tree PE)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TT a -> Tree PE
forall a. TT a -> Tree PE
hh

-- | convenience method to pull out the return value from 'TT'

getValLRFromTT :: TT a -> Either String a
getValLRFromTT :: TT a -> Either String a
getValLRFromTT = Getting (Either String a) (TT a) (Either String a)
-> TT a -> Either String a
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view ((Val a -> Const (Either String a) (Val a))
-> TT a -> Const (Either String a) (TT a)
forall a b. Lens (TT a) (TT b) (Val a) (Val b)
ttVal ((Val a -> Const (Either String a) (Val a))
 -> TT a -> Const (Either String a) (TT a))
-> ((Either String a -> Const (Either String a) (Either String a))
    -> Val a -> Const (Either String a) (Val a))
-> Getting (Either String a) (TT a) (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either String a -> Const (Either String a) (Either String a))
-> Val a -> Const (Either String a) (Val a)
forall a b. Iso (Val a) (Val b) (Either String a) (Either String b)
_ValEither)

-- | converts a typed tree to an untyped tree for display

hh :: TT a -> Tree PE
hh :: TT a -> Tree PE
hh (TT ValP
bp Val a
bt String
ss Forest PE
tt) = PE -> Forest PE -> Tree PE
forall a. a -> Forest a -> Tree a
Node (ValP -> String -> PE
PE (ValP -> Val a -> ValP
forall a. ValP -> Val a -> ValP
validateValP ValP
bp Val a
bt) String
ss) Forest PE
tt

data Inline = Inline | NoInline deriving (Int -> Inline -> ShowS
[Inline] -> ShowS
Inline -> String
(Int -> Inline -> ShowS)
-> (Inline -> String) -> ([Inline] -> ShowS) -> Show Inline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inline] -> ShowS
$cshowList :: [Inline] -> ShowS
show :: Inline -> String
$cshow :: Inline -> String
showsPrec :: Int -> Inline -> ShowS
$cshowsPrec :: Int -> Inline -> ShowS
Show, Inline -> Inline -> Bool
(Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool) -> Eq Inline
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inline -> Inline -> Bool
$c/= :: Inline -> Inline -> Bool
== :: Inline -> Inline -> Bool
$c== :: Inline -> Inline -> Bool
Eq)

-- | decorate the tree with more detail when there are errors but inline the error node

getValueLR :: Inline
           -> POpts
           -> String
           -> TT a
           -> [Tree PE]
           -> Either (TT x) a
getValueLR :: Inline -> POpts -> String -> TT a -> Forest PE -> Either (TT x) a
getValueLR Inline
inline POpts
opts String
msg0 TT a
tt Forest PE
hs =
-- hack: if infix ...

  let ts :: String
ts = if TT a -> String
forall a. TT a -> String
_ttString TT a
tt String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg0 then String
"" else TT a -> String
forall a. TT a -> String
_ttString TT a
tt
      xs :: String
xs = String
ts String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
ts Bool -> Bool -> Bool
|| String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
msg0 then String
"" else String
" | ") String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg0
      tts :: Forest PE
tts = case Inline
inline of
              Inline
Inline -> Forest PE
hs Forest PE -> Forest PE -> Forest PE
forall a. Semigroup a => a -> a -> a
<> TT a -> Forest PE
forall a. TT a -> Forest PE
_ttForest TT a
tt
              Inline
NoInline -> Forest PE
hs Forest PE -> Forest PE -> Forest PE
forall a. Semigroup a => a -> a -> a
<> [TT a -> Tree PE
forall a. TT a -> Tree PE
hh TT a
tt]
  in (String -> TT x) -> Either String a -> Either (TT x) a
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (\String
e -> POpts -> Val x -> String -> Forest PE -> TT x
forall a. POpts -> Val a -> String -> Forest PE -> TT a
mkNode POpts
opts (String -> Val x
forall a. String -> Val a
Fail String
e) String
xs Forest PE
tts) (TT a -> Either String a
forall a. TT a -> Either String a
getValLRFromTT TT a
tt)


-- | elide the 'Identity' wrapper so it acts like a normal ADT

type family HKD f a where
  HKD Identity a = a
  HKD f a = f a

-- | final set of options using Identity

type POpts = HOpts Identity

-- | customizable options for running a typelevel expression

data HOpts f =
  HOpts { HOpts f -> HKD f Int
oWidth :: !(HKD f Int) -- ^ length of data to display for 'showLitImpl'

        , HOpts f -> HKD f Debug
oDebug :: !(HKD f Debug) -- ^ debug level

        , HOpts f -> HKD f Disp
oDisp :: !(HKD f Disp) -- ^ display the tree using the normal tree or unicode

        , HOpts f -> HKD f (String, PColor)
oColor :: !(HKD f (String, PColor)) -- ^ color palette used

        , HOpts f -> [String]
oMsg :: ![String] -- ^ messages associated with type

        , HOpts f -> HKD f Int
oRecursion :: !(HKD f Int) -- ^ max recursion

        , HOpts f -> HKD f (Bool, SColor, SColor)
oOther :: !(HKD f (Bool, SColor, SColor)) -- ^ other message effects

        , HOpts f -> HKD f Bool
oNoColor :: !(HKD f Bool) -- ^ no colors

        }

-- | the color palette for displaying the expression tree

newtype PColor = PColor (ValP -> String -> String)
instance Show PColor where
  show :: PColor -> String
show PColor {} = String
"PColor <fn>"

deriving stock instance
  ( Show (HKD f Int)
  , Show (HKD f Debug)
  , Show (HKD f Disp)
  , Show (HKD f (String, PColor))
  , Show (HKD f Bool)
  , Show (HKD f (Bool, SColor, SColor))
  ) => Show (HOpts f)

-- | combine options ala monoid

reifyOpts :: HOpts Last -> HOpts Identity
reifyOpts :: HOpts Last -> POpts
reifyOpts HOpts Last
h =
  HKD Identity Int
-> HKD Identity Debug
-> HKD Identity Disp
-> HKD Identity (String, PColor)
-> [String]
-> HKD Identity Int
-> HKD Identity (Bool, SColor, SColor)
-> HKD Identity Bool
-> POpts
forall (f :: Type -> Type).
HKD f Int
-> HKD f Debug
-> HKD f Disp
-> HKD f (String, PColor)
-> [String]
-> HKD f Int
-> HKD f (Bool, SColor, SColor)
-> HKD f Bool
-> HOpts f
HOpts (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oWidth POpts
defOpts) (Last Int -> Maybe Int
coerce (HOpts Last -> HKD Last Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oWidth HOpts Last
h)))
        (Debug -> Maybe Debug -> Debug
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
defOpts) (Last Debug -> Maybe Debug
coerce (HOpts Last -> HKD Last Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug HOpts Last
h)))
        (Disp -> Maybe Disp -> Disp
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Disp
forall (f :: Type -> Type). HOpts f -> HKD f Disp
oDisp POpts
defOpts) (Last Disp -> Maybe Disp
coerce (HOpts Last -> HKD Last Disp
forall (f :: Type -> Type). HOpts f -> HKD f Disp
oDisp HOpts Last
h)))
        (if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor POpts
defOpts) (Last Bool -> Maybe Bool
coerce (HOpts Last -> HKD Last Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor HOpts Last
h))
           then (String, PColor)
HKD Identity (String, PColor)
nocolor
           else (String, PColor) -> Maybe (String, PColor) -> (String, PColor)
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity (String, PColor)
forall (f :: Type -> Type). HOpts f -> HKD f (String, PColor)
oColor POpts
defOpts) (Last (String, PColor) -> Maybe (String, PColor)
coerce (HOpts Last -> HKD Last (String, PColor)
forall (f :: Type -> Type). HOpts f -> HKD f (String, PColor)
oColor HOpts Last
h))
        )
        (POpts -> [String]
forall (f :: Type -> Type). HOpts f -> [String]
oMsg POpts
defOpts [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> HOpts Last -> [String]
forall (f :: Type -> Type). HOpts f -> [String]
oMsg HOpts Last
h)
        (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursion POpts
defOpts) (Last Int -> Maybe Int
coerce (HOpts Last -> HKD Last Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursion HOpts Last
h)))
        (if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor POpts
defOpts) (Last Bool -> Maybe Bool
coerce (HOpts Last -> HKD Last Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor HOpts Last
h))
           then (Bool, SColor, SColor)
HKD Identity (Bool, SColor, SColor)
otherDef
           else (Bool, SColor, SColor)
-> Maybe (Bool, SColor, SColor) -> (Bool, SColor, SColor)
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity (Bool, SColor, SColor)
forall (f :: Type -> Type). HOpts f -> HKD f (Bool, SColor, SColor)
oOther POpts
defOpts) (Last (Bool, SColor, SColor) -> Maybe (Bool, SColor, SColor)
coerce (HOpts Last -> HKD Last (Bool, SColor, SColor)
forall (f :: Type -> Type). HOpts f -> HKD f (Bool, SColor, SColor)
oOther HOpts Last
h))
        )
        (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor POpts
defOpts) (Last Bool -> Maybe Bool
coerce (HOpts Last -> HKD Last Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor HOpts Last
h)))

-- | set maximum display width of expressions

setWidth :: Int -> HOpts Last
setWidth :: Int -> HOpts Last
setWidth Int
i = HOpts Last
forall a. Monoid a => a
mempty { oWidth :: HKD Last Int
oWidth = Int -> Last Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
i }

-- | set title message for the display tree

setMessage :: String -> HOpts Last
setMessage :: String -> HOpts Last
setMessage String
s = HOpts Last
forall a. Monoid a => a
mempty { oMsg :: [String]
oMsg = String -> [String]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
s }

-- | set maximum recursion eg when running regex

setRecursion :: Int -> HOpts Last
setRecursion :: Int -> HOpts Last
setRecursion Int
i = HOpts Last
forall a. Monoid a => a
mempty { oRecursion :: HKD Last Int
oRecursion = Int -> Last Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
i }

-- | set color of title message

setOther :: Bool
         -> Color
         -> Color
         -> HOpts Last
setOther :: Bool -> Color -> Color -> HOpts Last
setOther Bool
b Color
c1 Color
c2 = HOpts Last
forall a. Monoid a => a
mempty { oOther :: HKD Last (Bool, SColor, SColor)
oOther = (Bool, SColor, SColor) -> Last (Bool, SColor, SColor)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Bool, SColor, SColor) -> Last (Bool, SColor, SColor))
-> (Bool, SColor, SColor) -> Last (Bool, SColor, SColor)
forall a b. (a -> b) -> a -> b
$ (Bool, Color, Color) -> (Bool, SColor, SColor)
coerce (Bool
b, Color
c1, Color
c2) }

-- | turn on/off colors

setNoColor :: Bool -> HOpts Last
setNoColor :: Bool -> HOpts Last
setNoColor Bool
b = HOpts Last
forall a. Monoid a => a
mempty { oNoColor :: HKD Last Bool
oNoColor = Bool -> Last Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
b }

-- | display type eg 'Unicode' or 'Ansi'

setDisp :: Disp -> HOpts Last
setDisp :: Disp -> HOpts Last
setDisp Disp
d = HOpts Last
forall a. Monoid a => a
mempty { oDisp :: HKD Last Disp
oDisp = Disp -> Last Disp
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Disp
d }

-- | create color palette for the expression tree

setCreateColor :: String
   -> Color
   -> Color
   -> Color
   -> Color
   -> Color
   -> Color
   -> Color
   -> Color
   -> HOpts Last
setCreateColor :: String
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> HOpts Last
setCreateColor String
s Color
c1 Color
c2 Color
c3 Color
c4 Color
c5 Color
c6 Color
c7 Color
c8 =
  let pc :: ValP -> ShowS
pc = \case
       FailP {} -> Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.color Color
c1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.bgColor Color
c2
       ValP
FalseP -> Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.color Color
c3 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.bgColor Color
c4
       ValP
TrueP -> Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.color Color
c5 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.bgColor Color
c6
       ValP
ValP -> Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.color Color
c7 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.bgColor Color
c8
  in HOpts Last
forall a. Monoid a => a
mempty { oColor :: HKD Last (String, PColor)
oColor = (String, PColor) -> Last (String, PColor)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String
s,(ValP -> ShowS) -> PColor
PColor ValP -> ShowS
pc) }

-- | set debug mode

setDebug :: Debug -> HOpts Last
setDebug :: Debug -> HOpts Last
setDebug Debug
d =
  HOpts Last
forall a. Monoid a => a
mempty { oDebug :: HKD Last Debug
oDebug = Debug -> Last Debug
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Debug
d }

-- | monoid opts

instance Monoid (HOpts Last) where
  mempty :: HOpts Last
mempty = HKD Last Int
-> HKD Last Debug
-> HKD Last Disp
-> HKD Last (String, PColor)
-> [String]
-> HKD Last Int
-> HKD Last (Bool, SColor, SColor)
-> HKD Last Bool
-> HOpts Last
forall (f :: Type -> Type).
HKD f Int
-> HKD f Debug
-> HKD f Disp
-> HKD f (String, PColor)
-> [String]
-> HKD f Int
-> HKD f (Bool, SColor, SColor)
-> HKD f Bool
-> HOpts f
HOpts HKD Last Int
forall a. Monoid a => a
mempty HKD Last Debug
forall a. Monoid a => a
mempty HKD Last Disp
forall a. Monoid a => a
mempty HKD Last (String, PColor)
forall a. Monoid a => a
mempty [String]
forall a. Monoid a => a
mempty HKD Last Int
forall a. Monoid a => a
mempty HKD Last (Bool, SColor, SColor)
forall a. Monoid a => a
mempty HKD Last Bool
forall a. Monoid a => a
mempty

instance Semigroup (HOpts Last) where
  HOpts HKD Last Int
a HKD Last Debug
b HKD Last Disp
c HKD Last (String, PColor)
d [String]
e HKD Last Int
f HKD Last (Bool, SColor, SColor)
g HKD Last Bool
h <> :: HOpts Last -> HOpts Last -> HOpts Last
<> HOpts HKD Last Int
a' HKD Last Debug
b' HKD Last Disp
c' HKD Last (String, PColor)
d' [String]
e' HKD Last Int
f' HKD Last (Bool, SColor, SColor)
g' HKD Last Bool
h'
     = HKD Last Int
-> HKD Last Debug
-> HKD Last Disp
-> HKD Last (String, PColor)
-> [String]
-> HKD Last Int
-> HKD Last (Bool, SColor, SColor)
-> HKD Last Bool
-> HOpts Last
forall (f :: Type -> Type).
HKD f Int
-> HKD f Debug
-> HKD f Disp
-> HKD f (String, PColor)
-> [String]
-> HKD f Int
-> HKD f (Bool, SColor, SColor)
-> HKD f Bool
-> HOpts f
HOpts (Last Int
HKD Last Int
a Last Int -> Last Int -> Last Int
forall a. Semigroup a => a -> a -> a
<> Last Int
HKD Last Int
a')
             (Last Debug
HKD Last Debug
b Last Debug -> Last Debug -> Last Debug
forall a. Semigroup a => a -> a -> a
<> Last Debug
HKD Last Debug
b')
             (Last Disp
HKD Last Disp
c Last Disp -> Last Disp -> Last Disp
forall a. Semigroup a => a -> a -> a
<> Last Disp
HKD Last Disp
c')
             (Last (String, PColor)
HKD Last (String, PColor)
d Last (String, PColor)
-> Last (String, PColor) -> Last (String, PColor)
forall a. Semigroup a => a -> a -> a
<> Last (String, PColor)
HKD Last (String, PColor)
d')
             ([String]
e [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
e')
             (Last Int
HKD Last Int
f Last Int -> Last Int -> Last Int
forall a. Semigroup a => a -> a -> a
<> Last Int
HKD Last Int
f')
             (Last (Bool, SColor, SColor)
HKD Last (Bool, SColor, SColor)
g Last (Bool, SColor, SColor)
-> Last (Bool, SColor, SColor) -> Last (Bool, SColor, SColor)
forall a. Semigroup a => a -> a -> a
<> Last (Bool, SColor, SColor)
HKD Last (Bool, SColor, SColor)
g')
             (Last Bool
HKD Last Bool
h Last Bool -> Last Bool -> Last Bool
forall a. Semigroup a => a -> a -> a
<> Last Bool
HKD Last Bool
h')

--seqPOptsM :: HOpts Last -> Maybe (HOpts Identity)

--seqPOptsM h = coerce (HOpts <$> oWidth h <*> oDebug h <*> oDisp h <*> oColor h)


-- | display format for the tree

data Disp = Ansi -- ^ draw normal tree

          | Unicode  -- ^ use unicode

          deriving stock (Int -> Disp -> ShowS
[Disp] -> ShowS
Disp -> String
(Int -> Disp -> ShowS)
-> (Disp -> String) -> ([Disp] -> ShowS) -> Show Disp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Disp] -> ShowS
$cshowList :: [Disp] -> ShowS
show :: Disp -> String
$cshow :: Disp -> String
showsPrec :: Int -> Disp -> ShowS
$cshowsPrec :: Int -> Disp -> ShowS
Show, Disp -> Disp -> Bool
(Disp -> Disp -> Bool) -> (Disp -> Disp -> Bool) -> Eq Disp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Disp -> Disp -> Bool
$c/= :: Disp -> Disp -> Bool
== :: Disp -> Disp -> Bool
$c== :: Disp -> Disp -> Bool
Eq, ReadPrec [Disp]
ReadPrec Disp
Int -> ReadS Disp
ReadS [Disp]
(Int -> ReadS Disp)
-> ReadS [Disp] -> ReadPrec Disp -> ReadPrec [Disp] -> Read Disp
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Disp]
$creadListPrec :: ReadPrec [Disp]
readPrec :: ReadPrec Disp
$creadPrec :: ReadPrec Disp
readList :: ReadS [Disp]
$creadList :: ReadS [Disp]
readsPrec :: Int -> ReadS Disp
$creadsPrec :: Int -> ReadS Disp
Read, Disp
Disp -> Disp -> Bounded Disp
forall a. a -> a -> Bounded a
maxBound :: Disp
$cmaxBound :: Disp
minBound :: Disp
$cminBound :: Disp
Bounded, Int -> Disp
Disp -> Int
Disp -> [Disp]
Disp -> Disp
Disp -> Disp -> [Disp]
Disp -> Disp -> Disp -> [Disp]
(Disp -> Disp)
-> (Disp -> Disp)
-> (Int -> Disp)
-> (Disp -> Int)
-> (Disp -> [Disp])
-> (Disp -> Disp -> [Disp])
-> (Disp -> Disp -> [Disp])
-> (Disp -> Disp -> Disp -> [Disp])
-> Enum Disp
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Disp -> Disp -> Disp -> [Disp]
$cenumFromThenTo :: Disp -> Disp -> Disp -> [Disp]
enumFromTo :: Disp -> Disp -> [Disp]
$cenumFromTo :: Disp -> Disp -> [Disp]
enumFromThen :: Disp -> Disp -> [Disp]
$cenumFromThen :: Disp -> Disp -> [Disp]
enumFrom :: Disp -> [Disp]
$cenumFrom :: Disp -> [Disp]
fromEnum :: Disp -> Int
$cfromEnum :: Disp -> Int
toEnum :: Int -> Disp
$ctoEnum :: Int -> Disp
pred :: Disp -> Disp
$cpred :: Disp -> Disp
succ :: Disp -> Disp
$csucc :: Disp -> Disp
Enum)

-- | default options

defOpts :: POpts
defOpts :: POpts
defOpts = HOpts :: forall (f :: Type -> Type).
HKD f Int
-> HKD f Debug
-> HKD f Disp
-> HKD f (String, PColor)
-> [String]
-> HKD f Int
-> HKD f (Bool, SColor, SColor)
-> HKD f Bool
-> HOpts f
HOpts
    { oWidth :: HKD Identity Int
oWidth = HKD Identity Int
100
    , oDebug :: HKD Identity Debug
oDebug = Debug
HKD Identity Debug
DNormal
    , oDisp :: HKD Identity Disp
oDisp = Disp
HKD Identity Disp
Ansi
    , oColor :: HKD Identity (String, PColor)
oColor = (String, PColor)
HKD Identity (String, PColor)
colorDef
    , oMsg :: [String]
oMsg = [String]
forall a. Monoid a => a
mempty
    , oRecursion :: HKD Identity Int
oRecursion = HKD Identity Int
100
    , oOther :: HKD Identity (Bool, SColor, SColor)
oOther = (Bool, SColor, SColor)
HKD Identity (Bool, SColor, SColor)
otherDef
    , oNoColor :: HKD Identity Bool
oNoColor = Bool
HKD Identity Bool
False
    }

-- | default title message color and boundaries between multipart refine messages

otherDef :: (Bool, SColor, SColor)
otherDef :: (Bool, SColor, SColor)
otherDef = (Bool, Color, Color) -> (Bool, SColor, SColor)
coerce (Bool
True, Color
Default, Color
Default)

nocolor, colorDef :: (String, PColor)
nocolor :: (String, PColor)
nocolor = (String
"nocolor", (ValP -> ShowS) -> PColor
PColor ((ValP -> ShowS) -> PColor) -> (ValP -> ShowS) -> PColor
forall a b. (a -> b) -> a -> b
$ (String -> ValP -> String) -> ValP -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ValP -> String
forall a b. a -> b -> a
const)
colorDef :: (String, PColor)
colorDef = String -> Maybe (String, PColor) -> (String, PColor)
forall a. HasCallStack => String -> Maybe a -> a
Safe.fromJustNote String
"colorDef" (Maybe (String, PColor) -> (String, PColor))
-> Maybe (String, PColor) -> (String, PColor)
forall a b. (a -> b) -> a -> b
$ Last (String, PColor) -> Maybe (String, PColor)
coerce (Last (String, PColor) -> Maybe (String, PColor))
-> Last (String, PColor) -> Maybe (String, PColor)
forall a b. (a -> b) -> a -> b
$ HOpts Last -> HKD Last (String, PColor)
forall (f :: Type -> Type). HOpts f -> HKD f (String, PColor)
oColor (HOpts Last -> HKD Last (String, PColor))
-> HOpts Last -> HKD Last (String, PColor)
forall a b. (a -> b) -> a -> b
$ OptC Color5 => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @Color5

-- | how much detail to show in the expression tree

data Debug =
       DZero -- ^ one line summary used mainly for testing

     | DLite -- ^ one line summary with additional context from the top of the evaluation tree

     | DNormal  -- ^ outputs the evaluation tree but skips noisy subtrees

     | DVerbose -- ^ outputs the entire evaluation tree

     deriving stock (ReadPrec [Debug]
ReadPrec Debug
Int -> ReadS Debug
ReadS [Debug]
(Int -> ReadS Debug)
-> ReadS [Debug]
-> ReadPrec Debug
-> ReadPrec [Debug]
-> Read Debug
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Debug]
$creadListPrec :: ReadPrec [Debug]
readPrec :: ReadPrec Debug
$creadPrec :: ReadPrec Debug
readList :: ReadS [Debug]
$creadList :: ReadS [Debug]
readsPrec :: Int -> ReadS Debug
$creadsPrec :: Int -> ReadS Debug
Read, Eq Debug
Eq Debug
-> (Debug -> Debug -> Ordering)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Debug)
-> (Debug -> Debug -> Debug)
-> Ord Debug
Debug -> Debug -> Bool
Debug -> Debug -> Ordering
Debug -> Debug -> Debug
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
min :: Debug -> Debug -> Debug
$cmin :: Debug -> Debug -> Debug
max :: Debug -> Debug -> Debug
$cmax :: Debug -> Debug -> Debug
>= :: Debug -> Debug -> Bool
$c>= :: Debug -> Debug -> Bool
> :: Debug -> Debug -> Bool
$c> :: Debug -> Debug -> Bool
<= :: Debug -> Debug -> Bool
$c<= :: Debug -> Debug -> Bool
< :: Debug -> Debug -> Bool
$c< :: Debug -> Debug -> Bool
compare :: Debug -> Debug -> Ordering
$ccompare :: Debug -> Debug -> Ordering
$cp1Ord :: Eq Debug
Ord, Int -> Debug -> ShowS
[Debug] -> ShowS
Debug -> String
(Int -> Debug -> ShowS)
-> (Debug -> String) -> ([Debug] -> ShowS) -> Show Debug
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Debug] -> ShowS
$cshowList :: [Debug] -> ShowS
show :: Debug -> String
$cshow :: Debug -> String
showsPrec :: Int -> Debug -> ShowS
$cshowsPrec :: Int -> Debug -> ShowS
Show, Debug -> Debug -> Bool
(Debug -> Debug -> Bool) -> (Debug -> Debug -> Bool) -> Eq Debug
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Debug -> Debug -> Bool
$c/= :: Debug -> Debug -> Bool
== :: Debug -> Debug -> Bool
$c== :: Debug -> Debug -> Bool
Eq, Int -> Debug
Debug -> Int
Debug -> [Debug]
Debug -> Debug
Debug -> Debug -> [Debug]
Debug -> Debug -> Debug -> [Debug]
(Debug -> Debug)
-> (Debug -> Debug)
-> (Int -> Debug)
-> (Debug -> Int)
-> (Debug -> [Debug])
-> (Debug -> Debug -> [Debug])
-> (Debug -> Debug -> [Debug])
-> (Debug -> Debug -> Debug -> [Debug])
-> Enum Debug
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Debug -> Debug -> Debug -> [Debug]
$cenumFromThenTo :: Debug -> Debug -> Debug -> [Debug]
enumFromTo :: Debug -> Debug -> [Debug]
$cenumFromTo :: Debug -> Debug -> [Debug]
enumFromThen :: Debug -> Debug -> [Debug]
$cenumFromThen :: Debug -> Debug -> [Debug]
enumFrom :: Debug -> [Debug]
$cenumFrom :: Debug -> [Debug]
fromEnum :: Debug -> Int
$cfromEnum :: Debug -> Int
toEnum :: Int -> Debug
$ctoEnum :: Int -> Debug
pred :: Debug -> Debug
$cpred :: Debug -> Debug
succ :: Debug -> Debug
$csucc :: Debug -> Debug
Enum, Debug
Debug -> Debug -> Bounded Debug
forall a. a -> a -> Bounded a
maxBound :: Debug
$cmaxBound :: Debug
minBound :: Debug
$cminBound :: Debug
Bounded)

-- | verbose debug flag

isVerbose :: POpts -> Bool
isVerbose :: POpts -> Bool
isVerbose = (Debug
DVerboseDebug -> Debug -> Bool
forall a. Eq a => a -> a -> Bool
==) (Debug -> Bool) -> (POpts -> Debug) -> POpts -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POpts -> Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug

-- | color palettes

type Color1 = 'OColor "color1" 'Default 'Blue 'Default 'Red 'Black 'Cyan 'Black 'Yellow
type Color2 = 'OColor "color2" 'Default 'Magenta 'Default 'Red 'Black 'White 'Black 'Yellow
type Color3 = 'OColor "color3" 'Default 'Blue 'Red 'Default 'White 'Default 'Black 'Yellow
type Color4 = 'OColor "color4" 'Default 'Red 'Red 'Default 'Green 'Default 'Black 'Yellow
type Color5 = 'OColor "color5" 'Blue 'Default 'Red 'Default 'Cyan 'Default 'Yellow 'Default

type Other1 = 'OOther 'True 'Yellow 'Default
type Other2 = 'OOther 'True 'Default 'Default

show3 :: (Show a1, Show a2)
  => POpts
  -> String
  -> a1
  -> a2
  -> String
show3 :: POpts -> String -> a1 -> a2 -> String
show3 POpts
opts String
msg0 a1
ret = POpts -> String -> a1 -> String -> ShowS
forall a1. Show a1 => POpts -> String -> a1 -> String -> ShowS
lit3 POpts
opts String
msg0 a1
ret String
"" ShowS -> (a2 -> String) -> a2 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a2 -> String
forall a. Show a => a -> String
show

show3' :: (Show a1, Show a2)
  => POpts
  -> String
  -> a1
  -> String
  -> a2
  -> String
show3' :: POpts -> String -> a1 -> String -> a2 -> String
show3' POpts
opts String
msg0 a1
ret String
fmt = POpts -> String -> a1 -> String -> ShowS
forall a1. Show a1 => POpts -> String -> a1 -> String -> ShowS
lit3 POpts
opts String
msg0 a1
ret String
fmt ShowS -> (a2 -> String) -> a2 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a2 -> String
forall a. Show a => a -> String
show

lit3 :: Show a1
  => POpts
  -> String
  -> a1
  -> String
  -> String
  -> String
lit3 :: POpts -> String -> a1 -> String -> ShowS
lit3 POpts
opts String
msg0 a1
ret String
fmt String
as
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
fmt Bool -> Bool -> Bool
&& String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
as = String
msg0
  | Bool
otherwise =
         String
msg0
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
msg0 then String
"" else String
" ")
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> a1 -> String
forall a. Show a => POpts -> a -> String
showL POpts
opts a1
ret
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> String -> ShowS
litVerbose POpts
opts (String
" | " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
100 String
fmt) String
as

-- | more restrictive: only display data in verbose debug mode

litVerbose :: POpts
         -> String
         -> String
         -> String
litVerbose :: POpts -> String -> ShowS
litVerbose POpts
o = POpts -> Debug -> String -> ShowS
showLitImpl POpts
o Debug
DVerbose

showLitImpl :: POpts
            -> Debug
            -> String
            -> String
            -> String
showLitImpl :: POpts -> Debug -> String -> ShowS
showLitImpl POpts
o Debug
i String
s String
a =
  if POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
o Debug -> Debug -> Bool
forall a. Ord a => a -> a -> Bool
>= Debug
i Bool -> Bool -> Bool
|| POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
o Debug -> Debug -> Bool
forall a. Eq a => a -> a -> Bool
== Debug
DLite then Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
100 String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> ShowS
litL POpts
o String
a
  else String
""

showVerbose :: Show a
  => POpts
  -> String
  -> a
  -> String
showVerbose :: POpts -> String -> a -> String
showVerbose POpts
o = POpts -> Debug -> String -> a -> String
forall a. Show a => POpts -> Debug -> String -> a -> String
showAImpl POpts
o Debug
DVerbose

showAImpl :: Show a
  => POpts
  -> Debug
  -> String
  -> a
  -> String
showAImpl :: POpts -> Debug -> String -> a -> String
showAImpl POpts
o Debug
i String
s a
a = POpts -> Debug -> String -> ShowS
showLitImpl POpts
o Debug
i (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
100 String
s) (a -> String
forall a. Show a => a -> String
show a
a)

showL :: Show a
  => POpts
  -> a
  -> String
showL :: POpts -> a -> String
showL POpts
o = POpts -> ShowS
litL POpts
o ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

litL :: POpts -> String -> String
litL :: POpts -> ShowS
litL = Int -> ShowS
litL' (Int -> ShowS) -> (POpts -> Int) -> POpts -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POpts -> Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oWidth

litL' :: Int -> String -> String
litL' :: Int -> ShowS
litL' Int
i String
s =
  let (String
z,String
e) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i String
s
  in String
z String -> ShowS
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
e then String
"" else String
"..."

litBL :: POpts -> BL8.ByteString -> String
litBL :: POpts -> ByteString -> String
litBL POpts
o ByteString
s =
  let i :: HKD Identity Int
i = POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oWidth POpts
o
  in Int -> ShowS
litL' Int
HKD Identity Int
i (ByteString -> String
BL8.unpack (Int64 -> ByteString -> ByteString
BL8.take (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
HKD Identity Int
i) ByteString
s))

litBS :: POpts -> BS8.ByteString -> String
litBS :: POpts -> ByteString -> String
litBS POpts
o ByteString
s =
  let i :: HKD Identity Int
i = POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oWidth POpts
o
  in Int -> ShowS
litL' Int
HKD Identity Int
i (ByteString -> String
BS8.unpack (Int -> ByteString -> ByteString
BS8.take Int
HKD Identity Int
i ByteString
s))

-- | extract values from the trees or if there are errors return a tree with context

splitAndAlign :: Show x =>
                    POpts
                    -> String
                    -> [((Int, x), TT a)]
                    -> Either (TT w) [(a, (Int, x), TT a)]
splitAndAlign :: POpts
-> String
-> [((Int, x), TT a)]
-> Either (TT w) [(a, (Int, x), TT a)]
splitAndAlign POpts
opts String
msgs [((Int, x), TT a)]
ts =
  case [Either (((Int, x), TT Any), String) (a, (Int, x), TT a)]
-> ([(((Int, x), TT Any), String)], [(a, (Int, x), TT a)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((((Int, x), TT a)
 -> Either (((Int, x), TT Any), String) (a, (Int, x), TT a))
-> [((Int, x), TT a)]
-> [Either (((Int, x), TT Any), String) (a, (Int, x), TT a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, x), TT a)
-> Either (((Int, x), TT Any), String) (a, (Int, x), TT a)
forall w a x. (w, TT a) -> Either ((w, TT x), String) (a, w, TT a)
partitionTTExtended [((Int, x), TT a)]
ts) of
     (excs :: [(((Int, x), TT Any), String)]
excs@((((Int, x), TT Any), String)
e:[(((Int, x), TT Any), String)]
_), [(a, (Int, x), TT a)]
_) ->
          TT w -> Either (TT w) [(a, (Int, x), TT a)]
forall a b. a -> Either a b
Left (TT w -> Either (TT w) [(a, (Int, x), TT a)])
-> TT w -> Either (TT w) [(a, (Int, x), TT a)]
forall a b. (a -> b) -> a -> b
$ POpts -> Val w -> String -> Forest PE -> TT w
forall a. POpts -> Val a -> String -> Forest PE -> TT a
mkNode POpts
opts
                       (String -> Val w
forall a. String -> Val a
Fail ([String] -> String
groupErrors (((((Int, x), TT Any), String) -> String)
-> [(((Int, x), TT Any), String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, x), TT Any), String) -> String
forall a b. (a, b) -> b
snd [(((Int, x), TT Any), String)]
excs)))
                       (String
msgs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (POpts -> [((Int, x), TT Any)] -> String
forall x z. Show x => POpts -> [((Int, x), z)] -> String
formatList POpts
opts [(((Int, x), TT Any), String) -> ((Int, x), TT Any)
forall a b. (a, b) -> a
fst (((Int, x), TT Any), String)
e] String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" excnt=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(((Int, x), TT Any), String)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(((Int, x), TT Any), String)]
excs)))
                       ((((Int, x), TT a) -> Tree PE) -> [((Int, x), TT a)] -> Forest PE
forall a b. (a -> b) -> [a] -> [b]
map (TT a -> Tree PE
forall a. TT a -> Tree PE
hh (TT a -> Tree PE)
-> (((Int, x), TT a) -> TT a) -> ((Int, x), TT a) -> Tree PE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, x), TT a) -> TT a
forall a b. (a, b) -> b
snd) [((Int, x), TT a)]
ts)
     ([], [(a, (Int, x), TT a)]
tfs) -> [(a, (Int, x), TT a)] -> Either (TT w) [(a, (Int, x), TT a)]
forall a b. b -> Either a b
Right [(a, (Int, x), TT a)]
tfs

groupErrors :: [String] -> String
groupErrors :: [String] -> String
groupErrors =
     String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | "
   ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty String -> String) -> [NonEmpty String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\xs :: NonEmpty String
xs@(String
x :| [String]
_) -> String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if NonEmpty String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NonEmpty String
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (NonEmpty String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NonEmpty String
xs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")" else String
""))
   ([NonEmpty String] -> [String])
-> ([String] -> [NonEmpty String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [NonEmpty String]
forall (f :: Type -> Type) a.
(Foldable f, Eq a) =>
f a -> [NonEmpty a]
N.group

partitionTTExtended :: (w, TT a) -> Either ((w, TT x), String) (a, w, TT a)
partitionTTExtended :: (w, TT a) -> Either ((w, TT x), String) (a, w, TT a)
partitionTTExtended (w
s, TT a
t) =
  case TT a -> Val a
forall a. TT a -> Val a
_ttVal TT a
t of
    Fail String
e -> ((w, TT x), String) -> Either ((w, TT x), String) (a, w, TT a)
forall a b. a -> Either a b
Left ((w
s, TT a
t TT a -> (TT a -> TT x) -> TT x
forall a b. a -> (a -> b) -> b
& (Val a -> Identity (Val x)) -> TT a -> Identity (TT x)
forall a b. Lens (TT a) (TT b) (Val a) (Val b)
ttVal ((Val a -> Identity (Val x)) -> TT a -> Identity (TT x))
-> Val x -> TT a -> TT x
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Val x
forall a. String -> Val a
Fail String
e), String
e)
    Val a
a -> (a, w, TT a) -> Either ((w, TT x), String) (a, w, TT a)
forall a b. b -> Either a b
Right (a
a,w
s,TT a
t)

formatList :: forall x z . Show x
  => POpts
  -> [((Int, x), z)]
  -> String
formatList :: POpts -> [((Int, x), z)] -> String
formatList POpts
opts = [String] -> String
unwords ([String] -> String)
-> ([((Int, x), z)] -> [String]) -> [((Int, x), z)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, x), z) -> String) -> [((Int, x), z)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\((Int
i, x
a), z
_) -> String
"(i=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> Debug -> String -> x -> String
forall a. Show a => POpts -> Debug -> String -> a -> String
showAImpl POpts
opts Debug
DLite String
", a=" x
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")")

-- | pretty print a tree

toNodeString :: POpts
             -> PE
             -> String
toNodeString :: POpts -> PE -> String
toNodeString POpts
opts PE
bpe =
  if POpts -> Bool
hasNoTree POpts
opts
  then ShowS
forall x. HasCallStack => String -> x
errorInProgram ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"shouldnt be calling this if we are dropping details: toNodeString " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Debug -> String
forall a. Show a => a -> String
show (POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PE -> String
forall a. Show a => a -> String
show PE
bpe
  else Long -> POpts -> ValP -> String
colorValP Long
Long POpts
opts (PE -> ValP
_peValP PE
bpe) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PE -> String
_peString PE
bpe

hasNoTree :: POpts -> Bool
hasNoTree :: POpts -> Bool
hasNoTree POpts
opts =
  case POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts of
    HKD Identity Debug
DZero -> Bool
True
    HKD Identity Debug
DLite -> Bool
True
    HKD Identity Debug
DNormal -> Bool
False
    HKD Identity Debug
DVerbose -> Bool
False

-- | render 'ValP' value with colors

colorValP ::
     Long
  -> POpts
  -> ValP
  -> String
colorValP :: Long -> POpts -> ValP -> String
colorValP Long
long POpts
o ValP
bp =
  case ValP
bp of
    FailP String
e -> case Long
long of
                 Long
Long -> String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
f String
"Error" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
nullSpace String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
                 Long
Short -> ShowS
f String
"Failed"
    ValP
FalseP -> ShowS
f String
"False"
    ValP
TrueP -> ShowS
f String
"True"
    ValP
ValP -> ShowS
f String
"P"
  where f :: ShowS
f = POpts -> ValP -> ShowS
colorMe POpts
o ValP
bp

data Long = Long | Short deriving (Int -> Long -> ShowS
[Long] -> ShowS
Long -> String
(Int -> Long -> ShowS)
-> (Long -> String) -> ([Long] -> ShowS) -> Show Long
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Long] -> ShowS
$cshowList :: [Long] -> ShowS
show :: Long -> String
$cshow :: Long -> String
showsPrec :: Int -> Long -> ShowS
$cshowsPrec :: Int -> Long -> ShowS
Show, Long -> Long -> Bool
(Long -> Long -> Bool) -> (Long -> Long -> Bool) -> Eq Long
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Long -> Long -> Bool
$c/= :: Long -> Long -> Bool
== :: Long -> Long -> Bool
$c== :: Long -> Long -> Bool
Eq)

-- | render 'Val' value with colors

colorValLite :: Show a
    => POpts
    -> (Val a, ValP)
    -> String
colorValLite :: POpts -> (Val a, ValP) -> String
colorValLite POpts
o (Val a
bt,ValP
bp') =
  let f :: ShowS
f = POpts -> ValP -> ShowS
colorMe POpts
o ValP
bp
      bp :: ValP
bp = ValP -> Val a -> ValP
forall a. ValP -> Val a -> ValP
validateValP ValP
bp' Val a
bt
  in case Val a
bt of
       Fail String
e -> ShowS
f String
"Error" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
       Val a
a -> case ValP
bp of
                  ValP
FalseP -> ShowS
f String
"False"
                  ValP
TrueP -> ShowS
f String
"True"
                  ValP
ValP -> ShowS
f String
"Present" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
a
                  FailP {} -> ShowS
forall x. HasCallStack => String -> x
errorInProgram ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"colorValLite: unexpected FailP " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Val a, ValP) -> String
forall a. Show a => a -> String
show (Val a
bt,ValP
bp)

colorValBool ::
      POpts
   -> Val Bool
   -> String
colorValBool :: POpts -> Val Bool -> String
colorValBool POpts
o Val Bool
r =
  let f :: ShowS
f = POpts -> ValP -> ShowS
colorMe POpts
o (Val Bool -> ValP
forall a. (a ~ Bool) => Val a -> ValP
val2PBool Val Bool
r)
  in case Val Bool
r of
      Fail String
e -> ShowS
f String
"Fail" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
      Val Bool
False -> ShowS
f String
"False"
      Val Bool
True -> ShowS
f String
"True"

-- | colors the result of the predicate based on the current color palette

colorMe ::
     POpts
  -> ValP
  -> String
  -> String
colorMe :: POpts -> ValP -> ShowS
colorMe POpts
o ValP
b String
s =
  let (String
_, PColor
f) | POpts -> HKD Identity Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor POpts
o = (String, PColor)
nocolor
             | Bool
otherwise = POpts -> HKD Identity (String, PColor)
forall (f :: Type -> Type). HOpts f -> HKD f (String, PColor)
oColor POpts
o
  in PColor -> ValP -> ShowS
coerce PColor
f ValP
b String
s

-- | display tree

prtTreePure ::
     POpts
  -> Tree PE
  -> String
prtTreePure :: POpts -> Tree PE -> String
prtTreePure POpts
opts Tree PE
t
  | POpts -> Bool
hasNoTree POpts
opts = Long -> POpts -> ValP -> String
colorValP Long
Long POpts
opts (Tree PE
t Tree PE -> Getting ValP (Tree PE) ValP -> ValP
forall s a. s -> Getting a s a -> a
^. (PE -> Const ValP PE) -> Tree PE -> Const ValP (Tree PE)
forall a. Lens' (Tree a) a
root ((PE -> Const ValP PE) -> Tree PE -> Const ValP (Tree PE))
-> ((ValP -> Const ValP ValP) -> PE -> Const ValP PE)
-> Getting ValP (Tree PE) ValP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValP -> Const ValP ValP) -> PE -> Const ValP PE
Lens' PE ValP
peValP)
  | Bool
otherwise = POpts -> Tree String -> String
showTreeImpl POpts
opts (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$ (PE -> String) -> Tree PE -> Tree String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (POpts -> PE -> String
toNodeString POpts
opts) Tree PE
t

showTreeImpl :: POpts
         -> Tree String
         -> String
showTreeImpl :: POpts -> Tree String -> String
showTreeImpl POpts
o =
  case POpts -> HKD Identity Disp
forall (f :: Type -> Type). HOpts f -> HKD f Disp
oDisp POpts
o of
    HKD Identity Disp
Unicode -> Tree String -> String
drawTreeU
    HKD Identity Disp
Ansi -> ShowS
forall a. [a] -> [a]
Safe.initSafe ShowS -> (Tree String -> String) -> Tree String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> String
drawTree -- to drop the last newline else we have to make sure that everywhere else has that newline


-- | extract message part from tree

topMessage :: TT a -> String
topMessage :: TT a -> String
topMessage TT a
pp =
  let s :: String
s = TT a -> String
forall a. TT a -> String
_ttString TT a
pp
  in String -> ShowS
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
t a -> m -> m
unlessNull String
s ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | render numbered tree

prefixNumberToTT :: ((Int, x), TT a) -> TT a
prefixNumberToTT :: ((Int, x), TT a) -> TT a
prefixNumberToTT ((Int
i, x
_), TT a
t) = String -> TT a -> TT a
forall a. String -> TT a -> TT a
prefixMsg (String
"i=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": ") TT a
t

-- | prefix text in front of ttString

prefixMsg :: String -> TT a -> TT a
prefixMsg :: String -> TT a -> TT a
prefixMsg String
msg = (String -> Identity String) -> TT a -> Identity (TT a)
forall a. Lens' (TT a) String
ttString ((String -> Identity String) -> TT a -> Identity (TT a))
-> ShowS -> TT a -> TT a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)

-- | a typeclass for choosing which monad to run in

--

-- >>> hasIO @IO

-- True

--

-- >>> hasIO @Identity

-- False

--


class Monad m => MonadEval m where
  runIO :: IO a -> m (Maybe a)
  catchit :: a -> m (Either String a)
  catchitNF :: NFData a => a -> m (Either String a)
  liftEval :: m a -> IO a
  hasIO :: Bool
  hasIO = Bool
False

-- | 'Identity' instance for evaluating the expression

instance MonadEval Identity where
  runIO :: IO a -> Identity (Maybe a)
runIO IO a
_ = Maybe a -> Identity (Maybe a)
forall a. a -> Identity a
Identity Maybe a
forall a. Maybe a
Nothing
  catchit :: a -> Identity (Either String a)
catchit = a -> Identity (Either String a)
forall a. a -> Identity (Either String a)
catchitIdentityUnsafe
  catchitNF :: a -> Identity (Either String a)
catchitNF = a -> Identity (Either String a)
forall a. NFData a => a -> Identity (Either String a)
catchitNFIdentityUnsafe
  liftEval :: Identity a -> IO a
liftEval = a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a -> IO a) -> (Identity a -> a) -> Identity a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity


{-# NOINLINE catchitIdentityUnsafe #-}
catchitIdentityUnsafe :: a -> Identity (Either String a)
catchitIdentityUnsafe :: a -> Identity (Either String a)
catchitIdentityUnsafe a
v = Either String a -> Identity (Either String a)
forall a. a -> Identity a
Identity (Either String a -> Identity (Either String a))
-> Either String a -> Identity (Either String a)
forall a b. (a -> b) -> a -> b
$ IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$ a -> IO (Either String a)
forall (m :: Type -> Type) a.
MonadEval m =>
a -> m (Either String a)
catchit @IO a
v

{-# NOINLINE catchitNFIdentityUnsafe #-}
catchitNFIdentityUnsafe :: NFData a => a -> Identity (Either String a)
catchitNFIdentityUnsafe :: a -> Identity (Either String a)
catchitNFIdentityUnsafe a
v = Either String a -> Identity (Either String a)
forall a. a -> Identity a
Identity (Either String a -> Identity (Either String a))
-> Either String a -> Identity (Either String a)
forall a b. (a -> b) -> a -> b
$ IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$ a -> IO (Either String a)
forall (m :: Type -> Type) a.
(MonadEval m, NFData a) =>
a -> m (Either String a)
catchitNF @IO a
v


-- | 'IO' instance for evaluating the expression

instance MonadEval IO where
  runIO :: IO a -> IO (Maybe a)
runIO IO a
ioa = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
ioa
  catchit :: a -> IO (Either String a)
catchit a
v = Either String a -> IO (Either String a)
forall a. a -> IO a
E.evaluate (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> a -> Either String a
forall a b. (a -> b) -> a -> b
$! a
v) IO (Either String a)
-> (SomeException -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(E.SomeException e
e) -> Either String a -> IO (Either String a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left (String
"IO e=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall a. Show a => a -> String
show e
e))
  catchitNF :: a -> IO (Either String a)
catchitNF a
v = Either String a -> IO (Either String a)
forall a. a -> IO a
E.evaluate (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> a -> Either String a
forall a b. NFData a => (a -> b) -> a -> b
$!! a
v) IO (Either String a)
-> (SomeException -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(E.SomeException e
e) -> Either String a -> IO (Either String a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left (String
"IO e=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall a. Show a => a -> String
show e
e))
  liftEval :: IO a -> IO a
liftEval = IO a -> IO a
forall a. a -> a
id
  hasIO :: Bool
hasIO = Bool
True

-- composite types are used instead of type synonyms as showT (typeRep) unrolls the definition

-- eg sqlhandler.encode/decode and parsejson* etc

-- | Display options

data Opt =
    OEmpty                -- ^ mempty

  | OWidth !Nat           -- ^ set display width

  | OMsg !Symbol          -- ^ set text to add context to a failure message for refined types

  | ORecursion !Nat       -- ^ set recursion limit eg for regex

  | OOther                -- ^ set effects for messages

     !Bool    -- ^ set underline

     !Color   -- ^ set foreground color

     !Color   -- ^ set background color

  | !Opt :# !Opt        -- ^ mappend

  | OColor    -- ^ set color palette

     !Symbol  -- ^ name of color palette

     !Color   -- ^ Fail foreground color

     !Color   -- ^ Fail background color

     !Color   -- ^ False foreground color

     !Color   -- ^ False background color

     !Color   -- ^ True foreground color

     !Color   -- ^ True background color

     !Color   -- ^ Present foreground color

     !Color   -- ^ Present background color

  | OColorOn  -- ^ turn on colors

  | OColorOff -- ^ turn off colors

  | OAnsi                 -- ^ ansi display

  | OUnicode              -- ^ unicode display

  | OZero                 -- ^ debug mode return nothing

  | OLite                 -- ^ debug mode return one line

  | ONormal               -- ^ debug mode normal

  | OVerbose              -- ^ debug mode verbose

  | OZ                    -- ^ composite: no messages

  | OL                    -- ^ composite: lite version

  | OA                    -- ^ composite: ansi + colors

  | OAB                   -- ^ composite: ansi + colors + background

  | OAN                   -- ^ composite: ansi + no colors

  | OAV                   -- ^ composite: ansi + colors + verbose

  | OANV                  -- ^ composite: ansi + no colors + verbose

  | OU                    -- ^ composite: unicode + colors

  | OUB                   -- ^ composite: unicode + colors + background

  | OUN                   -- ^ composite: unicode + no colors

  | OUV                   -- ^ composite: unicode + colors + verbose

  | OUNV                  -- ^ composite: unicode + no colors + verbose


infixr 6 :#
-- | extract options from the typelevel

class OptC (k :: Opt) where
   getOptC :: HOpts Last
instance KnownNat n => OptC ('OWidth n) where
   getOptC :: HOpts Last
getOptC = Int -> HOpts Last
setWidth (forall a. (KnownNat n, Num a) => a
forall (n :: Nat) a. (KnownNat n, Num a) => a
nat @n)
instance KnownSymbol s => OptC ('OMsg s) where
   getOptC :: HOpts Last
getOptC = String -> HOpts Last
setMessage (KnownSymbol s => String
forall (s :: Symbol). KnownSymbol s => String
symb @s)
instance KnownNat n => OptC ('ORecursion n) where
   getOptC :: HOpts Last
getOptC = Int -> HOpts Last
setRecursion (forall a. (KnownNat n, Num a) => a
forall (n :: Nat) a. (KnownNat n, Num a) => a
nat @n)
instance ( GetBool b
         , GetColor c1
         , GetColor c2
         ) => OptC ('OOther b c1 c2) where
   getOptC :: HOpts Last
getOptC = Bool -> Color -> Color -> HOpts Last
setOther (GetBool b => Bool
forall (a :: Bool). GetBool a => Bool
getBool @b) (GetColor c1 => Color
forall (a :: Color). GetColor a => Color
getColor @c1) (GetColor c2 => Color
forall (a :: Color). GetColor a => Color
getColor @c2)
instance OptC 'OEmpty where
   getOptC :: HOpts Last
getOptC = HOpts Last
forall a. Monoid a => a
mempty
instance ( OptC a
         , OptC b
         ) => OptC (a ':# b) where
   getOptC :: HOpts Last
getOptC = OptC a => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @a HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> OptC b => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @b
instance ( KnownSymbol s
         , GetColor c1
         , GetColor c2
         , GetColor c3
         , GetColor c4
         , GetColor c5
         , GetColor c6
         , GetColor c7
         , GetColor c8)
  => OptC ('OColor s c1 c2 c3 c4 c5 c6 c7 c8) where
     getOptC :: HOpts Last
getOptC = String
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> Color
-> HOpts Last
setCreateColor
        (KnownSymbol s => String
forall (s :: Symbol). KnownSymbol s => String
symb @s)
        (GetColor c1 => Color
forall (a :: Color). GetColor a => Color
getColor @c1)
        (GetColor c2 => Color
forall (a :: Color). GetColor a => Color
getColor @c2)
        (GetColor c3 => Color
forall (a :: Color). GetColor a => Color
getColor @c3)
        (GetColor c4 => Color
forall (a :: Color). GetColor a => Color
getColor @c4)
        (GetColor c5 => Color
forall (a :: Color). GetColor a => Color
getColor @c5)
        (GetColor c6 => Color
forall (a :: Color). GetColor a => Color
getColor @c6)
        (GetColor c7 => Color
forall (a :: Color). GetColor a => Color
getColor @c7)
        (GetColor c8 => Color
forall (a :: Color). GetColor a => Color
getColor @c8)
instance OptC 'OColorOn where
   getOptC :: HOpts Last
getOptC = Bool -> HOpts Last
setNoColor Bool
False
instance OptC 'OColorOff where
   getOptC :: HOpts Last
getOptC = Bool -> HOpts Last
setNoColor Bool
True
instance OptC 'OAnsi where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi
instance OptC 'OUnicode where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Unicode
instance OptC 'OZero where
   getOptC :: HOpts Last
getOptC = Debug -> HOpts Last
setDebug Debug
DZero
instance OptC 'OLite where
   getOptC :: HOpts Last
getOptC = Debug -> HOpts Last
setDebug Debug
DLite
instance OptC 'ONormal where
   getOptC :: HOpts Last
getOptC = Debug -> HOpts Last
setDebug Debug
DNormal
instance OptC 'OVerbose where
   getOptC :: HOpts Last
getOptC = Debug -> HOpts Last
setDebug Debug
DVerbose
instance OptC 'OZ where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Bool -> HOpts Last
setNoColor Bool
True HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DZero
instance OptC 'OL where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Bool -> HOpts Last
setNoColor Bool
True HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DLite HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Int -> HOpts Last
setWidth Int
200
instance OptC 'OA where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> OptC Color5 => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @Color5 HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DNormal HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> OptC Other2 => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @Other2 HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Int -> HOpts Last
setWidth Int
100
instance OptC 'OAB where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> OptC Color1 => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @Color1 HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DNormal HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> OptC Other1 => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @Other1 HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Int -> HOpts Last
setWidth Int
100
instance OptC 'OAN where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Bool -> HOpts Last
setNoColor Bool
True HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DNormal HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Int -> HOpts Last
setWidth Int
100
instance OptC 'OAV where
   getOptC :: HOpts Last
getOptC = OptC ('OA ':# ('OVerbose ':# 'OWidth 200)) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OA ':# 'OVerbose ':# 'OWidth 200)
instance OptC 'OANV where
   getOptC :: HOpts Last
getOptC = Disp -> HOpts Last
setDisp Disp
Ansi HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Bool -> HOpts Last
setNoColor Bool
True HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Debug -> HOpts Last
setDebug Debug
DVerbose HOpts Last -> HOpts Last -> HOpts Last
forall a. Semigroup a => a -> a -> a
<> Int -> HOpts Last
setWidth Int
200
instance OptC 'OU where
   getOptC :: HOpts Last
getOptC = OptC ('OA ':# 'OUnicode) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OA ':# 'OUnicode)
instance OptC 'OUB where
   getOptC :: HOpts Last
getOptC = OptC ('OAB ':# 'OUnicode) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OAB ':# 'OUnicode)
instance OptC 'OUN where
   getOptC :: HOpts Last
getOptC = OptC ('OAN ':# 'OUnicode) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OAN ':# 'OUnicode)
instance OptC 'OUV where
   getOptC :: HOpts Last
getOptC = OptC ('OAV ':# 'OUnicode) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OAV ':# 'OUnicode)
instance OptC 'OUNV where
   getOptC :: HOpts Last
getOptC = OptC ('OANV ':# 'OUnicode) => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @('OANV ':# 'OUnicode)

-- | option synonyms to save a keystroke

type OZ = 'OZ     -- 'OAnsi ':# 'OColorOff ':# 'OZero

type OL = 'OL     -- 'OAnsi ':# 'OColorOff ':# 'OLite ':# 'OWidth 200

type OA = 'OA     -- 'OAnsi ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100

type OAB = 'OAB   -- 'OAnsi ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100

type OAN = 'OAN   -- 'OAnsi ':# 'OColorOff ':# 'ONormal ':# 'OWidth 100

type OAV = 'OAV   -- 'OAnsi ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200

type OANV = 'OANV -- 'OAnsi ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200

type OU = 'OU     -- 'OUnicode ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100

type OUB = 'OUB   -- 'OUnicode ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100

type OUN = 'OUN   -- 'OUnicode ':# 'OColorOff ':# 'OWidth 200

type OUV = 'OUV   -- 'OUnicode ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200

type OUNV = 'OUNV -- 'OUnicode ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200


_Debug :: Lens' POpts Debug
_Debug :: (Debug -> f Debug) -> POpts -> f POpts
_Debug Debug -> f Debug
afb POpts
opts = (\Debug
d -> POpts
opts { oDebug :: HKD Identity Debug
oDebug = Debug
HKD Identity Debug
d }) (Debug -> POpts) -> f Debug -> f POpts
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Debug -> f Debug
afb (POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts)

_DVerboseI :: Prism' Debug ()
_DVerboseI :: p () (f ()) -> p Debug (f Debug)
_DVerboseI =
  (() -> Debug) -> (Debug -> Maybe ()) -> Prism Debug Debug () ()
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Debug -> () -> Debug
forall a b. a -> b -> a
const Debug
DVerbose)
  ((Debug -> Maybe ()) -> Prism Debug Debug () ())
-> (Debug -> Maybe ()) -> Prism Debug Debug () ()
forall a b. (a -> b) -> a -> b
$ \case
       Debug
DVerbose -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
       Debug
_ -> Maybe ()
forall a. Maybe a
Nothing

-- | traversal for DVerbose

--

-- >>> has _DVerbose (getOpt @OU)

-- False

--

-- >>> has _DVerbose (getOpt @OUV)

-- True

--

_DVerbose :: Traversal' POpts ()
_DVerbose :: (() -> f ()) -> POpts -> f POpts
_DVerbose = (Debug -> f Debug) -> POpts -> f POpts
Lens' POpts Debug
_Debug ((Debug -> f Debug) -> POpts -> f POpts)
-> ((() -> f ()) -> Debug -> f Debug)
-> (() -> f ())
-> POpts
-> f POpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> f ()) -> Debug -> f Debug
Prism Debug Debug () ()
_DVerboseI

-- | convert typelevel options to 'POpts'

--

-- >>> (oDisp &&& fst . oColor &&& oWidth) (getOpt @(OA ':# OU ':# OA ':# 'OWidth 321 ':# Color4 ':# 'OMsg "test message"))

-- (Ansi,("color4",321))

--

-- >>> oMsg (getOpt @('OMsg "abc" ':# 'OMsg "def"))

-- ["abc","def"]

--

-- >>> oOther (getOpt @('OOther 'False 'Red 'White ':# 'OOther 'True 'Red 'Black))

-- (True,Red,Black)

--

-- >>> a = show (getOpt @('OEmpty ':# OU))

-- >>> b = show (getOpt @(OU ':# 'OEmpty));

-- >>> c = show (getOpt @OU)

-- >>> a==b && b==c

-- True

--

getOpt :: forall o . OptC o => POpts
getOpt :: POpts
getOpt = HOpts Last -> POpts
reifyOpts (OptC o => HOpts Last
forall (k :: Opt). OptC k => HOpts Last
getOptC @o)

-- | deal with possible recursion on a list

chkSize :: Foldable t
   => POpts
   -> String
   -> t a
   -> [Tree PE]
   -> Either (TT x) [a]
chkSize :: POpts -> String -> t a -> Forest PE -> Either (TT x) [a]
chkSize POpts
opts String
msg0 t a
xs Forest PE
hhs =
  let mx :: HKD Identity Int
mx = POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursion POpts
opts
  in case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
HKD Identity Int
mx (t a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList t a
xs) of
    ([a]
zs,[]) -> [a] -> Either (TT x) [a]
forall a b. b -> Either a b
Right [a]
zs
    ([a]
_,a
_:[a]
_) -> TT x -> Either (TT x) [a]
forall a b. a -> Either a b
Left (TT x -> Either (TT x) [a]) -> TT x -> Either (TT x) [a]
forall a b. (a -> b) -> a -> b
$ POpts -> Val x -> String -> Forest PE -> TT x
forall a. POpts -> Val a -> String -> Forest PE -> TT a
mkNode POpts
opts (String -> Val x
forall a. String -> Val a
Fail (String
msg0 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" list size exceeded")) (String
"max is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
HKD Identity Int
mx) Forest PE
hhs

-- | deal with possible recursion on two lists

chkSize2 :: (Foldable t, Foldable u)
   => POpts
   -> String
   -> t a
   -> u b
   -> [Tree PE]
   -> Either (TT x) ([a],[b])
chkSize2 :: POpts
-> String -> t a -> u b -> Forest PE -> Either (TT x) ([a], [b])
chkSize2 POpts
opts String
msg0 t a
xs u b
ys Forest PE
hhs =
  (,) ([a] -> [b] -> ([a], [b]))
-> Either (TT x) [a] -> Either (TT x) ([b] -> ([a], [b]))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> POpts -> String -> t a -> Forest PE -> Either (TT x) [a]
forall (t :: Type -> Type) a x.
Foldable t =>
POpts -> String -> t a -> Forest PE -> Either (TT x) [a]
chkSize POpts
opts String
msg0 t a
xs Forest PE
hhs Either (TT x) ([b] -> ([a], [b]))
-> Either (TT x) [b] -> Either (TT x) ([a], [b])
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> POpts -> String -> u b -> Forest PE -> Either (TT x) [b]
forall (t :: Type -> Type) a x.
Foldable t =>
POpts -> String -> t a -> Forest PE -> Either (TT x) [a]
chkSize POpts
opts String
msg0 u b
ys Forest PE
hhs

-- | pretty print a message

formatOMsg :: POpts -> String -> String
formatOMsg :: POpts -> ShowS
formatOMsg POpts
o String
suffix =
  case POpts -> [String]
forall (f :: Type -> Type). HOpts f -> [String]
oMsg POpts
o of
    [] -> String
forall a. Monoid a => a
mempty
    s :: [String]
s@(String
_:[String]
_) -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | " (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (POpts -> ShowS
setOtherEffects POpts
o) [String]
s) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suffix

-- | override options for 'DZero' so we dont lose error information

subopts :: POpts -> POpts
subopts :: POpts -> POpts
subopts POpts
opts =
  case POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts of
    HKD Identity Debug
DZero -> POpts
opts { oDebug :: HKD Identity Debug
oDebug = Debug
HKD Identity Debug
DLite }
    HKD Identity Debug
_ -> POpts
opts

-- | render a string for messages using optional color and underline

setOtherEffects :: POpts -> String -> String
setOtherEffects :: POpts -> ShowS
setOtherEffects POpts
o =
  if POpts -> HKD Identity Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oNoColor POpts
o then ShowS
forall a. a -> a
id
  else case (Bool, SColor, SColor) -> (Bool, Color, Color)
coerce (POpts -> HKD Identity (Bool, SColor, SColor)
forall (f :: Type -> Type). HOpts f -> HKD f (Bool, SColor, SColor)
oOther POpts
o) of
         (Bool
False, Color
Default, Color
Default) -> ShowS
forall a. a -> a
id
         (Bool
b, Color
c1, Color
c2) -> (if Bool
b then Style -> ShowS
forall a. Pretty a => Style -> a -> a
C.style Style
C.Underline else ShowS
forall a. a -> a
id) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.color Color
c1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ShowS
forall a. Pretty a => Color -> a -> a
C.bgColor Color
c2

-- | mconcat 'Opt' options at the type level

--

-- >>> x = getOpt @(OptT '[ 'OMsg "test", 'ORecursion 123, OU, OL, 'OMsg "field2"])

-- >>> oMsg x

-- ["test","field2"]

-- >>> oRecursion x

-- 123

--

type family OptT (xs :: [Opt]) where
  OptT '[] = 'OEmpty
  OptT (x ': xs) = x ':# OptT xs

-- | message to display when the length of a foldable is exceeded

badLength :: Foldable t
          => t a
          -> Int
          -> String
badLength :: t a -> Int -> String
badLength t a
as Int
n = String
":invalid length(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (t a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length t a
as) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

prtTree :: Show x => POpts -> TT x -> String
prtTree :: POpts -> TT x -> String
prtTree POpts
opts TT x
tt =
  case POpts -> HKD Identity Debug
forall (f :: Type -> Type). HOpts f -> HKD f Debug
oDebug POpts
opts of
     HKD Identity Debug
DZero -> String
""

     HKD Identity Debug
DLite ->
           POpts -> ShowS
formatOMsg POpts
opts String
" >>> "
           String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> (Val x, ValP) -> String
forall a. Show a => POpts -> (Val a, ValP) -> String
colorValLite POpts
opts ((TT x -> Val x
forall a. TT a -> Val a
_ttVal (TT x -> Val x) -> (TT x -> ValP) -> TT x -> (Val x, ValP)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TT x -> ValP
forall a. TT a -> ValP
_ttValP) TT x
tt)
           String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
           String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TT x -> String
forall a. TT a -> String
topMessage TT x
tt

     HKD Identity Debug
_ -> POpts -> ShowS
formatOMsg POpts
opts String
""
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> POpts -> Tree PE -> String
prtTreePure POpts
opts (TT x -> Tree PE
forall a. TT a -> Tree PE
hh TT x
tt)

verboseList :: POpts -> TT a -> [Tree PE]
verboseList :: POpts -> TT a -> Forest PE
verboseList POpts
o TT a
tt
  | POpts -> Bool
isVerbose POpts
o = [TT a -> Tree PE
forall a. TT a -> Tree PE
hh TT a
tt]
  | Bool
otherwise = []

-- | iso for 'Val'

--

-- >>> Val 123 ^. _ValEither

-- Right 123

--

-- >>> Val 123 & _ValEither %~ right' (show . succ)

-- Val "124"

--

-- >>> Fail "abc" & _ValEither %~ ((<>"def") +++ (show . succ))

-- Fail "abcdef"

--

-- >>> Right 1.2 & from _ValEither %~ fmap (show . (*10))

-- Right "12.0"

--

-- >>> Val True ^. _ValEither

-- Right True

--

-- >>> Fail "abc" ^. _ValEither

-- Left "abc"

--

-- >>> Left "abc" ^. from _ValEither

-- Fail "abc"

--

-- >>> _ValEither # Right False

-- Val False

--

-- >>> [Just (Val 'x')] ^. mapping (mapping _ValEither)

-- [Just (Right 'x')]

--

-- >>> Just (Fail "abcd") ^. mapping _ValEither

-- Just (Left "abcd")

--

_ValEither :: Iso (Val a) (Val b) (Either String a) (Either String b)
_ValEither :: p (Either String a) (f (Either String b)) -> p (Val a) (f (Val b))
_ValEither = (Val a -> Either String a)
-> (Either String b -> Val b)
-> Iso (Val a) (Val b) (Either String a) (Either String b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Val a -> Either String a
forall b. Val b -> Either String b
fw Either String b -> Val b
forall a. Either String a -> Val a
bw
  where fw :: Val b -> Either String b
fw = \case
               Val b
a -> b -> Either String b
forall a b. b -> Either a b
Right b
a
               Fail String
e -> String -> Either String b
forall a b. a -> Either a b
Left String
e
        bw :: Either String a -> Val a
bw = (String -> Val a) -> (a -> Val a) -> Either String a -> Val a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Val a
forall a. String -> Val a
Fail a -> Val a
forall a. a -> Val a
Val

-- | converts from a typed 'Val' to the untyped 'ValP'

--

-- >>> val2P (Val True)

-- ValP

--

-- >>> val2P (Val 123)

-- ValP

--

-- >>> val2P (Fail "abc")

-- FailP "abc"

--

val2P :: Val a -> ValP
val2P :: Val a -> ValP
val2P =
  \case
    Fail String
e -> String -> ValP
FailP String
e
    Val {} -> ValP
ValP

-- | converts from a typed 'Val' Bool to the untyped 'ValP'

--

-- >>> val2PBool (Val True)

-- TrueP

--

-- >>> val2PBool (Val False)

-- FalseP

--

-- >>> val2PBool (Fail "abc")

-- FailP "abc"

--

val2PBool :: a ~ Bool => Val a -> ValP
val2PBool :: Val a -> ValP
val2PBool =
  \case
    Fail String
e -> String -> ValP
FailP String
e
    Val a
True -> ValP
TrueP
    Val a
False -> ValP
FalseP

-- | lens that keeps 'ValP' in sync with 'Val' for TT Bool

--

-- >>> (TT ValP (Val True) "xxx" [] & ttValBool %~ \b -> fmap not b) == TT FalseP (Val False) "xxx" []

-- True

--

-- >>> (TT ValP (Val True) "xxx" [] & ttValBool .~ Fail "abc") == TT (FailP "abc") (Fail "abc") "xxx" []

-- True

--

-- >>> (TT ValP (Val True) "xxx" [] & ttValBool %~ id) == TT TrueP (Val True) "xxx" []

-- True

--

-- >>> (TT FalseP (Val True) "xxx" [] & ttValBool %~ id) == TT TrueP (Val True) "xxx" []

-- True

--

ttValBool :: a ~ Bool => Lens' (TT a) (Val Bool)
ttValBool :: Lens' (TT a) (Val Bool)
ttValBool Val Bool -> f (Val Bool)
afb TT a
tt = (\Val Bool
b -> TT a
tt { _ttValP :: ValP
_ttValP = Val Bool -> ValP
forall a. (a ~ Bool) => Val a -> ValP
val2PBool Val Bool
b, _ttVal :: Val Bool
_ttVal = Val Bool
b }) (Val Bool -> TT Bool) -> f (Val Bool) -> f (TT Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Val Bool -> f (Val Bool)
afb (TT a -> Val a
forall a. TT a -> Val a
_ttVal TT a
tt)

-- | lens from 'TT' to 'Val' that also keeps 'ValP' in sync with 'Val'

--

-- >>> (TT FalseP (Val True) "xxx" [] & ttVal %~ id) == TT ValP (Val True) "xxx" []

-- True

--

-- >>> (TT FalseP (Val 123) "xxx" [] & ttVal .~ Fail "aa") == TT (FailP "aa") (Fail "aa") "xxx" []

-- True

--

-- >>> (TT (FailP "sdf") (Val 123) "xxx" [] & ttVal %~ fmap show) == TT ValP (Val "123") "xxx" []

-- True

--

ttVal :: Lens (TT a) (TT b) (Val a) (Val b)
ttVal :: (Val a -> f (Val b)) -> TT a -> f (TT b)
ttVal Val a -> f (Val b)
afb TT a
tt = (\Val b
b -> TT a
tt { _ttValP :: ValP
_ttValP = Val b -> ValP
forall a. Val a -> ValP
val2P Val b
b, _ttVal :: Val b
_ttVal = Val b
b }) (Val b -> TT b) -> f (Val b) -> f (TT b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Val a -> f (Val b)
afb (TT a -> Val a
forall a. TT a -> Val a
_ttVal TT a
tt)