{-# LANGUAGE NumericUnderscores #-}
{-# 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 #-}
module Predicate.Util (
Val(..)
, _Fail
, _Val
, _ValEither
, TT
, ttVal
, ttValBool
, ttString
, ttForest
, PE(..)
, peValP
, peString
, ValP(..)
, _FailP
, _TrueP
, _FalseP
, _ValP
, mkNode
, mkNodeB
, mkNodeCopy
, getValAndPE
, getValLRFromTT
, getValueLR
, Inline (..)
, prefixNumberToTT
, prefixMsg
, splitAndAlign
, verboseList
, fixTTBool
, topMessage
, hasNoTree
, 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
, zeroToLite
, defOpts
, show3
, show3'
, lit3
, litVerbose
, showVerbose
, showL
, litL
, litBL
, litBS
, joinStrings
, prtTreePure
, formatOMsg
, prtTree
, MonadEval(..)
, hh
, chkSize
, chkSize2
, badLength
, getMaxRecursionValue
, lengthGreaterThanOne
) 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 ()
import Data.Kind (Type)
data ValP =
FailP !String
| FalseP
| TrueP
| ValP
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
data PE = PE { PE -> ValP
_peValP :: !ValP
, PE -> String
_peString :: !String
} 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
joinStrings :: String -> String -> String
joinStrings :: String -> ShowS
joinStrings 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
joinStrings String
s String
s1)
instance Semigroup ValP where
FailP String
s <> :: ValP -> ValP -> ValP
<> FailP String
s1 = String -> ValP
FailP (String -> ShowS
joinStrings 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
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
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
joinStrings 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
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
data TT a = TT { TT a -> ValP
_ttValP :: !ValP
, TT a -> Val a
_ttVal :: !(Val a)
, TT a -> String
_ttString :: !String
, TT a -> Forest PE
_ttForest :: !(Forest PE)
} 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
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
joinStrings 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
joinStrings 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 }
mkNodeCopy :: POpts
-> TT a
-> String
-> [Tree PE]
-> TT a
mkNodeCopy :: POpts -> TT a -> String -> Forest PE -> TT a
mkNodeCopy POpts
opts TT a
tt String
msg Forest PE
pes =
POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
forall a. POpts -> (ValP, Val a) -> String -> Forest PE -> TT a
mkNodeImpl POpts
opts (TT a -> ValP
forall a. TT a -> ValP
_ttValP TT a
tt, TT a -> Val a
forall a. TT a -> Val a
_ttVal TT a
tt) String
msg (Forest PE
pes 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])
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)
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 ->
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
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
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
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)
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
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)
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)
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 =
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 -> ShowS
joinStrings String
ts 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)
type family HKD (f :: Type -> Type) (a :: Type) where
HKD Identity a = a
HKD f a = f a
type POpts = HOpts Identity
data HOpts f =
HOpts { HOpts f -> HKD f Int
oWidth :: !(HKD f Int)
, HOpts f -> HKD f Debug
oDebug :: !(HKD f Debug)
, HOpts f -> HKD f Disp
oDisp :: !(HKD f Disp)
, HOpts f -> HKD f (String, PColor)
oColor :: !(HKD f (String, PColor))
, HOpts f -> [String]
oMsg :: ![String]
, HOpts f -> HKD f Int
oRecursion :: !(HKD f Int)
, HOpts f -> HKD f Int
oRecursionLarge :: !(HKD f Int)
, HOpts f -> HKD f Bool
oLarge :: !(HKD f Bool)
, HOpts f -> HKD f (Bool, SColor, SColor)
oOther :: !(HKD f (Bool, SColor, SColor))
, HOpts f -> HKD f Bool
oNoColor :: !(HKD f Bool)
}
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)
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 Int
-> HKD Identity Bool
-> 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 Int
-> HKD f Bool
-> 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)))
(Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (POpts -> HKD Identity Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursionLarge POpts
defOpts) (Last Int -> Maybe Int
coerce (HOpts Last -> HKD Last Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursionLarge 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
oLarge POpts
defOpts) (Last Bool -> Maybe Bool
coerce (HOpts Last -> HKD Last Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oLarge 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)))
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 }
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 }
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 }
setRecursionLarge :: Int -> HOpts Last
setRecursionLarge :: Int -> HOpts Last
setRecursionLarge Int
i = HOpts Last
forall a. Monoid a => a
mempty { oRecursionLarge :: HKD Last Int
oRecursionLarge = Int -> Last Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
i }
setLarge :: Bool -> HOpts Last
setLarge :: Bool -> HOpts Last
setLarge Bool
b = HOpts Last
forall a. Monoid a => a
mempty { oLarge :: HKD Last Bool
oLarge = Bool -> Last Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
b }
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) }
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 }
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 }
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) }
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 }
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 Int
-> HKD Last Bool
-> 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 Int
-> HKD f Bool
-> 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 Int
forall a. Monoid a => a
mempty HKD Last Bool
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 Int
g HKD Last Bool
h HKD Last (Bool, SColor, SColor)
i HKD Last Bool
j <> :: 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 Int
g' HKD Last Bool
h' HKD Last (Bool, SColor, SColor)
i' HKD Last Bool
j'
= HKD Last Int
-> HKD Last Debug
-> HKD Last Disp
-> HKD Last (String, PColor)
-> [String]
-> HKD Last Int
-> HKD Last Int
-> HKD Last Bool
-> 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 Int
-> HKD f Bool
-> 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 Int
HKD Last Int
g Last Int -> Last Int -> Last Int
forall a. Semigroup a => a -> a -> a
<> Last Int
HKD Last Int
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')
(Last (Bool, SColor, SColor)
HKD Last (Bool, SColor, SColor)
i 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)
i')
(Last Bool
HKD Last Bool
j Last Bool -> Last Bool -> Last Bool
forall a. Semigroup a => a -> a -> a
<> Last Bool
HKD Last Bool
j')
data Disp = Ansi
| 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)
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 Int
-> HKD f Bool
-> 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
, oRecursionLarge :: HKD Identity Int
oRecursionLarge = HKD Identity Int
10_000
, oLarge :: HKD Identity Bool
oLarge = Bool
HKD Identity Bool
False
, 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
}
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
$ ShowS -> ValP -> ShowS
forall a b. a -> b -> a
const ShowS
forall a. a -> a
id)
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
data Debug =
DZero
| DLite
| DNormal
| DVerbose
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)
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
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
<> POpts -> ShowS
litL POpts
opts String
fmt) String
as
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 POpts -> ShowS
litL POpts
o 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 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 (Int64
1Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
s))
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
<> let ll :: Int
ll = NonEmpty String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NonEmpty String
xs in (if Int
ll 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 Int
ll 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
lengthGreaterThanOne :: [a] -> Bool
lengthGreaterThanOne :: [a] -> Bool
lengthGreaterThanOne =
\case
a
_:a
_:[a]
_ -> Bool
True
[a]
_ -> Bool
False
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
")")
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
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)
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"
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
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
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
")"
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
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
<>)
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
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
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
data Opt =
OEmpty
| OWidth !Nat
| OMsg !Symbol
| ORecursion !Nat
| ORecursionLarge !Nat
| OLarge !Bool
| OOther
!Bool
!Color
!Color
| !Opt :# !Opt
| OColor
!Symbol
!Color
!Color
!Color
!Color
!Color
!Color
!Color
!Color
| OColorOn
| OColorOff
| OAnsi
| OUnicode
| OZero
| OLite
| ONormal
| OVerbose
| OZ
| OL
| OA
| OAB
| OAN
| OAV
| OANV
| OU
| OUB
| OUN
| OUV
| OUNV
infixr 6 :#
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 KnownNat n => OptC ('ORecursionLarge n) where
getOptC :: HOpts Last
getOptC = Int -> HOpts Last
setRecursionLarge (forall a. (KnownNat n, Num a) => a
forall (n :: Nat) a. (KnownNat n, Num a) => a
nat @n)
instance GetBool b => OptC ('OLarge b) where
getOptC :: HOpts Last
getOptC = Bool -> HOpts Last
setLarge (GetBool b => Bool
forall (a :: Bool). GetBool a => Bool
getBool @b)
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)
type OZ = 'OZ
type OL = 'OL
type OA = 'OA
type OAB = 'OAB
type OAN = 'OAN
type OAV = 'OAV
type OANV = 'OANV
type OU = 'OU
type OUB = 'OUB
type OUN = 'OUN
type OUV = 'OUV
type OUNV = 'OUNV
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)
chkSize :: Foldable t
=> POpts
-> String
-> t a
-> [Tree PE]
-> Either (TT x) (Int,[a])
chkSize :: POpts -> String -> t a -> Forest PE -> Either (TT x) (Int, [a])
chkSize POpts
opts String
msg0 t a
xs Forest PE
hhs =
let mx :: Int
mx = POpts -> Int
getMaxRecursionValue POpts
opts
in case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mx (t a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList t a
xs) of
([a]
zs,[]) -> (Int, [a]) -> Either (TT x) (Int, [a])
forall a b. b -> Either a b
Right ([a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [a]
zs,[a]
zs)
([a]
_,a
_:[a]
_) -> TT x -> Either (TT x) (Int, [a])
forall a b. a -> Either a b
Left (TT x -> Either (TT x) (Int, [a]))
-> TT x -> Either (TT x) (Int, [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
mx) Forest PE
hhs
chkSize2 :: (Foldable t, Foldable u)
=> POpts
-> String
-> t a
-> u b
-> [Tree PE]
-> Either (TT x) ((Int,[a]),(Int,[b]))
chkSize2 :: POpts
-> String
-> t a
-> u b
-> Forest PE
-> Either (TT x) ((Int, [a]), (Int, [b]))
chkSize2 POpts
opts String
msg0 t a
xs u b
ys Forest PE
hhs =
(,) ((Int, [a]) -> (Int, [b]) -> ((Int, [a]), (Int, [b])))
-> Either (TT x) (Int, [a])
-> Either (TT x) ((Int, [b]) -> ((Int, [a]), (Int, [b])))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> POpts -> String -> t a -> Forest PE -> Either (TT x) (Int, [a])
forall (t :: Type -> Type) a x.
Foldable t =>
POpts -> String -> t a -> Forest PE -> Either (TT x) (Int, [a])
chkSize POpts
opts String
msg0 t a
xs Forest PE
hhs Either (TT x) ((Int, [b]) -> ((Int, [a]), (Int, [b])))
-> Either (TT x) (Int, [b])
-> Either (TT x) ((Int, [a]), (Int, [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) (Int, [b])
forall (t :: Type -> Type) a x.
Foldable t =>
POpts -> String -> t a -> Forest PE -> Either (TT x) (Int, [a])
chkSize POpts
opts String
msg0 u b
ys Forest PE
hhs
getMaxRecursionValue :: POpts -> Int
getMaxRecursionValue :: POpts -> Int
getMaxRecursionValue = (POpts -> Bool) -> (POpts -> Int) -> (POpts -> Int) -> POpts -> Int
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM POpts -> Bool
forall (f :: Type -> Type). HOpts f -> HKD f Bool
oLarge POpts -> Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursionLarge POpts -> Int
forall (f :: Type -> Type). HOpts f -> HKD f Int
oRecursion
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
zeroToLite :: POpts -> POpts
zeroToLite :: POpts -> POpts
zeroToLite 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
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
type family OptT (xs :: [Opt]) where
OptT '[] = 'OEmpty
OptT (x ': xs) = x ':# OptT xs
badLength :: Int
-> Int
-> String
badLength :: Int -> Int -> String
badLength Int
asLen Int
n = String
":invalid length(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
asLen 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 = []
_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
val2P :: Val a -> ValP
val2P :: Val a -> ValP
val2P =
\case
Fail String
e -> String -> ValP
FailP String
e
Val {} -> ValP
ValP
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
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)
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)