diff --git a/predicate-typed.cabal b/predicate-typed.cabal --- a/predicate-typed.cabal +++ b/predicate-typed.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ce8bf201dfcc67f4335c139afa9cb860348bc6b07daa4e34ac23aff8db72dad2 +-- hash: 6b4766366591bfcedbf8b3452314ca1261917f6b3261789d01dca0eebe6b6b8d name: predicate-typed -version: 0.7.1.0 +version: 0.7.2.0 synopsis: Predicates, Refinement types and Dsl description: Please see the README on GitHub at category: Data diff --git a/src/Predicate/Core.hs b/src/Predicate/Core.hs --- a/src/Predicate/Core.hs +++ b/src/Predicate/Core.hs @@ -27,16 +27,21 @@ , IdT , W , Msg + , Hide -- ** display evaluation tree , pan + , panv , pa , pu , pab , pub + , pav + , puv , pl , pz , run + , runs , P(..) @@ -44,12 +49,14 @@ , runPQ , runPQBool , evalBool + , evalBoolHide + , evalHide , evalQuick , prtTree ) where import Predicate.Util import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat) -import Control.Lens ((^.)) +import Control.Lens ((&), (^.), (.~)) import Data.Proxy import Data.Typeable import Data.Kind (Type) @@ -63,14 +70,24 @@ -- | This is the core class. Each instance of this class can be combined into a dsl using 'Predicate.Prelude.>>' class P p a where type PP (p :: k) a :: Type -- PP is the output type - eval :: MonadEval m => Proxy p -> POpts -> a -> m (TT (PP p a)) -- ^ returns a tree of results + eval :: MonadEval m + => proxy p -- ^ proxy for the expression + -> POpts -- ^ display options + -> a -- ^ value + -> m (TT (PP p a)) -- ^ returns a tree of results -- | A specialised form of 'eval' that works only on predicates -evalBool :: (MonadEval m, P p a, PP p a ~ Bool) => Proxy p -> POpts -> a -> m (TT (PP p a)) +evalBool :: ( MonadEval m + , P p a + , PP p a ~ Bool + ) => proxy p + -> POpts + -> a + -> m (TT (PP p a)) evalBool p opts a = fixBoolT <$> eval p opts a evalQuick :: forall p i . P p i => i -> Either String (PP p i) -evalQuick i = getValLRFromTT (runIdentity (eval (Proxy @p) (getOptT @'OL) i)) +evalQuick i = getValLRFromTT (runIdentity (eval (Proxy @p) (getOptT @OL) i)) -- | identity function -- @@ -95,7 +112,7 @@ type PP Id a = a eval _ opts a = let msg0 = "Id" - in pure $ mkNode opts (PresentT a) (msg0 <> show0 opts " " a) [] + in pure $ mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] -- even more constraints than 'Id' so we might need to explicitly add types (Typeable) @@ -104,12 +121,14 @@ -- >>> pz @IdT 23 -- PresentT 23 data IdT -instance (Typeable a, Show a) => P IdT a where +instance ( Typeable a + , Show a + ) => P IdT a where type PP IdT a = a eval _ opts a = let msg0 = "IdT(" <> t <> ")" t = showT @a - in pure $ mkNode opts (PresentT a) (msg0 <> show0 opts " " a) [] + in pure $ mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] -- | transparent predicate wrapper to make k of kind 'Type' so it can be in a promoted list (cant mix kinds) see 'Predicate.Core.Do' -- @@ -122,7 +141,7 @@ data W (p :: k) instance P p a => P (W p) a where type PP (W p) a = PP p a - eval _ = eval (Proxy @(Msg "W" p)) + eval _ = eval (Proxy @(Msg "W " p)) -- | add a message to give more context to the evaluation tree -- @@ -147,6 +166,16 @@ Left e -> pure e Right msg -> prefixMsg msg <$> eval (Proxy @p) opts a +-- | run the expression \'p\' but remove the subtrees +data Hide p +-- type H p = Hide p -- doesnt work with % -- unsaturated! + +instance P p x => P (Hide p) x where + type PP (Hide p) x = PP p x + eval _ opts x = do + tt <- eval (Proxy @p) opts x + pure $ tt & tForest .~ [] + -- | 'const' () function -- -- >>> pz @() "Asf" @@ -188,14 +217,18 @@ type PP s a = String eval _ opts _ = let s = symb @s - in pure $ mkNode opts (PresentT s) ("'" <> showLit0 opts "" s) [] + in pure $ mkNode opts (PresentT s) ("'" <> litL opts ("\"" <> s <> "\"")) [] -- | run the predicates in a promoted 2-tuple; similar to 'Control.Arrow.&&&' -- -- >>> pz @'(Id, 4) "hello" -- PresentT ("hello",4) -- -instance (P p a, P q a) => P '(p,q) a where +instance ( P p a + , P q a +-- , Show (PP p a) +-- , Show (PP q a) + ) => P '(p,q) a where type PP '(p,q) a = (PP p a, PP q a) eval _ opts a = do let msg = "'(,)" @@ -204,6 +237,7 @@ Left e -> e Right (p,q,pp,qq) -> mkNode opts (PresentT (p,q)) msg [hh pp, hh qq] +-- mkNode opts (PresentT (p,q)) ("'(" <> showL opts p <> ", " <> showL opts q <> ")") [hh pp, hh qq] -- | run the predicates in a promoted 3-tuple -- @@ -455,14 +489,17 @@ -- >>> pz @'[W 1, W 2, W 3, Id] 999 -- PresentT [1,2,3,999] -- -instance (Show (PP p a), Show a, P p a) => P '[p] a where +instance ( Show (PP p a) + , Show a + , P p a + ) => P '[p] a where type PP '[p] a = [PP p a] eval _ opts a = do pp <- eval (Proxy @p) opts a let msg0 = "" pure $ case getValueLR opts msg0 pp [] of Left e -> e - Right b -> mkNode opts (PresentT [b]) ("'" <> show0 opts "" [b] <> show1 opts " | " a) [hh pp] + Right b -> mkNode opts (PresentT [b]) ("'" <> showL opts [b] <> showVerbose opts " | " a) [hh pp] instance (Show (PP p a) , Show a @@ -474,13 +511,17 @@ type PP (p ': p1 ': ps) a = [PP p a] eval _ opts a = do let msg0 = "'(p':q)" - lr <- runPQ msg0 (Proxy @p) (Proxy @(p1 ': ps)) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let ret = p:q - -- no gap between ' and ret! - in mkNode opts (PresentT ret) ("'" <> show0 opts "" ret <> show1 opts " | " a) [hh pp, hh qq] + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @(p1 ': ps)) opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right q -> + let ret = p:q + -- no gap between ' and ret! + in mkNode opts (PresentT ret) ("'" <> showL opts ret <> litVerbose opts " " (topMessage pp) <> showVerbose opts " | " a) ([hh pp | isVerbose opts] <> [hh qq]) -- | extracts the \'a\' from type level \'Maybe a\' if the value exists -- @@ -506,7 +547,7 @@ pure $ case getValueLR opts msg0 pp [] of Left e -> e Right b -> mkNode opts (PresentT b) (show01 opts msg0 b ma) [hh pp] - Nothing -> pure $ mkNode opts (FailT (msg0 <> " found Nothing")) (msg0 <> " found Nothing") [] + Nothing -> pure $ mkNode opts (FailT (msg0 <> " found Nothing")) "" [] -- | expects Nothing otherwise it fails -- if the value is Nothing then it returns \'Proxy a\' as this provides type information @@ -523,7 +564,7 @@ let msg0 = "'Nothing" in pure $ case ma of Nothing -> mkNode opts (PresentT Proxy) msg0 [] - Just _ -> mkNode opts (FailT (msg0 <> " found Just")) (msg0 <> " found Just") [] + Just _ -> mkNode opts (FailT (msg0 <> " found Just")) "" [] -- omitted Show x so we can have less ambiguity -- | extracts the \'a\' from type level \'Either a b\' if the value exists @@ -542,7 +583,7 @@ eval _ opts lr = let msg0 = "'Left" in case lr of - Right _ -> pure $ mkNode opts (FailT (msg0 <> " found Right")) (msg0 <> " found Right") [] + Right _ -> pure $ mkNode opts (FailT (msg0 <> " found Right")) "" [] Left a -> do pp <- eval (Proxy @p) opts a pure $ case getValueLR opts msg0 pp [] of @@ -565,7 +606,7 @@ eval _ opts lr = do let msg0 = "'Right" case lr of - Left _ -> pure $ mkNode opts (FailT (msg0 <> " found Left")) (msg0 <> " found Left") [] + Left _ -> pure $ mkNode opts (FailT (msg0 <> " found Left")) "" [] Right a -> do pp <- eval (Proxy @p) opts a pure $ case getValueLR opts msg0 pp [] of @@ -598,7 +639,7 @@ pure $ case getValueLR opts msg0 pp [] of Left e -> e Right b -> mkNode opts (_tBool pp) (show01' opts msg0 b "This " a) [hh pp] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) (msg0 <> " found " <> showThese th) [] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) "" [] -- | extracts the \'b\' from type level \'These a b\' if the value exists -- @@ -624,7 +665,7 @@ pure $ case getValueLR opts msg0 pp [] of Left e -> e Right b -> mkNode opts (_tBool pp) (show01' opts msg0 b "That " a) [hh pp] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) (msg0 <> " found " <> showThese th) [] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) "" [] -- | extracts the (a,b) from type level 'These a b' if the value exists @@ -658,12 +699,12 @@ Left e -> pure e Right p -> do qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg0 <> " q failed p=" <> show p) qq [hh pp] of + pure $ case getValueLR opts (msg0 <> " q failed p=" <> showL opts p) qq [hh pp] of Left e -> e Right q -> let ret =(p,q) in mkNode opts (PresentT ret) (show01 opts msg0 ret (These a b)) [hh pp, hh qq] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) (msg0 <> " found " <> showThese th) [] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) "" [] -- | converts the value to the corresponding 'Proxy' -- @@ -674,7 +715,7 @@ type PP 'Proxy a = Proxy a eval _ opts a = let b = Proxy @a - in pure $ mkNode opts (PresentT b) ("'Proxy" <> show1 opts " | " a) [] + in pure $ mkNode opts (PresentT b) ("'Proxy" <> showVerbose opts " | " a) [] -- | typelevel 'BoolT' -- @@ -693,37 +734,55 @@ instance GetBoolT x b => P (b :: BoolT x) a where type PP b a = Bool eval _ opts _ = do - let msg0 = "'BoolT" let ret = getBoolT @x @b pure $ case ret of - Left b -> mkNodeB opts b (if b then "TrueT" else "FalseT") [] - Right True -> mkNode opts (PresentT False) (msg0 <> " PresentT") [] - Right False -> mkNode opts (FailT "'FailT _") (msg0 <> " FailT") [] + Left b -> mkNodeB opts b (if b then "'TrueT" else "'FalseT") [] + Right True -> mkNode opts (PresentT False) "'PresentT _" [] + Right False -> mkNode opts (FailT "'FailT _") "BoolT" [] -pan, pa, pu, pl, pz, pab, pub :: forall p a . (Show (PP p a), P p a) => a -> IO (BoolT (PP p a)) +pan, panv, pa, pu, pl, pz, pab, pub, pav, puv + :: forall p a + . ( Show (PP p a) + , P p a + ) => a + -> IO (BoolT (PP p a)) -- | skips the evaluation tree and just displays the end result -pz = run @'OZ @p +pz = run @OZ @p -- | same as 'pz' but adds context to the end result -pl = run @'OL @p +pl = run @OL @p -- | displays the evaluation tree in plain text without colors -pan = run @'OAN @p +pan = run @OAN @p +-- | displays the evaluation tree in plain text without colors and verbose +panv = run @OANV @p -- | displays the evaluation tree using colors without background colors -pa = run @'OA @p +pa = run @OA @p -- | displays the evaluation tree using background colors -pab = run @'OAB @p +pab = run @OAB @p +-- | 'pa' and verbose +pav = run @OAV @p -- | display the evaluation tree using unicode and colors -- @ -- pu @'(Id, "abc", 123) [1..4] -- @ -pu = run @'OU @p +pu = run @OU @p -- | displays the evaluation tree using unicode and colors with background colors -pub = run @'OUB @p +pub = run @OUB @p +-- | 'pu' and verbose +puv = run @OUV @p -- | evaluate a typelevel expression (use type applications to pass in the options and the expression) -- --- >>> run @'OZ @Id 123 +-- >>> run @OZ @Id 123 -- PresentT 123 -- +-- >>> run @('OMsg "field1" ':# OL) @('Left Id) (Right 123) +-- field1 >>> Error 'Left found Right +-- FailT "'Left found Right" +-- +-- >>> run @(OptTT '[ 'OMsg "test", OU, 'OEmpty, OL, 'OMsg "field2"]) @('FailT '[]) () +-- test | field2 >>> Error 'FailT _ (BoolT) +-- FailT "'FailT _" +-- run :: forall opts p a . ( OptTC opts , Show (PP p a) @@ -737,6 +796,25 @@ putStr $ prtTree opts pp return r +-- | run expression with multiple options in a list +-- +-- >>> runs @'[ OL, 'OMsg "field2"] @'( 'True, 'False) () +-- field2 >>> Present (True,False) ('(,)) +-- PresentT (True,False) +-- +-- >>> runs @'[ 'OMsg "test", OU, 'OEmpty, OL, 'OMsg "field2"] @('FailT '[]) () +-- test | field2 >>> Error 'FailT _ (BoolT) +-- FailT "'FailT _" +-- +runs :: forall optss p a + . ( OptTC (OptTT optss) + , Show (PP p a) + , P p a) + => a + -> IO (BoolT (PP p a)) +runs = run @(OptTT optss) @p + + prtTree :: Show x => POpts -> TT x -> String prtTree opts pp = let r = pp ^. tBool @@ -751,10 +829,12 @@ _ -> formatOMsg opts "\n" <> prtTreePure opts (fromTT pp) -runPQ :: (P p a, P q a, MonadEval m) +runPQ :: ( P p a + , P q a + , MonadEval m) => String - -> Proxy p - -> Proxy q + -> proxy1 p + -> proxy2 q -> POpts -> a -> [Holder] @@ -769,10 +849,13 @@ Left e -> Left e Right q -> Right (p, q, pp, qq) -runPQBool :: (P p a, PP p a ~ Bool, P q a, PP q a ~ Bool, MonadEval m) +runPQBool :: ( P p a + , PP p a ~ Bool + , P q a + , PP q a ~ Bool, MonadEval m) => String - -> Proxy p - -> Proxy q + -> proxy1 p + -> proxy2 q -> POpts -> a -> [Holder] @@ -786,3 +869,23 @@ pure $ case getValueLR opts msg0 qq (hhs <> [hh pp]) of Left e -> Left e Right q -> Right (p, q, pp, qq) + +evalBoolHide :: forall m p a proxy + . (MonadEval m, P p a, PP p a ~ Bool) + => proxy p + -> POpts + -> a + -> m (TT (PP p a)) +evalBoolHide _ opts = + if isVerbose opts then evalBool (Proxy @p) opts + else evalBool (Proxy @(Hide p)) opts + +evalHide :: forall m p a proxy + . (MonadEval m, P p a) + => proxy p + -> POpts + -> a + -> m (TT (PP p a)) +evalHide _ opts = + if isVerbose opts then eval (Proxy @p) opts + else eval (Proxy @(Hide p)) opts diff --git a/src/Predicate/Examples/Refined1.hs b/src/Predicate/Examples/Refined1.hs --- a/src/Predicate/Examples/Refined1.hs +++ b/src/Predicate/Examples/Refined1.hs @@ -44,12 +44,12 @@ -- | tests -- -- >>> :m + Data.Ratio --- >>> newRefined1P (readshow @'OZ @Rational) "13 % 3" +-- >>> newRefined1P (readshow @OZ @Rational) "13 % 3" -- Right (Refined1 (13 % 3)) -- --- >>> newRefined1P (readshow @'OZ @Rational) "13x % 3" +-- >>> newRefined1P (readshow @OZ @Rational) "13x % 3" -- Left "Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3)" -- --- >>> newRefined1P (Proxy @(ReadShow' 'OZ Rational (11 -% 2 <..> 3 -% 1))) "-13 % 3" +-- >>> newRefined1P (Proxy @(ReadShow' OZ Rational (11 -% 2 <..> 3 -% 1))) "-13 % 3" -- Right (Refined1 ((-13) % 3)) -- diff --git a/src/Predicate/Examples/Refined2.hs b/src/Predicate/Examples/Refined2.hs --- a/src/Predicate/Examples/Refined2.hs +++ b/src/Predicate/Examples/Refined2.hs @@ -90,10 +90,10 @@ -- | credit card with luhn algorithm -- --- >>> newRefined2 @'OZ @Ccip @(Ccop 11) "1234-5678-901" +-- >>> newRefined2 @OZ @Ccip @(Ccop 11) "1234-5678-901" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined2 @'OZ @Ccip @(Ccop 11) "1234-5678-903" +-- >>> newRefined2 @OZ @Ccip @(Ccop 11) "1234-5678-903" -- Right (Refined2 {r2In = [1,2,3,4,5,6,7,8,9,0,3], r2Out = "1234-5678-903"}) -- -- >>> pz @(Ccip >> Ccop 11) "79927398713" @@ -106,10 +106,10 @@ -- | read in a valid datetime -- --- >>> newRefined2 @'OL @(Dtip LocalTime) @'True "2018-09-14 02:57:04" +-- >>> newRefined2 @OL @(Dtip LocalTime) @'True "2018-09-14 02:57:04" -- Right (Refined2 {r2In = 2018-09-14 02:57:04, r2Out = "2018-09-14 02:57:04"}) -- --- >>> newRefined2 @'OL @(Dtip LocalTime) @'True "2018-09-99 12:12:12" +-- >>> newRefined2 @OL @(Dtip LocalTime) @'True "2018-09-99 12:12:12" -- Left "Step 1. Initial Conversion(ip) Failed | ParseTimeP LocalTime (%F %T) failed to parse" -- datetime1 :: Proxy (DateTime1 opts t) @@ -131,13 +131,13 @@ -- | read in an ssn -- --- >>> newRefined2 @'OZ @Ssnip @Ssnop "134-01-2211" +-- >>> newRefined2 @OZ @Ssnip @Ssnop "134-01-2211" -- Right (Refined2 {r2In = [134,1,2211], r2Out = "134-01-2211"}) -- --- >>> newRefined2 @'OL @Ssnip @Ssnop "666-01-2211" +-- >>> newRefined2 @OL @Ssnip @Ssnop "666-01-2211" -- Left "Step 2. False Boolean Check(op) | {Bool(0) [number for group 0 invalid: found 666] (True && False | (666 /= 666))}" -- --- >>> newRefined2 @'OL @Ssnip @Ssnop "667-00-2211" +-- >>> newRefined2 @OL @Ssnip @Ssnop "667-00-2211" -- Left "Step 2. False Boolean Check(op) | {Bool(1) [number for group 1 invalid: found 0] (1 <= 0)}" -- @@ -150,13 +150,13 @@ -- | read in a time and validate it -- --- >>> newRefined2 @'OL @Hmsip @Hmsop' "23:13:59" +-- >>> newRefined2 @OL @Hmsip @Hmsop' "23:13:59" -- Right (Refined2 {r2In = [23,13,59], r2Out = "23:13:59"}) -- --- >>> newRefined2 @'OL @Hmsip @Hmsop' "23:13:60" +-- >>> newRefined2 @OL @Hmsip @Hmsop' "23:13:60" -- Left "Step 2. False Boolean Check(op) | {Bool(2) [seconds] (60 <= 59)}" -- --- >>> newRefined2 @'OL @Hmsip @Hmsop' "26:13:59" +-- >>> newRefined2 @OL @Hmsip @Hmsop' "26:13:59" -- Left "Step 2. False Boolean Check(op) | {Bool(0) [hours] (26 <= 23)}" -- hms :: OptTC opts => Proxy (Hms opts) @@ -165,7 +165,7 @@ type HmsR (opts :: OptT) = MakeR2 (Hms opts) type Hms (opts :: OptT) = '(opts, Hmsip, Hmsop >> 'True, String) ---hms' :: Proxy (Hms' 'OZ) +--hms' :: Proxy (Hms' OZ) --hms' = mkProxy2' type HmsR' (opts :: OptT) = MakeR2 (Hms' opts) @@ -173,19 +173,19 @@ -- | read in an ipv4 address and validate it -- --- >>> newRefined2 @'OZ @Ip4ip @Ip4op' "001.223.14.1" +-- >>> newRefined2 @OZ @Ip4ip @Ip4op' "001.223.14.1" -- Right (Refined2 {r2In = [1,223,14,1], r2Out = "001.223.14.1"}) -- --- >>> newRefined2 @'OL @Ip4ip @Ip4op' "001.223.14.999" +-- >>> newRefined2 @OL @Ip4ip @Ip4op' "001.223.14.999" -- Left "Step 2. False Boolean Check(op) | {Bool(3) [octet 3 out of range 0-255 found 999] (999 <= 255)}" -- --- >>> newRefined2P (ip4 @'OL) "001.223.14.999" +-- >>> newRefined2P (ip4 @OL) "001.223.14.999" -- Left "Step 2. Failed Boolean Check(op) | octet 3 out of range 0-255 found 999" -- --- >>> newRefined2P (ip4 @'OL) "001.223.14.999.1" +-- >>> newRefined2P (ip4 @OL) "001.223.14.999.1" -- Left "Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4" -- --- >>> newRefined2P (ip4 @'OL) "001.257.14.1" +-- >>> newRefined2P (ip4 @OL) "001.257.14.1" -- Left "Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257" -- type Ip4R (opts :: OptT) = MakeR2 (Ip4 opts) @@ -212,16 +212,16 @@ -- | convert a string from a given base \'i\' and store it internally as an base 10 integer -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @'True "00fe" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @'True "00fe" -- Right (Refined2 {r2In = 254, r2Out = "00fe"}) -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @(Between 100 400 Id) "00fe" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(Between 100 400 Id) "00fe" -- Right (Refined2 {r2In = 254, r2Out = "00fe"}) -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @(GuardSimple (Id < 400) >> 'True) "f0fe" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(GuardSimple (Id < 400) >> 'True) "f0fe" -- Left "Step 2. Failed Boolean Check(op) | (61694 < 400)" -- --- >>> newRefined2 @'OL @(ReadBase Int 16 Id) @(Id < 400) "f0fe" -- todo: why different parens vs braces +-- >>> newRefined2 @OL @(ReadBase Int 16 Id) @(Id < 400) "f0fe" -- todo: why different parens vs braces -- Left "Step 2. False Boolean Check(op) | {61694 < 400}" -- type BaseN (opts :: OptT) (n :: Nat) = BaseN' opts n 'True @@ -230,23 +230,23 @@ -- | Luhn check -- --- >>> newRefined2 @'OZ @Luhnip @(Luhnop 4) "1230" +-- >>> newRefined2 @OZ @Luhnip @(Luhnop 4) "1230" -- Right (Refined2 {r2In = [1,2,3,0], r2Out = "1230"}) -- --- >>> newRefined2 @'OL @Luhnip @(Luhnop 4) "1234" +-- >>> newRefined2 @OL @Luhnip @(Luhnop 4) "1234" -- Left "Step 2. False Boolean Check(op) | {True && False | (Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4])}" -- -- | uses builtin 'Luhn' -- | convert a string from a given base \'i\' and store it internally as a base \'j\' string -- --- >>> newRefined2 @'OZ @(BaseIJip 16 2) @'True "fe" +-- >>> newRefined2 @OZ @(BaseIJip 16 2) @'True "fe" -- Right (Refined2 {r2In = "11111110", r2Out = "fe"}) -- --- >>> newRefined2 @'OZ @(BaseIJip 16 2) @'True "fge" +-- >>> newRefined2 @OZ @(BaseIJip 16 2) @'True "fge" -- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" -- --- >>> newRefined2 @'OL @(BaseIJip 16 2) @(ReadBase Int 2 Id < 1000) "ffe" +-- >>> newRefined2 @OL @(BaseIJip 16 2) @(ReadBase Int 2 Id < 1000) "ffe" -- Left "Step 2. False Boolean Check(op) | {4094 < 1000}" -- type BaseIJip (i :: Nat) (j :: Nat) = ReadBase Int i Id >> ShowBase j Id @@ -257,34 +257,34 @@ -- | take any valid Read/Show instance and turn it into a valid 'Predicate.Refined2.Refined2' -- -- >>> :m + Data.Ratio --- >>> newRefined2 @'OZ @(ReadP Rational Id) @'True "13 % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "13 % 3" -- Right (Refined2 {r2In = 13 % 3, r2Out = "13 % 3"}) -- --- >>> newRefined2 @'OZ @(ReadP Rational Id) @'True "13x % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "13x % 3" -- Left "Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3)" -- --- >>> newRefined2 @'OZ @(ReadP Rational Id) @(3 % 1 <..> 5 % 1) "13 % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @(3 % 1 <..> 5 % 1) "13 % 3" -- Right (Refined2 {r2In = 13 % 3, r2Out = "13 % 3"}) -- --- >>> newRefined2 @'OZ @(ReadP Rational Id) @(11 -% 2 <..> 3 -% 1) "-13 % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @(11 -% 2 <..> 3 -% 1) "-13 % 3" -- Right (Refined2 {r2In = (-13) % 3, r2Out = "-13 % 3"}) -- --- >>> newRefined2 @'OZ @(ReadP Rational Id) @(Id > (15 % 1)) "13 % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @(Id > (15 % 1)) "13 % 3" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined2 @'OL @(ReadP Rational Id) @(Msg (PrintF "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1))) "13 % 3" +-- >>> newRefined2 @OL @(ReadP Rational Id) @(Msg (PrintF "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1))) "13 % 3" -- Left "Step 2. False Boolean Check(op) | {invalid=4.3313 % 3 > 15 % 1}" -- --- >>> newRefined2 @'OZ @(ReadP Rational Id) @(Id > (11 % 1)) "13 % 3" +-- >>> newRefined2 @OZ @(ReadP Rational Id) @(Id > (11 % 1)) "13 % 3" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined2 @'OZ @(ReadP UTCTime Id) @'True "2018-10-19 14:53:11.5121359 UTC" +-- >>> newRefined2 @OZ @(ReadP UTCTime Id) @'True "2018-10-19 14:53:11.5121359 UTC" -- Right (Refined2 {r2In = 2018-10-19 14:53:11.5121359 UTC, r2Out = "2018-10-19 14:53:11.5121359 UTC"}) -- -- >>> :m + Data.Aeson --- >>> newRefined2 @'OZ @(ReadP Value Id) @'True "String \"jsonstring\"" +-- >>> newRefined2 @OZ @(ReadP Value Id) @'True "String \"jsonstring\"" -- Right (Refined2 {r2In = String "jsonstring", r2Out = "String \"jsonstring\""}) -- --- >>> newRefined2 @'OZ @(ReadP Value Id) @'True "Number 123.4" +-- >>> newRefined2 @OZ @(ReadP Value Id) @'True "Number 123.4" -- Right (Refined2 {r2In = Number 123.4, r2Out = "Number 123.4"}) -- diff --git a/src/Predicate/Examples/Refined3.hs b/src/Predicate/Examples/Refined3.hs --- a/src/Predicate/Examples/Refined3.hs +++ b/src/Predicate/Examples/Refined3.hs @@ -123,10 +123,10 @@ -- | credit card with luhn algorithm -- --- >>> newRefined3P (cc11 @'OZ) "1234-5678-901" +-- >>> newRefined3P (cc11 @OZ) "1234-5678-901" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined3P (cc11 @'OZ) "1234-5678-903" +-- >>> newRefined3P (cc11 @OZ) "1234-5678-903" -- Right (Refined3 {r3In = [1,2,3,4,5,6,7,8,9,0,3], r3Out = "1234-5678-903"}) -- -- >>> pz @(Ccip >> Ccop 11) "79927398713" @@ -156,10 +156,10 @@ -- | read in a valid datetime -- --- >>> newRefined3P (datetime1 @'OL @LocalTime) "2018-09-14 02:57:04" +-- >>> newRefined3P (datetime1 @OL @LocalTime) "2018-09-14 02:57:04" -- Right (Refined3 {r3In = 2018-09-14 02:57:04, r3Out = "2018-09-14 02:57:04"}) -- --- >>> newRefined3P (datetime1 @'OL @LocalTime) "2018-09-99 12:12:12" +-- >>> newRefined3P (datetime1 @OL @LocalTime) "2018-09-99 12:12:12" -- Left "Step 1. Initial Conversion(ip) Failed | ParseTimeP LocalTime (%F %T) failed to parse" -- datetime1 :: Proxy (DateTime1 opts t) @@ -185,26 +185,26 @@ -- | read in an ssn -- --- >>> newRefined3P (ssn @'OZ) "134-01-2211" +-- >>> newRefined3P (ssn @OZ) "134-01-2211" -- Right (Refined3 {r3In = [134,1,2211], r3Out = "134-01-2211"}) -- --- >>> newRefined3P (ssn @'OL) "666-01-2211" +-- >>> newRefined3P (ssn @OL) "666-01-2211" -- Left "Step 2. False Boolean Check(op) | {Bool(0) [number for group 0 invalid: found 666] (True && False | (666 /= 666))}" -- --- >>> newRefined3P (ssn @'OL) "667-00-2211" +-- >>> newRefined3P (ssn @OL) "667-00-2211" -- Left "Step 2. False Boolean Check(op) | {Bool(1) [number for group 1 invalid: found 0] (1 <= 0)}" -- type Ssn (opts :: OptT) = '(opts, Ssnip, Ssnop, Ssnfmt, String) type SsnR (opts :: OptT) = MakeR3 (Ssn opts) -- | read in a time and validate it -- --- >>> newRefined3P (hms @'OL) "23:13:59" +-- >>> newRefined3P (hms @OL) "23:13:59" -- Right (Refined3 {r3In = [23,13,59], r3Out = "23:13:59"}) -- --- >>> newRefined3P (hms @'OL) "23:13:60" +-- >>> newRefined3P (hms @OL) "23:13:60" -- Left "Step 2. Failed Boolean Check(op) | seconds invalid: found 60" -- --- >>> newRefined3P (hms @'OL) "26:13:59" +-- >>> newRefined3P (hms @OL) "26:13:59" -- Left "Step 2. Failed Boolean Check(op) | hours invalid: found 26" -- hms :: OptTC opts => Proxy (Hms opts) @@ -219,16 +219,16 @@ -- | read in an ipv4 address and validate it -- --- >>> newRefined3P (ip4 @'OZ) "001.223.14.1" +-- >>> newRefined3P (ip4 @OZ) "001.223.14.1" -- Right (Refined3 {r3In = [1,223,14,1], r3Out = "001.223.014.001"}) -- --- >>> newRefined3P (ip4 @'OL) "001.223.14.999" +-- >>> newRefined3P (ip4 @OL) "001.223.14.999" -- Left "Step 2. Failed Boolean Check(op) | octet 3 out of range 0-255 found 999" -- --- >>> newRefined3P (ip4 @'OZ) "001.223.14.999.1" +-- >>> newRefined3P (ip4 @OZ) "001.223.14.999.1" -- Left "Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4" -- --- >>> newRefined3P (ip4 @'OL) "001.257.14.1" +-- >>> newRefined3P (ip4 @OL) "001.257.14.1" -- Left "Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257" -- type Ip4R (opts :: OptT) = MakeR3 (Ip4 opts) @@ -251,16 +251,16 @@ -- | convert a string from a given base \'i\' and store it internally as an base 10 integer -- --- >>> newRefined3P (base16 @'OZ) "00fe" +-- >>> newRefined3P (base16 @OZ) "00fe" -- Right (Refined3 {r3In = 254, r3Out = "fe"}) -- --- >>> newRefined3P (basen' @'OZ @16 @(100 <..> 400)) "00fe" +-- >>> newRefined3P (basen' @OZ @16 @(100 <..> 400)) "00fe" -- Right (Refined3 {r3In = 254, r3Out = "fe"}) -- --- >>> newRefined3P (basen' @'OZ @16 @(GuardSimple (Id < 400) >> 'True)) "f0fe" +-- >>> newRefined3P (basen' @OZ @16 @(GuardSimple (Id < 400) >> 'True)) "f0fe" -- Left "Step 2. Failed Boolean Check(op) | (61694 < 400)" -- --- >>> newRefined3P (basen' @'OL @16 @(Id < 400)) "f0fe" -- todo: why different parens vs braces +-- >>> newRefined3P (basen' @OL @16 @(Id < 400)) "f0fe" -- todo: why different parens vs braces -- Left "Step 2. False Boolean Check(op) | {61694 < 400}" -- type BaseN (opts :: OptT) (n :: Nat) = BaseN' opts n 'True @@ -292,16 +292,16 @@ -- | ensures that two numbers are in a given range (emulates 'Refined.Refined') -- --- >>> newRefined3P (between @'OZ @10 @16) 14 +-- >>> newRefined3P (between @OZ @10 @16) 14 -- Right (Refined3 {r3In = 14, r3Out = 14}) -- --- >>> newRefined3P (between @'OZ @10 @16) 17 +-- >>> newRefined3P (between @OZ @10 @16) 17 -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> prtEval3P (between @'OAN @10 @16) 17 +-- >>> prtEval3P (between @OAN @10 @16) 17 -- Left Step 2. False Boolean Check(op) | {17 <= 16} -- --- *** Step 1. Success Initial Conversion(ip) [17] *** +-- *** Step 1. Success Initial Conversion(ip) (17) *** -- -- P Id 17 -- @@ -326,10 +326,10 @@ -- | Luhn check -- --- >>> newRefined3P (Proxy @(LuhnT 'OZ 4)) "1230" +-- >>> newRefined3P (Proxy @(LuhnT OZ 4)) "1230" -- Right (Refined3 {r3In = [1,2,3,0], r3Out = "1230"}) -- --- >>> newRefined3P (Proxy @(LuhnT 'OL 4)) "1234" +-- >>> newRefined3P (Proxy @(LuhnT OL 4)) "1234" -- Left "Step 2. False Boolean Check(op) | {True && False | (Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4])}" -- -- | uses builtin 'Luhn' @@ -349,7 +349,7 @@ ok = mkProxy3 -- | noop false -type OkNot (t :: Type) = '( 'OA, Id, 'False, Id, t) +type OkNot (t :: Type) = '( OA, Id, 'False, Id, t) type OkNotR (t :: Type) = MakeR3 (OkNot t) oknot :: Proxy (OkNot t) @@ -357,13 +357,13 @@ -- | convert a string from a given base \'i\' and store it internally as a base \'j\' string -- --- >>> newRefined3P (Proxy @(BaseIJ 'OZ 16 2)) "fe" +-- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fe" -- Right (Refined3 {r3In = "11111110", r3Out = "fe"}) -- --- >>> newRefined3P (Proxy @(BaseIJ 'OZ 16 2)) "fge" +-- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fge" -- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" -- --- >>> newRefined3P (Proxy @(BaseIJ' 'OL 16 2 (ReadBase Int 2 Id < 1000))) "ffe" +-- >>> newRefined3P (Proxy @(BaseIJ' OL 16 2 (ReadBase Int 2 Id < 1000))) "ffe" -- Left "Step 2. False Boolean Check(op) | {4094 < 1000}" -- type BaseIJ (opts :: OptT) (i :: Nat) (j :: Nat) = BaseIJ' opts i j 'True @@ -372,35 +372,35 @@ -- | take any valid Read/Show instance and turn it into a valid 'Refined3' -- -- >>> :m + Data.Ratio --- >>> newRefined3P (readshow @'OZ @Rational) "13 % 3" +-- >>> newRefined3P (readshow @OZ @Rational) "13 % 3" -- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) -- --- >>> newRefined3P (readshow @'OZ @Rational) "13x % 3" +-- >>> newRefined3P (readshow @OZ @Rational) "13x % 3" -- Left "Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3)" -- --- >>> newRefined3P (readshow' @'OZ @Rational @(3 % 1 <..> 5 % 1)) "13 % 3" +-- >>> newRefined3P (readshow' @OZ @Rational @(3 % 1 <..> 5 % 1)) "13 % 3" -- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) -- --- >>> newRefined3P (Proxy @(ReadShow' 'OZ Rational (11 -% 2 <..> 3 -% 1))) "-13 % 3" +-- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (11 -% 2 <..> 3 -% 1))) "-13 % 3" -- Right (Refined3 {r3In = (-13) % 3, r3Out = "(-13) % 3"}) -- --- >>> newRefined3P (Proxy @(ReadShow' 'OZ Rational (Id > (15 % 1)))) "13 % 3" +-- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (Id > (15 % 1)))) "13 % 3" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined3P (Proxy @(ReadShow' 'OL Rational (Msg (PrintF "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1))))) "13 % 3" +-- >>> newRefined3P (Proxy @(ReadShow' OL Rational (Msg (PrintF "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1))))) "13 % 3" -- Left "Step 2. False Boolean Check(op) | {invalid=4.3313 % 3 > 15 % 1}" -- --- >>> newRefined3P (Proxy @(ReadShow' 'OZ Rational (Id > (11 % 1)))) "13 % 3" +-- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (Id > (11 % 1)))) "13 % 3" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined3P (readshow @'OZ @UTCTime) "2018-10-19 14:53:11.5121359 UTC" +-- >>> newRefined3P (readshow @OZ @UTCTime) "2018-10-19 14:53:11.5121359 UTC" -- Right (Refined3 {r3In = 2018-10-19 14:53:11.5121359 UTC, r3Out = "2018-10-19 14:53:11.5121359 UTC"}) -- -- >>> :m + Data.Aeson --- >>> newRefined3P (readshow @'OZ @Value) "String \"jsonstring\"" +-- >>> newRefined3P (readshow @OZ @Value) "String \"jsonstring\"" -- Right (Refined3 {r3In = String "jsonstring", r3Out = "String \"jsonstring\""}) -- --- >>> newRefined3P (readshow @'OZ @Value) "Number 123.4" +-- >>> newRefined3P (readshow @OZ @Value) "Number 123.4" -- Right (Refined3 {r3In = Number 123.4, r3Out = "Number 123.4"}) -- type ReadShow (opts :: OptT) (t :: Type) = '( opts, ReadP t Id, 'True, ShowP Id, String) @@ -417,22 +417,22 @@ -- | test tuple type families -- --- >>> pl @(T5_2 (Ip4 'OL)) "1.2.3.4" +-- >>> pl @(T5_2 (Ip4 OL)) "1.2.3.4" -- Present [1,2,3,4] (Map [1,2,3,4] | ["1","2","3","4"]) -- PresentT [1,2,3,4] -- -- --- >>> pl @(T5_3 (Ip4 'OL)) [141,213,308,4] +-- >>> pl @(T5_3 (Ip4 OL)) [141,213,308,4] -- Error octet 2 out of range 0-255 found 308 ((>>) lhs failed) -- FailT "octet 2 out of range 0-255 found 308" -- -- --- >>> pl @(T5_3 (Ip4 'OL)) [141,213,308,4,8] +-- >>> pl @(T5_3 (Ip4 OL)) [141,213,308,4,8] -- Error Guards:invalid length(5) expected 4 ((>>) lhs failed) -- FailT "Guards:invalid length(5) expected 4" -- -- --- >>> pl @(T5_4 (Ip4 'OL)) [141,513,9,4] +-- >>> pl @(T5_4 (Ip4 OL)) [141,513,9,4] -- Present "141.513.009.004" (PrintL(4) [141.513.009.004] | s=%03d.%03d.%03d.%03d) -- PresentT "141.513.009.004" -- diff --git a/src/Predicate/Prelude.hs b/src/Predicate/Prelude.hs --- a/src/Predicate/Prelude.hs +++ b/src/Predicate/Prelude.hs @@ -29,10811 +29,11074 @@ Contains instances of the class 'P' for evaluating expressions at the type level. -} module Predicate.Prelude ( - -- ** boolean expressions - type (&&) - , type (&&~) - , type (||) - , type (||~) - , type (~>) - , Not - , Ands - , Ors - , Asc - , Asc' - , Desc - , Desc' - , Between - , BetweenA - , type (<..>) - , All - , Any - , AllPositive - , Positive - , AllNegative - , Negative - , AndA - , type (&*) - , OrA - , type (|+) - , IdBool - -- ** regex expressions - , Re - , Re' - , Rescan - , Rescan' - , RescanRanges - , RescanRanges' - , Resplit - , Resplit' - , ReplaceAll - , ReplaceAll' - , ReplaceOne - , ReplaceOne' - , ReplaceAllString - , ReplaceAllString' - , ReplaceOneString - , ReplaceOneString' - , ReplaceFn - , ReplaceFn1 - , ReplaceFn2 - , ReplaceFn3 - - -- ** tuple expressions - , Fst - , Snd - , Thd - , L1 - , L2 - , L3 - , L4 - , L5 - , L6 - , Dup - , Swap - , SwapC(..) - , Assoc - , Unassoc - , Pairs - - -- ** character expressions - , IsLower - , IsUpper - , IsDigit - , IsSpace - , IsPunctuation - , IsControl - , IsHexDigit - , IsOctDigit - , IsSeparator - , IsLatin1 - - , IsLowerAll - , IsUpperAll - , IsDigitAll - , IsSpaceAll - , IsPunctuationAll - , IsControlAll - , IsHexDigitAll - , IsOctDigitAll - , IsSeparatorAll - , IsLatin1All - - -- ** datetime expressions - , FormatTimeP - , ParseTimeP - , ParseTimeP' - , ParseTimes - , ParseTimes' - , MkDay - , MkDay' - , UnMkDay - , MkDayExtra - , MkDayExtra' - , ToWeekDate - , ToWeekYear - , ToDay - , ToTime - , MkTime - , MkTime' - , UnMkTime - , PosixToUTCTime - , UTCTimeToPosix - - -- ** numeric expressions - , type (+) - , type (-) - , type (*) - , type (/) - , Negate - , Abs - , Signum - , FromInteger - , FromInteger' - , FromIntegral - , FromIntegral' - , Truncate - , Truncate' - , Ceiling - , Ceiling' - , Floor - , Floor' - , Even - , Odd - , Div - , Mod - , DivMod - , QuotRem - , Quot - , Rem - , LogBase - , type (^) - , type (**) - - -- *** rational numbers - , type (%) - , type (-%) - , ToRational - , FromRational - , FromRational' - - -- ** proxy expressions - , MkProxy - , ProxyT - , ProxyT' - , Unproxy - - -- ** read / show expressions - , ShowP - , ReadP - , ReadP' - , ReadQ - , ReadQ' - , ReadMaybe - , ReadMaybe' - , ReadBase - , ReadBase' - , ShowBase - - -- ** aeson expressions - , ParseJson' - , ParseJson - , EncodeJson - , EncodeJsonFile - , ParseJsonFile' - , ParseJsonFile - - -- ** arrow expressions - , type (&&&) - , type (***) - , First - , Second - , type (|||) - , type (+++) - - -- ** compare expressions - , type (>) - , type (>=) - , type (==) - , type (/=) - , type (<=) - , type (<) - , type (>~) - , type (>=~) - , type (==~) - , type (/=~) - , type (<=~) - , type (<~) - , Gt - , Ge - , Same - , Le - , Lt - , Ne - , type (==!) - , OrdP - , OrdA' - , OrdA - , OrdI - , type (===~) - , Cmp - , CmpI - - -- ** enum expressions - , Succ - , Pred - , FromEnum - , ToEnum - , ToEnum' - , EnumFromTo - , EnumFromThenTo - -- *** bounded enum expressions - , SuccB - , SuccB' - , PredB - , PredB' - , ToEnumBDef - , ToEnumBDef' - , ToEnumBFail - - -- ** wrap / unwrap expressions - , Unwrap - , Wrap - , Wrap' - , Coerce - , Coerce2 - - -- ** list / foldable expressions - , Map - , Concat - , ConcatMap - , Partition - , GroupOn - , Filter - , Break - , Span - , Intercalate - , Elem - , Inits - , Tails - , Ones - , OneP - , Len - , Length - , PadL - , PadR - , Cycle - , SplitAts - , SplitAt - , ChunksOf - , Rotate - , Take - , Drop - , Min - , Max - , Sum - , Product - , IsEmpty - , Null - , Null' - , ToList - , ToList' - , IToList - , IToList' - , FromList - , EmptyList - , EmptyList' - , Singleton - , Reverse - , ReverseL - , SortBy - , SortOn - , SortOnDesc - , Remove - , Keep - -- *** overloaded list expressions - , ToListExt - , FromListExt - - -- ** maybe expressions - , MkNothing - , MkNothing' - , MkJust - , IsNothing - , IsJust - , MapMaybe - , CatMaybes - , Just - , JustDef - , JustFail - , MaybeIn - , MaybeBool - - -- ** either expressions - , PartitionEithers - , IsLeft - , IsRight - , MkLeft - , MkLeft' - , MkRight - , MkRight' - , Left' - , Right' - , LeftDef - , LeftFail - , RightDef - , RightFail - , EitherBool - , EitherIn - - -- ** semigroup / monoid expressions - , type (<>) - , MConcat - , STimes - , SapA - , SapA' - , MEmptyT - , MEmptyT' - , MEmptyP - , MEmpty2 - , MEmpty2' - - -- ** indexing expressions - , Ix - , Ix' - , IxL - , type (!!) - , type (!!?) - , Lookup - , LookupDef - , LookupDef' - , LookupFail - , LookupFail' - - -- ** cons / uncons expressions - , type (:+) - , type (+:) - , type (++) - , Uncons - , Unsnoc - , Head - , Tail - , Init - , Last - , HeadDef - , HeadFail - , TailDef - , TailFail - , LastDef - , LastFail - , InitDef - , InitFail - - -- ** these expressions - , PartitionThese - , Thiss - , Thats - , Theses - , This' - , That' - , These' - , IsThis - , IsThat - , IsThese - , MkThis - , MkThis' - , MkThat - , MkThat' - , MkThese - , ThisDef - , ThisFail - , ThatDef - , ThatFail - , TheseDef - , TheseFail - , TheseIn - , TheseId - , TheseX - - -- ** fold / unfold expressions - , Scanl - , ScanN - , ScanNA - , FoldN - , FoldL - , Unfoldr - , IterateN - , IterateUntil - , IterateWhile - , IterateNWhile - , IterateNUntil - - -- ** failure expressions - , Fail - , Failp - , Failt - , FailS - , Catch - , Catch' - - -- ** zip expressions - , ZipThese - , ZipL - , ZipR - , Zip - , Unzip - , Unzip3 - - -- ** conditional expressions - , If - , Case - , Case' - , Case'' - , Guards - , GuardsQuick - , Guard - , ExitWhen - , GuardSimple - , GuardsN - , GuardsDetail - - , Bools - , BoolsQuick - , BoolsN - - -- ** IO expressions - , ReadFile - , FileExists - , ReadDir - , DirExists - , ReadEnv - , ReadEnvAll - , TimeUtc - , TimeZt - , AppendFile - , WriteFile - , WriteFile' - , Stdout - , Stderr - , Stdin - , ReadIO - , ReadIO' - - -- ** string expressions - , ToLower - , ToUpper - , ToTitle - , TrimBoth - , TrimL - , TrimR - , StripR - , StripL - , IsPrefix - , IsInfix - , IsSuffix - , IsPrefixI - , IsInfixI - , IsSuffixI - , ToString - , FromString - , FromString' - - -- ** print expressions - , PrintF - , PrintL - , PrintT - - -- ** higher order expressions - , Pure - , Pure2 - , FoldMap - , type (<$) - , type (<*) - , type (*>) - , FMapFst - , FMapSnd - , Sequence - , Traverse - , Join - , EmptyT - , type (<|>) - , Extract - , Duplicate - - -- ** expression combinators - , type ($) - , type (&) - , Do - , Dot - , RDot - , type (>>) - , type (<<) - , type (>>>) - , DoN - , type ($$) - , type ($&) - , K - , Hide - , Hole - , Skip - , type (|>) - , type (>|) - , type (>|>) - , Uncurry - - -- *** parallel expressions - , Para - , ParaN - , Repeat - - -- ** miscellaneous - , Both - , Prime - , PrimeNext - , Luhn - , Char1 - -- ** tuples - , Tuple2 - , Tuple3 - , Tuple4 - , Tuple5 - , Tuple6 - ) where -import Predicate.Core -import Predicate.Util -import Safe (succMay, predMay, toEnumMay) -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import Control.Lens hiding (iall) -import Data.List -import qualified Data.Text.Lens as DTL -import Data.Proxy -import Control.Applicative -import Data.Typeable -import Control.Monad.Except -import qualified Control.Exception as E -import Data.Kind (Type) -import qualified Text.Regex.PCRE.Heavy as RH -import Data.String -import Data.Foldable -import Data.Maybe -import Control.Arrow -import qualified Data.Semigroup as SG -import Numeric -import Data.Char -import Data.Function -import Data.These (These(..)) -import Data.Ratio -import Data.Time -import Data.Coerce -import Data.Void -import qualified Data.Sequence as Seq -import Text.Printf -import System.Directory -import Control.Comonad -import System.IO -import System.Environment -import qualified GHC.Exts as GE -import Data.Bool -import Data.Either -import qualified Data.Type.Equality as DE -import Data.Time.Calendar.WeekDate -import qualified Data.Time.Clock.System as CP -import qualified Data.Time.Clock.POSIX as P -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Map.Strict as M - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists --- >>> import qualified Data.Map.Strict as M --- >>> import qualified Data.Text as T --- >>> import Safe (readNote) - --- | a type level predicate for a monotonic increasing list --- --- >>> pl @Asc "aaacdef" --- True (All(6)) --- TrueT --- --- >>> pz @Asc [1,2,3,4,5,5,7] --- TrueT --- --- >>> pz @Asc' [1,2,3,4,5,5,7] --- FalseT --- --- >>> pz @Asc "axacdef" --- FalseT --- - - --- | a type level predicate for a monotonic increasing list -data Asc -type AscT = All (Fst Id <= Snd Id) Pairs - -instance P AscT x => P Asc x where - type PP Asc x = PP AscT x - eval _ = evalBool (Proxy @AscT) - --- | a type level predicate for a strictly increasing list -data Asc' -type AscT' = All (Fst Id < Snd Id) Pairs - -instance P AscT' x => P Asc' x where - type PP Asc' x = PP AscT' x - eval _ = evalBool (Proxy @AscT') - --- | a type level predicate for a monotonic decreasing list -data Desc -type DescT = All (Fst Id >= Snd Id) Pairs - -instance P DescT x => P Desc x where - type PP Desc x = PP DescT x - eval _ = evalBool (Proxy @DescT) --- | a type level predicate for a strictly decreasing list -data Desc' -type DescT' = All (Fst Id > Snd Id) Pairs - -instance P DescT' x => P Desc' x where - type PP Desc' x = PP DescT' x - eval _ = evalBool (Proxy @DescT') - - ---type AscAlt = SortOn Id Id == Id ---type DescAlt = SortOnDesc Id Id == Id - --- | A predicate that determines if the value is between \'p\' and \'q\' --- --- >>> pz @(Between 5 8 Len) [1,2,3,4,5,5,7] --- TrueT --- --- >>> pz @(5 <..> 8) 6 --- TrueT --- --- >>> pl @(Between 5 8 Id) 9 --- False (9 <= 8) --- FalseT --- --- >>> pz @(10 % 4 <..> 40 % 5) 4 --- TrueT --- --- >>> pz @(10 % 4 <..> 40 % 5) 33 --- FalseT --- -data Between p q r -- reify as it is used a lot! nicer specific messages at the top level! - -instance (Ord (PP p x) - , Show (PP p x) - , PP r x ~ PP p x - , PP r x ~ PP q x - , P p x - , P q x - , P r x - ) => P (Between p q r) x where - type PP (Between p q r) x = Bool - eval _ opts x = do - let msg0 = "Between" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right r -> do - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [hh rr] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh rr, hh pp, hh qq] - in if p <= r && r <= q then mkNodeB opts True (show p <> " <= " <> show r <> " <= " <> show q) hhs - else if p > r then mkNodeB opts False (show p <> " <= " <> show r) hhs - else mkNodeB opts False (show r <> " <= " <> show q) hhs - - -data p <..> q -infix 4 <..> - -type BetweenT p q = Between p q Id - -instance P (BetweenT p q) x => P (p <..> q) x where - type PP (p <..> q) x = PP (BetweenT p q) x - eval _ = evalBool (Proxy @(BetweenT p q)) - --- | between for tuples --- --- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),8) --- False (8 <= 4) --- FalseT --- --- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),0) --- False (1 <= 0) --- FalseT --- --- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),3) --- True (1 <= 3 <= 4) --- TrueT --- --- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2018-10-12" --- True (2017-04-11 <= 2018-10-12 <= 2018-12-30) --- TrueT --- --- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2019-10-12" --- False (2019-10-12 <= 2018-12-30) --- FalseT --- --- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2016-10-12" --- False (2017-04-11 <= 2016-10-12) --- FalseT --- - -{- too much data mitigated somewhat by Hide -type BetweenAT p q = '(p,q) >> Between (Fst (Fst Id)) (Snd (Fst Id)) (Snd Id) - -instance P (BetweenAT p q) x => P (BetweenA p q) x where - type PP (BetweenA p q) x = PP (BetweenAT p q) x - eval _ = evalBool (Proxy @(BetweenAT p q)) --} -data BetweenA p q - -instance (PP p x ~ (a,a') - , P q x - , PP q x ~ a - , Ord a - , a ~ a' - , Show a - , P p x - ) => P (BetweenA p q) x where - type PP (BetweenA p q) x = Bool - eval _ opts x = do - let msg0 = "BetweenA" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right ((p1,p2),q,pp,qq) -> - [hh pp, hh qq] & if p1 <= q && q <= p2 then mkNodeB opts True (show p1 <> " <= " <> show q <> " <= " <> show p2) - else if p1 > q then mkNodeB opts False (show p1 <> " <= " <> show q) - else mkNodeB opts False (show q <> " <= " <> show p2) - --- | similar to 'all' --- --- >>> pl @(All (Between 1 8 Id) Id) [7,3,4,1,2,9,0,1] --- False (All(8) i=5 (9 <= 8)) --- FalseT --- --- >>> pz @(All Odd Id) [1,5,11,5,3] --- TrueT --- --- >>> pz @(All Odd Id) [] --- TrueT --- --- >>> pan @(All Even Id) [1,5,11,5,3] --- False All(5) i=0 (1 == 0) --- | --- +- P Id [1,5,11,5,3] --- | --- +- False i=0:1 == 0 --- | | --- | +- P 1 `mod` 2 = 1 --- | | | --- | | +- P I --- | | | --- | | `- P '2 --- | | --- | `- P '0 --- | --- +- False i=1:1 == 0 --- | | --- | +- P 5 `mod` 2 = 1 --- | | | --- | | +- P I --- | | | --- | | `- P '2 --- | | --- | `- P '0 --- | --- +- False i=2:1 == 0 --- | | --- | +- P 11 `mod` 2 = 1 --- | | | --- | | +- P I --- | | | --- | | `- P '2 --- | | --- | `- P '0 --- | --- +- False i=3:1 == 0 --- | | --- | +- P 5 `mod` 2 = 1 --- | | | --- | | +- P I --- | | | --- | | `- P '2 --- | | --- | `- P '0 --- | --- `- False i=4:1 == 0 --- | --- +- P 3 `mod` 2 = 1 --- | | --- | +- P I --- | | --- | `- P '2 --- | --- `- P '0 --- FalseT --- -data All p q - -instance (P p a - , PP p a ~ Bool - , PP q x ~ f a - , P q x - , Show a - , Foldable f - ) => P (All p q) x where - type PP (All p q) x = Bool - eval _ opts x = do - let msg0 = "All" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case chkSize opts msg0 q [hh qq] of - Left e -> pure e - Right () -> do - ts <- zipWithM (\i a -> ((i, a),) <$> evalBool (Proxy @p) opts a) [0::Int ..] (toList q) - pure $ case splitAndAlign opts msg0 ts of - Left e -> e - Right abcs -> - let hhs = hh qq : map (hh . fixit) ts - msg1 = msg0 ++ "(" ++ show (length q) ++ ")" - in case find (not . view _1) abcs of - Nothing -> mkNodeB opts True msg1 hhs - Just (_,(i,_),tt) -> - mkNodeB opts False (msg1 <> " i=" ++ showIndex i ++ " " <> topMessage tt) hhs - -showIndex :: (Show i, Num i) => i -> String -showIndex i = show (i+0) --- | similar to 'any' --- --- >>> pl @(Any Even Id) [1,5,11,5,3] --- False (Any(5)) --- FalseT --- --- >>> pl @(Any Even Id) [1,5,112,5,3] --- True (Any(5) i=2 (0 == 0)) --- TrueT --- --- >>> pz @(Any Even Id) [] --- FalseT --- -data Any p q - -instance (P p a - , PP p a ~ Bool - , PP q x ~ f a - , P q x - , Show a - , Foldable f - ) => P (Any p q) x where - type PP (Any p q) x = Bool - eval _ opts x = do - let msg0 = "Any" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case chkSize opts msg0 q [hh qq] of - Left e -> pure e - Right () -> do - ts <- zipWithM (\i a -> ((i, a),) <$> evalBool (Proxy @p) opts a) [0::Int ..] (toList q) - pure $ case splitAndAlign opts msg0 ts of - Left e -> e - Right abcs -> - let hhs = hh qq : map (hh . fixit) ts - msg1 = msg0 ++ "(" ++ show (length q) ++ ")" - in case find (view _1) abcs of - Nothing -> mkNodeB opts False msg1 hhs - Just (_,(i,_),tt) -> - mkNodeB opts True (msg1 <> " i=" ++ showIndex i ++ " " <> topMessage tt) hhs - - --- | a type level predicate for all positive elements in a list --- --- >>> pz @AllPositive [1,5,10,2,3] --- TrueT --- --- >>> pz @AllPositive [0,1,5,10,2,3] --- FalseT --- --- >>> pz @AllPositive [3,1,-5,10,2,3] --- FalseT --- --- >>> pz @AllNegative [-1,-5,-10,-2,-3] --- TrueT --- -data AllPositive -type AllPositiveT = All Positive Id - -instance P AllPositiveT x => P AllPositive x where - type PP AllPositive x = PP AllPositiveT x - eval _ = evalBool (Proxy @AllPositiveT) - --- | a type level predicate for all negative elements in a list -data AllNegative -type AllNegativeT = All Negative Id - -instance P AllNegativeT x => P AllNegative x where - type PP AllNegative x = PP AllNegativeT x - eval _ = evalBool (Proxy @AllNegativeT) - - -type Positive = Gt 0 - -type Negative = Lt 0 - --- | 'unzip' equivalent --- --- >>> pz @Unzip (zip [1..5] "abcd") --- PresentT ([1,2,3,4],"abcd") --- -data Unzip -type UnzipT = '(Map (Fst Id) Id, Map (Snd Id) Id) - -instance P UnzipT x => P Unzip x where - type PP Unzip x = PP UnzipT x - eval _ = eval (Proxy @UnzipT) - - --- | 'unzip3' equivalent --- --- >>> pz @Unzip3 (zip3 [1..5] "abcd" (cycle [True,False])) --- PresentT ([1,2,3,4],"abcd",[True,False,True,False]) --- -data Unzip3 -type Unzip3T = '(Map (Fst Id) Id, Map (Snd Id) Id, Map (Thd Id) Id) - -instance P Unzip3T x => P Unzip3 x where - type PP Unzip3 x = PP Unzip3T x - eval _ = eval (Proxy @Unzip3T) - - --- | represents a predicate using a 'Symbol' as a regular expression --- evaluates 'Re' and returns True if there is a match --- --- >>> pz @(Re "^\\d{2}:\\d{2}:\\d{2}$" Id) "13:05:25" --- TrueT --- -data Re' (rs :: [ROpt]) p q -data Re p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Re' rs p q) x where - type PP (Re' rs p q) x = Bool - eval _ opts x = do - let msg0 = "Re" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - let b = q RH.=~ regex - in mkNodeB opts b (msg1 <> showLit1 opts " | " q) hhs - -type ReT p q = Re' '[] p q - -instance P (ReT p q) x => P (Re p q) x where - type PP (Re p q) x = PP (ReT p q) x - eval _ = evalBool (Proxy @(ReT p q)) - --- only way with rescan is to be explicit: no repeats! and useanchors but not (?m) --- or just use Re' but then we only get a bool ie doesnt capture groups --- rescan returns Right [] as an failure! --- [] is failure! - - --- | runs a regex matcher returning the original values and optionally any groups --- --- >>> pz @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" --- PresentT [("13:05:25",["13","05","25"])] --- --- >>> pz @(Rescan (Snd Id) "13:05:25") ('a',"^(\\d{2}):(\\d{2}):(\\d{2})$") --- PresentT [("13:05:25",["13","05","25"])] --- -data Rescan' (rs :: [ROpt]) p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Rescan' rs p q) x where - type PP (Rescan' rs p q) x = [(String, [String])] - eval _ opts x = do - let msg0 = "Rescan" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt (oRecursion opts) $ RH.scan regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") (msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q) hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") (msg1 <> " no match" <> show1 opts " | " q) [hh pp, hh qq] - (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b q) [hh pp, hh qq] - -data Rescan p q -type RescanT p q = Rescan' '[] p q - -instance P (RescanT p q) x => P (Rescan p q) x where - type PP (Rescan p q) x = PP (RescanT p q) x - eval _ = eval (Proxy @(RescanT p q)) - - --- | similar to 'Rescan' but gives the column start and ending positions instead of values --- --- >>> pz @(RescanRanges "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" --- PresentT [((0,8),[(0,2),(3,5),(6,8)])] --- -data RescanRanges' (rs :: [ROpt]) p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (RescanRanges' rs p q) x where - type PP (RescanRanges' rs p q) x = [((Int,Int), [(Int,Int)])] - eval _ opts x = do - let msg0 = "RescanRanges" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt (oRecursion opts) $ RH.scanRanges regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") (msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q) hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") (msg1 <> " no match" <> show1 opts " | " q) hhs - (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b q) hhs - -data RescanRanges p q -type RescanRangesT p q = RescanRanges' '[] p q - -instance P (RescanRangesT p q) x => P (RescanRanges p q) x where - type PP (RescanRanges p q) x = PP (RescanRangesT p q) x - eval _ = eval (Proxy @(RescanRangesT p q)) - --- | splits a string on a regex delimiter --- --- >>> pz @(Resplit "\\." Id) "141.201.1.22" --- PresentT ["141","201","1","22"] --- --- >>> pz @(Resplit (Singleton (Fst Id)) (Snd Id)) (':', "12:13:1") --- PresentT ["12","13","1"] --- --- >>> pl @(Resplit' '[ 'Caseless ] "aBc" Id) "123AbC456abc" --- Present ["123","456",""] (Resplit (aBc) ["123","456",""] | 123AbC456abc) --- PresentT ["123","456",""] --- -data Resplit' (rs :: [ROpt]) p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Resplit' rs p q) x where - type PP (Resplit' rs p q) x = [String] - eval _ opts x = do - let msg0 = "Resplit" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt (oRecursion opts) $ RH.split regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") (msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q) hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") (msg1 <> " no match" <> show1 opts " | " q) hhs - (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b q) hhs - -data Resplit p q -type ResplitT p q = Resplit' '[] p q - -instance P (ResplitT p q) x => P (Resplit p q) x where - type PP (Resplit p q) x = PP (ResplitT p q) x - eval _ = eval (Proxy @(ResplitT p q)) - --- | replaces regex \'s\' with a string \'s1\' inside the value --- --- >>> pz @(ReplaceAllString 'ROverWrite "\\." ":" Id) "141.201.1.22" --- PresentT "141:201:1:22" --- -data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r - -instance (GetBool b - , GetROpts rs - , PP p x ~ String - , PP q x ~ RReplace - , PP r x ~ String - , P p x - , P q x - , P r x - ) => P (ReplaceImpl b rs p q r) x where - type PP (ReplaceImpl b rs p q r) x = String - eval _ opts x = do - let msg0 = "Replace" <> (if alle then "All" else "One") <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - alle = getBool @b - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> pure tta - Right regex -> do - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let ret :: String - ret = case q of - RReplace o s -> - let g fn = (if alle then RH.gsub else RH.sub) regex fn r - in g (case o of - RPrepend -> (s <>) - ROverWrite -> const s - RAppend -> (<> s)) - RReplace1 s -> (if alle then RH.gsub else RH.sub) regex s r - RReplace2 s -> (if alle then RH.gsub else RH.sub) regex s r - RReplace3 s -> (if alle then RH.gsub else RH.sub) regex s r - in mkNode opts (PresentT ret) (msg1 <> showLit0 opts " " r <> showLit1 opts " | " ret) (hhs <> [hh rr]) - -data ReplaceAll' (rs :: [ROpt]) p q r -type ReplaceAllT' (rs :: [ROpt]) p q r = ReplaceImpl 'True rs p q r - -instance P (ReplaceAllT' rs p q r) x => P (ReplaceAll' rs p q r) x where - type PP (ReplaceAll' rs p q r) x = PP (ReplaceAllT' rs p q r) x - eval _ = eval (Proxy @(ReplaceAllT' rs p q r)) - -data ReplaceAll p q r -type ReplaceAllT p q r = ReplaceAll' '[] p q r - -instance P (ReplaceAllT p q r) x => P (ReplaceAll p q r) x where - type PP (ReplaceAll p q r) x = PP (ReplaceAllT p q r) x - eval _ = eval (Proxy @(ReplaceAllT p q r)) - -data ReplaceOne' (rs :: [ROpt]) p q r -type ReplaceOneT' (rs :: [ROpt]) p q r = ReplaceImpl 'False rs p q r - -instance P (ReplaceOneT' rs p q r) x => P (ReplaceOne' rs p q r) x where - type PP (ReplaceOne' rs p q r) x = PP (ReplaceOneT' rs p q r) x - eval _ = eval (Proxy @(ReplaceOneT' rs p q r)) - --- | replace first occurrence of string \'p\' with '\q'\ in \'r\' --- --- >>> pl @(ReplaceOneString 'ROverWrite "abc" "def" Id) "123abc456abc" --- Present "123def456abc" (ReplaceOne' [] (abc) 123abc456abc | 123def456abc) --- PresentT "123def456abc" --- --- >>> pz @(Rescan "^Date\\((\\d+[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1530144000123+0530)" --- PresentT 2018-06-28 05:30:00.123 +0530 --- --- >>> pz @(Rescan "^Date\\((\\d+[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1593460089052+0800)" --- PresentT 2020-06-30 03:48:09.052 +0800 --- --- >>> pz @(Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> (Id !! 0 <> "." <> Id !! 1) >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1593460089052+0800)" --- PresentT 2020-06-30 03:48:09.052 +0800 --- -data ReplaceOne p q r -type ReplaceOneT p q r = ReplaceOne' '[] p q r - -instance P (ReplaceOneT p q r) x => P (ReplaceOne p q r) x where - type PP (ReplaceOne p q r) x = PP (ReplaceOneT p q r) x - eval _ = eval (Proxy @(ReplaceOneT p q r)) - --- | replace all occurrences of string \'p\' with '\q'\ in \'r\' --- --- >>> pl @(ReplaceAllString 'ROverWrite "abc" "def" Id) "123abc456abc" --- Present "123def456def" (ReplaceAll' [] (abc) 123abc456abc | 123def456def) --- PresentT "123def456def" --- --- >>> pl @(ReplaceAllString' '[] 'ROverWrite "abc" "def" Id) "123AbC456abc" --- Present "123AbC456def" (ReplaceAll' [] (abc) 123AbC456abc | 123AbC456def) --- PresentT "123AbC456def" --- --- >>> pl @(ReplaceAllString' '[ 'Caseless ] 'ROverWrite "abc" "def" Id) "123AbC456abc" --- Present "123def456def" (ReplaceAll (abc) 123AbC456abc | 123def456def) --- PresentT "123def456def" --- --- >>> pl @(ReplaceAllString 'RPrepend "abc" "def" Id) "123AbC456abc" --- Present "123AbC456defabc" (ReplaceAll' [] (abc) 123AbC456abc | 123AbC456defabc) --- PresentT "123AbC456defabc" --- --- >>> pl @(ReplaceAllString 'ROverWrite "abc" "def" Id) "123AbC456abc" --- Present "123AbC456def" (ReplaceAll' [] (abc) 123AbC456abc | 123AbC456def) --- PresentT "123AbC456def" --- --- >>> pl @(ReplaceAllString 'RAppend "abc" "def" Id) "123AbC456abc" --- Present "123AbC456abcdef" (ReplaceAll' [] (abc) 123AbC456abc | 123AbC456abcdef) --- PresentT "123AbC456abcdef" --- -data ReplaceAllString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r -type ReplaceAllStringT' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r = ReplaceAll' rs p (ReplaceFn o q) r - -instance P (ReplaceAllStringT' rs o p q r) x => P (ReplaceAllString' rs o p q r) x where - type PP (ReplaceAllString' rs o p q r) x = PP (ReplaceAllStringT' rs o p q r) x - eval _ = eval (Proxy @(ReplaceAllStringT' rs o p q r)) - -data ReplaceAllString o p q r -type ReplaceAllStringT o p q r = ReplaceAllString' '[] o p q r - -instance P (ReplaceAllStringT o p q r) x => P (ReplaceAllString o p q r) x where - type PP (ReplaceAllString o p q r) x = PP (ReplaceAllStringT o p q r) x - eval _ = eval (Proxy @(ReplaceAllStringT o p q r)) - -data ReplaceOneString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r -type ReplaceOneStringT' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r = ReplaceOne' rs p (ReplaceFn o q) r - -instance P (ReplaceOneStringT' rs o p q r) x => P (ReplaceOneString' rs o p q r) x where - type PP (ReplaceOneString' rs o p q r) x = PP (ReplaceOneStringT' rs o p q r) x - eval _ = eval (Proxy @(ReplaceOneStringT' rs o p q r)) - -data ReplaceOneString (o :: ReplaceFnSub) p q r -type ReplaceOneStringT (o :: ReplaceFnSub) p q r = ReplaceOneString' '[] o p q r - -instance P (ReplaceOneStringT o p q r) x => P (ReplaceOneString o p q r) x where - type PP (ReplaceOneString o p q r) x = PP (ReplaceOneStringT o p q r) x - eval _ = eval (Proxy @(ReplaceOneStringT o p q r)) - --- | Simple replacement string: see 'ReplaceAllString' and 'ReplaceOneString' --- -data ReplaceFn (o :: ReplaceFnSub) p - -instance (GetReplaceFnSub r - , PP p x ~ String - , P p x) => P (ReplaceFn r p) x where - type PP (ReplaceFn r p) x = RReplace - eval _ opts x = do - let msg0 = "ReplaceFn" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = RReplace (getReplaceFnSub @r) p - in mkNode opts (PresentT b) (msg0 <> show1 opts " | " p) [hh pp] - --- | A replacement function @(String -> [String] -> String)@ which returns the whole match and the groups --- Used by 'RH.sub' and 'RH.gsub' --- --- Requires "Text.Show.Functions" --- -data ReplaceFn1 p - -instance (PP p x ~ (String -> [String] -> String) - , P p x) => P (ReplaceFn1 p) x where - type PP (ReplaceFn1 p) x = RReplace - eval _ opts x = do - let msg0 = "ReplaceFn1 (String -> [String] -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RReplace1 f)) msg0 [hh pp] - --- | A replacement function @(String -> String)@ that yields the whole match --- Used by 'RH.sub' and 'RH.gsub' --- --- Requires "Text.Show.Functions" --- --- >>> :m + Text.Show.Functions --- >>> pz @(ReplaceAll "\\." (ReplaceFn2 (Fst Id)) (Snd Id)) (\x -> x <> ":" <> x, "141.201.1.22") --- PresentT "141.:.201.:.1.:.22" --- -data ReplaceFn2 p - -instance (PP p x ~ (String -> String) - , P p x) => P (ReplaceFn2 p) x where - type PP (ReplaceFn2 p) x = RReplace - eval _ opts x = do - let msg0 = "ReplaceFn2 (String -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RReplace2 f)) msg0 [hh pp] - --- | A replacement function @([String] -> String)@ which yields the groups --- Used by 'RH.sub' and 'RH.gsub' --- --- Requires "Text.Show.Functions" --- --- >>> :m + Text.Show.Functions --- >>> pz @(ReplaceAll "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" (ReplaceFn3 (Fst Id)) (Snd Id)) (\ys -> intercalate " | " $ map (show . succ . readNote @Int "invalid int") ys, "141.201.1.22") --- PresentT "142 | 202 | 2 | 23" --- -data ReplaceFn3 p - -instance (PP p x ~ ([String] -> String) - , P p x) => P (ReplaceFn3 p) x where - type PP (ReplaceFn3 p) x = RReplace - eval _ opts x = do - let msg0 = "ReplaceFn3 ([String] -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RReplace3 f)) msg0 [hh pp] - - --- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set --- --- >>> pz @IsSpace '\t' --- TrueT --- --- >>> pz @IsSpace ' ' --- TrueT --- --- >>> pz @IsSpace 'x' --- FalseT --- --- >>> pz @IsLower 'a' --- TrueT --- --- >>> pz @IsLower 'X' --- FalseT --- --- >>> pz @IsHexDigit 'A' --- TrueT --- --- >>> pz @IsHexDigit 'g' --- FalseT --- -data IsCharSet (cs :: CharSet) - -instance (x ~ Char, GetCharSet cs) => P (IsCharSet cs) x where - type PP (IsCharSet cs) x = Bool - eval _ opts c = - let msg0 = "Is" ++ drop 1 (show cs) - (cs,f) = getCharSet @cs - b = f c - in pure $ mkNodeB opts b (msg0 <> show1 opts " | " [c]) [] - --- | predicate for determining if a character is lowercase --- --- >>> pz @IsLower '1' --- FalseT --- --- >>> pz @IsLower 'a' --- TrueT --- --- >>> pz @(Map '(IsControl, IsLatin1, IsHexDigit, IsOctDigit, IsDigit, IsPunctuation, IsSeparator, IsSpace) Id) "abc134" --- PresentT [(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False)] --- -data IsLower -type IsLowerT = IsCharSet 'CLower - -instance P IsLowerT x => P IsLower x where - type PP IsLower x = PP IsLowerT x - eval _ = evalBool (Proxy @IsLowerT) - -data IsUpper -type IsUpperT = IsCharSet 'CUpper - -instance P IsUpperT x => P IsUpper x where - type PP IsUpper x = PP IsUpperT x - eval _ = evalBool (Proxy @IsUpperT) - --- | predicate for determining if the character is a digit --- --- >>> pz @IsDigit 'g' --- FalseT --- --- >>> pz @IsDigit '9' --- TrueT --- -data IsDigit -type IsDigitT = IsCharSet 'CNumber -instance P IsDigitT x => P IsDigit x where - type PP IsDigit x = Bool - eval _ = evalBool (Proxy @IsDigitT) - -data IsSpace -type IsSpaceT = IsCharSet 'CSpace -instance P IsSpaceT x => P IsSpace x where - type PP IsSpace x = Bool - eval _ = evalBool (Proxy @IsSpaceT) - -data IsPunctuation -type IsPunctuationT = IsCharSet 'CPunctuation -instance P IsPunctuationT x => P IsPunctuation x where - type PP IsPunctuation x = Bool - eval _ = evalBool (Proxy @IsPunctuationT) - -data IsControl -type IsControlT = IsCharSet 'CControl -instance P IsControlT x => P IsControl x where - type PP IsControl x = Bool - eval _ = evalBool (Proxy @IsControlT) - -data IsHexDigit -type IsHexDigitT = IsCharSet 'CHexDigit -instance P IsHexDigitT x => P IsHexDigit x where - type PP IsHexDigit x = Bool - eval _ = evalBool (Proxy @IsHexDigitT) - -data IsOctDigit -type IsOctDigitT = IsCharSet 'COctDigit -instance P IsOctDigitT x => P IsOctDigit x where - type PP IsOctDigit x = Bool - eval _ = evalBool (Proxy @IsOctDigitT) - -data IsSeparator -type IsSeparatorT = IsCharSet 'CSeparator -instance P IsSeparatorT x => P IsSeparator x where - type PP IsSeparator x = Bool - eval _ = evalBool (Proxy @IsSeparatorT) - -data IsLatin1 -type IsLatin1T = IsCharSet 'CLatin1 -instance P IsLatin1T x => P IsLatin1 x where - type PP IsLatin1 x = Bool - eval _ = evalBool (Proxy @IsLatin1T) - - - --- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set --- --- >>> pz @IsLowerAll "abc" --- TrueT --- --- >>> pz @IsLowerAll "abcX" --- FalseT --- --- >>> pz @IsLowerAll (T.pack "abcX") --- FalseT --- --- >>> pz @IsHexDigitAll "01efA" --- TrueT --- --- >>> pz @IsHexDigitAll "01egfA" --- FalseT --- --- | predicate for determining if a string is all lowercase --- --- >>> pz @IsLowerAll "abcdef213" --- FalseT --- --- >>> pz @IsLowerAll "abcdef" --- TrueT --- --- >>> pz @IsLowerAll "" --- TrueT --- --- >>> pz @IsLowerAll "abcdefG" --- FalseT --- --- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "AbcdE" --- False ((>>) False | {True (&*) False | (IsLowerAll | "bcdE")}) --- FalseT --- --- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "Abcde" --- True ((>>) True | {True (&*) True}) --- TrueT --- --- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "xbcde" --- False ((>>) False | {False (&*) True | (IsUpper | "x")}) --- FalseT --- --- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "X" --- True ((>>) True | {True (&*) True}) --- TrueT --- --- >>> pz @( '(IsControlAll, IsLatin1All , IsHexDigitAll , IsOctDigitAll , IsDigitAll , IsPunctuationAll , IsSeparatorAll , IsSpaceAll ) ) "abc134" --- PresentT (False,True,True,False,False,False,False,False) --- --- >>> pl @(SplitAts [1,2,10] Id >> Para '[IsLowerAll, IsDigitAll, IsUpperAll ]) "abdefghi" --- Present [True,False,False] ((>>) [True,False,False] | {Para(0) [True,False,False] | ["a","bd","efghi"]}) --- PresentT [True,False,False] --- --- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll ]) "a98efghi" --- False ((>>) False | {Bool(2) [] (IsUpperAll | "efghi")}) --- FalseT --- --- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll ]) "a98efghi" --- True ((>>) True | {Bools}) --- TrueT --- --- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll ]) "a98efgHi" --- False ((>>) False | {Bool(2) [] (False || False | (IsUpperAll | "efgHi") || (IsLowerAll | "efgHi"))}) --- FalseT --- -data IsCharSetAll (cs :: CharSet) - -instance (GetCharSet cs - , Show a - , DTL.IsText a - ) => P (IsCharSetAll cs) a where - type PP (IsCharSetAll cs) a = Bool - eval _ opts as = - let b = allOf DTL.text f as - msg0 = "Is" ++ drop 1 (show cs) ++ "All" - (cs,f) = getCharSet @cs - in pure $ mkNodeB opts b (msg0 <> show1 opts " | " as) [] - -data CharSet = CLower - | CUpper - | CNumber - | CSpace - | CPunctuation - | CControl - | CHexDigit - | COctDigit - | CSeparator - | CLatin1 - deriving Show - -class GetCharSet (cs :: CharSet) where - getCharSet :: (CharSet, Char -> Bool) -instance GetCharSet 'CLower where - getCharSet = (CLower, isLower) -instance GetCharSet 'CUpper where - getCharSet = (CUpper, isUpper) -instance GetCharSet 'CNumber where - getCharSet = (CNumber, isNumber) -instance GetCharSet 'CSpace where - getCharSet = (CSpace, isSpace) -instance GetCharSet 'CPunctuation where - getCharSet = (CPunctuation, isPunctuation) -instance GetCharSet 'CControl where - getCharSet = (CControl, isControl) -instance GetCharSet 'CHexDigit where - getCharSet = (CHexDigit, isHexDigit) -instance GetCharSet 'COctDigit where - getCharSet = (COctDigit, isOctDigit) -instance GetCharSet 'CSeparator where - getCharSet = (CSeparator, isSeparator) -instance GetCharSet 'CLatin1 where - getCharSet = (CLatin1, isLatin1) - -data IsLowerAll -type IsLowerAllT = IsCharSetAll 'CLower - -instance P IsLowerAllT x => P IsLowerAll x where - type PP IsLowerAll x = PP IsLowerAllT x - eval _ = evalBool (Proxy @IsLowerAllT) - -data IsUpperAll -type IsUpperAllT = IsCharSetAll 'CUpper - -instance P IsUpperAllT x => P IsUpperAll x where - type PP IsUpperAll x = PP IsUpperAllT x - eval _ = evalBool (Proxy @IsUpperAllT) - --- | predicate for determining if the string is all digits --- --- >>> pz @IsDigitAll "213G" --- FalseT --- --- >>> pz @IsDigitAll "929" --- TrueT --- -data IsDigitAll -type IsDigitAllT = IsCharSetAll 'CNumber -instance P IsDigitAllT x => P IsDigitAll x where - type PP IsDigitAll x = Bool - eval _ = evalBool (Proxy @IsDigitAllT) - --- | predicate for determining if the string is all spaces --- --- >>> pz @IsSpaceAll "213G" --- FalseT --- --- >>> pz @IsSpaceAll " " --- TrueT --- --- >>> pz @IsSpaceAll "" --- TrueT --- -data IsSpaceAll -type IsSpaceAllT = IsCharSetAll 'CSpace -instance P IsSpaceAllT x => P IsSpaceAll x where - type PP IsSpaceAll x = Bool - eval _ = evalBool (Proxy @IsSpaceAllT) - -data IsPunctuationAll -type IsPunctuationAllT = IsCharSetAll 'CPunctuation -instance P IsPunctuationAllT x => P IsPunctuationAll x where - type PP IsPunctuationAll x = Bool - eval _ = evalBool (Proxy @IsPunctuationAllT) - -data IsControlAll -type IsControlAllT = IsCharSetAll 'CControl -instance P IsControlAllT x => P IsControlAll x where - type PP IsControlAll x = Bool - eval _ = evalBool (Proxy @IsControlAllT) - -data IsHexDigitAll -type IsHexDigitAllT = IsCharSetAll 'CHexDigit -instance P IsHexDigitAllT x => P IsHexDigitAll x where - type PP IsHexDigitAll x = Bool - eval _ = evalBool (Proxy @IsHexDigitAllT) - -data IsOctDigitAll -type IsOctDigitAllT = IsCharSetAll 'COctDigit -instance P IsOctDigitAllT x => P IsOctDigitAll x where - type PP IsOctDigitAll x = Bool - eval _ = evalBool (Proxy @IsOctDigitAllT) - -data IsSeparatorAll -type IsSeparatorAllT = IsCharSetAll 'CSeparator -instance P IsSeparatorAllT x => P IsSeparatorAll x where - type PP IsSeparatorAll x = Bool - eval _ = evalBool (Proxy @IsSeparatorAllT) - -data IsLatin1All -type IsLatin1AllT = IsCharSetAll 'CLatin1 -instance P IsLatin1AllT x => P IsLatin1All x where - type PP IsLatin1All x = Bool - eval _ = evalBool (Proxy @IsLatin1AllT) - - --- | converts a string 'Data.Text.Lens.IsText' value to lower case --- --- >>> pz @ToLower "HeLlO wOrld!" --- PresentT "hello world!" --- -data ToLower - -instance (Show a, DTL.IsText a) => P ToLower a where - type PP ToLower a = a - eval _ opts as = - let msg0 = "ToLower" - xs = as & DTL.text %~ toLower - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] - --- | converts a string 'Data.Text.Lens.IsText' value to upper case --- --- >>> pz @ToUpper "HeLlO wOrld!" --- PresentT "HELLO WORLD!" --- -data ToUpper - -instance (Show a, DTL.IsText a) => P ToUpper a where - type PP ToUpper a = a - eval _ opts as = - let msg0 = "ToUpper" - xs = as & DTL.text %~ toUpper - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] - - --- | converts a string 'Data.Text.Lens.IsText' value to title case --- --- >>> pz @ToTitle "HeLlO wOrld!" --- PresentT "Hello world!" --- --- >>> data Color = Red | White | Blue | Green | Black deriving (Show,Eq,Enum,Bounded,Read) --- >>> pz @(ToTitle >> ReadP Color Id) "red" --- PresentT Red --- -data ToTitle - -instance (Show a, DTL.IsText a) => P ToTitle a where - type PP ToTitle a = a - eval _ opts as = - let msg0 = "ToTitle" - xs = toTitleAll (as ^. DTL.unpacked) ^. DTL.packed - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] - - -toTitleAll :: String -> String -toTitleAll (x:xs) = toUpper x : map toLower xs -toTitleAll [] = [] - - --- | similar to 'Data.List.inits' --- --- >>> pz @Inits [4,8,3,9] --- PresentT [[],[4],[4,8],[4,8,3],[4,8,3,9]] --- --- >>> pz @Inits [] --- PresentT [[]] --- -data Inits - -instance ([a] ~ x, Show a) => P Inits x where - type PP Inits x = [x] - eval _ opts as = - let msg0 = "Inits" - xs = inits as - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] - --- | similar to 'Data.List.tails' --- --- >>> pz @Tails [4,8,3,9] --- PresentT [[4,8,3,9],[8,3,9],[3,9],[9],[]] --- --- >>> pz @Tails [] --- PresentT [[]] --- -data Tails - -instance ([a] ~ x, Show a) => P Tails x where - type PP Tails x = [x] - eval _ opts as = - let msg0 = "Tails" - xs = tails as - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] - --- | split a list into single values --- --- >>> pz @(Ones Id) [4,8,3,9] --- PresentT [[4],[8],[3],[9]] --- --- >>> pz @(Ones Id) [] --- PresentT [] --- -data Ones p - -instance ( PP p x ~ [a] - , P p x - , Show a - ) => P (Ones p) x where - type PP (Ones p) x = [PP p x] - eval _ opts x = do - let msg0 = "Ones" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case chkSize opts msg0 p [hh pp] of - Left e -> e - Right () -> - let d = map pure p - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | similar to 'show' --- --- >>> pz @(ShowP Id) [4,8,3,9] --- PresentT "[4,8,3,9]" --- --- >>> pz @(ShowP Id) 'x' --- PresentT "'x'" --- --- >>> pz @(ShowP (42 -% 10)) 'x' --- PresentT "(-21) % 5" --- -data ShowP p - -instance (Show (PP p x), P p x) => P (ShowP p) x where - type PP (ShowP p) x = String - eval _ opts x = do - let msg0 = "ShowP" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = show p - in mkNode opts (PresentT d) (msg0 <> showLit0 opts " " d <> show1 opts " | " p) [hh pp] - --- | type level expression representing a formatted time --- similar to 'Data.Time.formatTime' using a type level 'Symbol' to get the formatting string --- --- >>> pz @(FormatTimeP "%F %T" Id) (readNote @LocalTime "invalid localtime" "2019-05-24 05:19:59") --- PresentT "2019-05-24 05:19:59" --- --- >>> pz @(FormatTimeP (Fst Id) (Snd Id)) ("the date is %d/%m/%Y", readNote @Day "invalid day" "2019-05-24") --- PresentT "the date is 24/05/2019" --- -data FormatTimeP p q - -instance (PP p x ~ String - , FormatTime (PP q x) - , P p x - , Show (PP q x) - , P q x - ) => P (FormatTimeP p q) x where - type PP (FormatTimeP p q) x = String - eval _ opts x = do - let msg0 = "FormatTimeP" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - b = formatTime defaultTimeLocale p q - in mkNode opts (PresentT b) (msg1 <> showLit0 opts " " b <> show1 opts " | " q) [hh pp, hh qq] - --- | similar to 'Data.Time.parseTimeM' where \'t\' is the 'Data.Time.ParseTime' type, \'p\' is the datetime format and \'q\' points to the content to parse --- --- >>> pz @(ParseTimeP LocalTime "%F %T" Id) "2019-05-24 05:19:59" --- PresentT 2019-05-24 05:19:59 --- --- >>> pz @(ParseTimeP LocalTime "%F %T" "2019-05-24 05:19:59") (Right "never used") --- PresentT 2019-05-24 05:19:59 --- --- keeping \'q\' as we might want to extract from a tuple -data ParseTimeP' t p q - -instance (ParseTime (PP t a) - , Typeable (PP t a) - , Show (PP t a) - , P p a - , P q a - , PP p a ~ String - , PP q a ~ String - ) => P (ParseTimeP' t p q) a where - type PP (ParseTimeP' t p q) a = PP t a - eval _ opts a = do - let msg0 = "ParseTimeP " <> t - t = showT @(PP t a) - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case parseTimeM @Maybe @(PP t a) True defaultTimeLocale p q of - Just b -> mkNode opts (PresentT b) (lit01' opts msg1 b "fmt=" p <> show1 opts " | " q) hhs - Nothing -> mkNode opts (FailT (msg1 <> " failed to parse")) (msg1 <> " failed") hhs - -data ParseTimeP (t :: Type) p q -type ParseTimePT (t :: Type) p q = ParseTimeP' (Hole t) p q - -instance P (ParseTimePT t p q) x => P (ParseTimeP t p q) x where - type PP (ParseTimeP t p q) x = PP (ParseTimePT t p q) x - eval _ = eval (Proxy @(ParseTimePT t p q)) - --- | A convenience method to match against many different datetime formats to find a match --- --- >>> pz @(ParseTimes LocalTime '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] "03/11/19 01:22:33") () --- PresentT 2019-03-11 01:22:33 --- --- >>> pz @(ParseTimes LocalTime (Fst Id) (Snd Id)) (["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"], "03/11/19 01:22:33") --- PresentT 2019-03-11 01:22:33 --- -data ParseTimes' t p q - -instance (ParseTime (PP t a) - , Typeable (PP t a) - , Show (PP t a) - , P p a - , P q a - , PP p a ~ [String] - , PP q a ~ String - ) => P (ParseTimes' t p q) a where - type PP (ParseTimes' t p q) a = PP t a - eval _ opts a = do - let msg0 = "ParseTimes " <> t - t = showT @(PP t a) - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 - hhs = [hh pp, hh qq] - zs = map (\d -> (d,) <$> parseTimeM @Maybe @(PP t a) True defaultTimeLocale d q) p - in case catMaybes zs of - [] -> mkNode opts (FailT ("no match on [" ++ q ++ "]")) (msg1 <> " no match") hhs - (d,b):_ -> mkNode opts (PresentT b) (lit01' opts msg1 b "fmt=" d <> show1 opts " | " q) hhs - -data ParseTimes (t :: Type) p q -type ParseTimesT (t :: Type) p q = ParseTimes' (Hole t) p q - -instance P (ParseTimesT t p q) x => P (ParseTimes t p q) x where - type PP (ParseTimes t p q) x = PP (ParseTimesT t p q) x - eval _ = eval (Proxy @(ParseTimesT t p q)) - --- | create a 'Day' from three int values passed in as year month and day --- --- >>> pz @(MkDay '(1,2,3) >> Just Id) () --- PresentT 0001-02-03 --- --- >>> pz @(Just (MkDay '(1,2,3))) 1 --- PresentT 0001-02-03 --- --- >>> pz @(MkDay Id) (2019,12,30) --- PresentT (Just 2019-12-30) --- --- >>> pz @(MkDay' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) --- PresentT Nothing --- --- >>> pz @(MkDay Id) (1999,3,13) --- PresentT (Just 1999-03-13) --- -data MkDay' p q r - -instance (P p x - , P q x - , P r x - , PP p x ~ Int - , PP q x ~ Int - , PP r x ~ Int - ) => P (MkDay' p q r) x where - type PP (MkDay' p q r) x = Maybe Day - eval _ opts x = do - let msg0 = "MkDay" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let mday = fromGregorianValid (fromIntegral p) q r - in mkNode opts (PresentT mday) (show01' opts msg0 mday "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) - -data MkDay p -type MkDayT p = MkDay' (Fst p) (Snd p) (Thd p) - -instance P (MkDayT p) x => P (MkDay p) x where - type PP (MkDay p) x = PP (MkDayT p) x - eval _ = eval (Proxy @(MkDayT p)) - --- | uncreate a 'Day' returning year month and day --- --- >>> pz @(UnMkDay Id) (readNote "invalid day" "2019-12-30") --- PresentT (2019,12,30) --- -data UnMkDay p - -instance (PP p x ~ Day, P p x) => P (UnMkDay p) x where - type PP (UnMkDay p) x = (Int, Int, Int) - eval _ opts x = do - let msg0 = "UnMkDay" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (fromIntegral -> y, m, d) = toGregorian p - b = (y, m, d) - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - - --- | create a 'Day' + Week + Day of Week from three int values passed in as year month and day --- --- >>> pz @(MkDayExtra '(1,2,3) >> Just Id >> Fst Id) () --- PresentT 0001-02-03 --- --- >>> pz @(Fst (Just (MkDayExtra '(1,2,3)))) 1 --- PresentT 0001-02-03 --- --- >>> pz @(MkDayExtra Id) (2019,12,30) --- PresentT (Just (2019-12-30,1,1)) --- --- >>> pz @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) --- PresentT Nothing --- --- >>> pz @(MkDayExtra Id) (1999,3,13) --- PresentT (Just (1999-03-13,10,6)) --- -data MkDayExtra' p q r - -instance (P p x - , P q x - , P r x - , PP p x ~ Int - , PP q x ~ Int - , PP r x ~ Int - ) => P (MkDayExtra' p q r) x where - type PP (MkDayExtra' p q r) x = Maybe (Day, Int, Int) - eval _ opts x = do - let msg0 = "MkDayExtra" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let mday = fromGregorianValid (fromIntegral p) q r - b = mday <&> \day -> - let (_, week, dow) = toWeekDate day - in (day, week, dow) - in mkNode opts (PresentT b) (show01' opts msg0 b "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) - -data MkDayExtra p -type MkDayExtraT p = MkDayExtra' (Fst p) (Snd p) (Thd p) - -instance P (MkDayExtraT p) x => P (MkDayExtra p) x where - type PP (MkDayExtra p) x = PP (MkDayExtraT p) x - eval _ = eval (Proxy @(MkDayExtraT p)) - --- | get day of week --- --- >>> pz @(Just (MkDay '(2020,7,11)) >> '(UnMkDay Id, ToWeekYear Id,ToWeekDate Id)) () --- PresentT ((2020,7,11),28,(6,"Saturday")) --- -data ToWeekDate p - -instance ( P p x - , PP p x ~ Day - ) => P (ToWeekDate p) x where - type PP (ToWeekDate p) x = (Int, String) - eval _ opts x = do - let msg0 = "ToWeekDate" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (_, _week, dow) = toWeekDate p - dowString = - case dow of - 1 -> "Monday" - 2 -> "Tuesday" - 3 -> "Wednesday" - 4 -> "Thursday" - 5 -> "Friday" - 6 -> "Saturday" - 7 -> "Sunday" - _ -> error $ "oops: ToWeekDate invalid " ++ show dow - in mkNode opts (PresentT (dow,dowString)) (show01 opts msg0 dow p) [hh pp] - --- | get week number of the year --- --- >>> pz @(Just (MkDay '(2020,7,11)) >> ToWeekYear Id) () --- PresentT 28 --- -data ToWeekYear p - -instance ( P p x - , PP p x ~ Day - ) => P (ToWeekYear p) x where - type PP (ToWeekYear p) x = Int - eval _ opts x = do - let msg0 = "ToWeekYear" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (_, week, _dow) = toWeekDate p - in mkNode opts (PresentT week) (show01 opts msg0 week p) [hh pp] - -class ToDayC a where - getDay :: a -> Day -instance ToDayC UTCTime where - getDay = utctDay -instance ToDayC ZonedTime where - getDay = getDay . zonedTimeToLocalTime -instance ToDayC LocalTime where - getDay = localDay -instance ToDayC Day where - getDay = id -instance ToDayC Rational where - getDay = getDay . P.posixSecondsToUTCTime . fromRational -instance ToDayC CP.SystemTime where - getDay = getDay . CP.systemToUTCTime - -class ToTimeC a where - getTime :: a -> TimeOfDay -instance ToTimeC UTCTime where - getTime = getTime . utctDayTime -instance ToTimeC ZonedTime where - getTime = getTime . zonedTimeToLocalTime -instance ToTimeC LocalTime where - getTime = localTimeOfDay -instance ToTimeC TimeOfDay where - getTime = id -instance ToTimeC DiffTime where - getTime = timeToTimeOfDay -instance ToTimeC Rational where - getTime = getTime . P.posixSecondsToUTCTime . fromRational -instance ToTimeC CP.SystemTime where - getTime = getTime . CP.systemToUTCTime - --- | extract 'Day' from a DateTime --- --- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" --- PresentT 2020-07-06 --- -data ToDay p - -instance (P p x, Show (PP p x), ToDayC (PP p x)) => P (ToDay p) x where - type PP (ToDay p) x = Day - eval _ opts x = do - let msg0 = "ToDay" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let ret = getDay p - in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp] - --- | extract 'TimeOfDay' from DateTime --- --- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" --- PresentT 2020-07-06 --- -data ToTime p - -instance ( P p x - , Show (PP p x) - , ToTimeC (PP p x) - ) => P (ToTime p) x where - type PP (ToTime p) x = TimeOfDay - eval _ opts x = do - let msg0 = "ToTime" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let ret = getTime p - in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp] - - --- | create a 'TimeOfDay' from three int values passed in as year month and day --- --- >>> pz @(MkTime '(1,2,3 % 12345)) () --- PresentT 01:02:00.000243013365 --- --- >>> pz @(MkTime Id) (12,13,65) --- PresentT 12:13:65 --- --- >>> pz @(MkTime' (Fst Id) (Snd Id) (Thd Id)) (13,99,99999) --- PresentT 13:99:99999 --- --- >>> pz @(MkTime Id) (17,3,13) --- PresentT 17:03:13 --- -data MkTime' p q r - -instance (P p x - , P q x - , P r x - , PP p x ~ Int - , PP q x ~ Int - , PP r x ~ Rational - ) => P (MkTime' p q r) x where - type PP (MkTime' p q r) x = TimeOfDay - eval _ opts x = do - let msg0 = "MkTime" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let mtime = TimeOfDay p q (fromRational r) - in mkNode opts (PresentT mtime) (show01' opts msg0 mtime "(h,m,s)=" (p,q,r)) (hhs <> [hh rr]) - -data MkTime p -type MkTimeT p = MkTime' (Fst p) (Snd p) (Thd p) - -instance P (MkTimeT p) x => P (MkTime p) x where - type PP (MkTime p) x = PP (MkTimeT p) x - eval _ = eval (Proxy @(MkTimeT p)) - - --- | uncreate a 'TimeOfDay' returning hour minute seconds picoseconds --- --- >>> pz @(ReadP UTCTime "2019-01-01 12:13:14.1234Z" >> ToTime Id >> UnMkTime Id) () --- PresentT (12,13,70617 % 5000) --- --- >>> pz @(ReadP UTCTime Id >> ToTime Id >> UnMkTime Id) "2020-07-22 08:01:14.127Z" --- PresentT (8,1,14127 % 1000) --- --- >>> pz @(ReadP ZonedTime Id >> '(UnMkDay (ToDay Id), UnMkTime (ToTime Id))) "2020-07-11 11:41:12.333 CET" --- PresentT ((2020,7,11),(11,41,12333 % 1000)) --- -data UnMkTime p - -instance (PP p x ~ TimeOfDay, P p x) => P (UnMkTime p) x where - type PP (UnMkTime p) x = (Int, Int, Rational) - eval _ opts x = do - let msg0 = "UnMkTime" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let TimeOfDay h m s = p - b = (h, m, toRational s) - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - - --- microsoft json date is x*1000 ie milliseconds - --- | convert posix time (seconds since 01-01-1970) to 'UTCTime' --- --- >>> pl @(PosixToUTCTime Id) 1593384312 --- Present 2020-06-28 22:45:12 UTC (PosixToUTCTime 2020-06-28 22:45:12 UTC | 1593384312 % 1) --- PresentT 2020-06-28 22:45:12 UTC --- --- >>> pl @(PosixToUTCTime Id >> UTCTimeToPosix Id) 1593384312 --- Present 1593384312 % 1 ((>>) 1593384312 % 1 | {UTCTimeToPosix 1593384312 % 1 | 2020-06-28 22:45:12 UTC}) --- PresentT (1593384312 % 1) --- --- >>> pl @(PosixToUTCTime (Id % 1000)) 1593384312000 --- Present 2020-06-28 22:45:12 UTC (PosixToUTCTime 2020-06-28 22:45:12 UTC | 1593384312 % 1) --- PresentT 2020-06-28 22:45:12 UTC --- --- >>> pl @(PosixToUTCTime Id) (3600*4+60*7+12) --- Present 1970-01-01 04:07:12 UTC (PosixToUTCTime 1970-01-01 04:07:12 UTC | 14832 % 1) --- PresentT 1970-01-01 04:07:12 UTC --- --- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" Id >> Head Id >> Snd Id >> ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) "Date(1530144000000+0530)" --- PresentT 2018-06-28 00:00:00 UTC --- -data PosixToUTCTime p - -instance (PP p x ~ Rational, P p x) => P (PosixToUTCTime p) x where - type PP (PosixToUTCTime p) x = UTCTime - eval _ opts x = do - let msg0 = "PosixToUTCTime" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = P.posixSecondsToUTCTime (fromRational p) - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | convert 'UTCTime' to posix time (seconds since 01-01-1970) --- --- >>> pl @(ReadP UTCTime Id >> UTCTimeToPosix Id) "2020-06-28 22:45:12 UTC" --- Present 1593384312 % 1 ((>>) 1593384312 % 1 | {UTCTimeToPosix 1593384312 % 1 | 2020-06-28 22:45:12 UTC}) --- PresentT (1593384312 % 1) --- --- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" Id >> Head Id >> Snd Id >> ((ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) &&& ReadP TimeZone (Id !! 1))) "Date(1530144000000+0530)" --- PresentT (2018-06-28 00:00:00 UTC,+0530) --- --- not so useful: instead use ParseTimeP FormatTimeP with %s %q %z etc --- --- >>> pz @(ParseTimeP ZonedTime "%s%Q%z" Id) "153014400.000+0530" --- PresentT 1974-11-07 05:30:00 +0530 --- -data UTCTimeToPosix p - -instance (PP p x ~ UTCTime, P p x) => P (UTCTimeToPosix p) x where - type PP (UTCTimeToPosix p) x = Rational - eval _ opts x = do - let msg0 = "UTCTimeToPosix" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = toRational $ P.utcTimeToPOSIXSeconds p - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read --- --- >>> pz @(ReadP Rational Id) "4 % 5" --- PresentT (4 % 5) --- --- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2018-10-12" --- TrueT --- --- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2016-10-12" --- FalseT --- -data ReadP' t p - -instance (P p x - , PP p x ~ String - , Typeable (PP t x) - , Show (PP t x) - , Read (PP t x) - ) => P (ReadP' t p) x where - type PP (ReadP' t p) x = PP t x - eval _ opts x = do - let msg0 = "ReadP " <> t - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> - let hhs = [hh pp] - in case reads @(PP t x) s of - [(b,"")] -> mkNode opts (PresentT b) (msg0 <> " " ++ show b) hhs - o -> mkNode opts (FailT (msg0 <> " (" ++ s ++ ")")) (msg0 <> " failed " <> show o <> " | s=" ++ s) hhs - -data ReadP (t :: Type) p -type ReadPT (t :: Type) p = ReadP' (Hole t) p - -instance P (ReadPT t p) x => P (ReadP t p) x where - type PP (ReadP t p) x = PP (ReadPT t p) x - eval _ = eval (Proxy @(ReadPT t p)) - - --- [] (a,s) (a,[]) - --- | Read but returns the Maybe of the value and any remaining unparsed string --- --- >>> pz @(ReadMaybe Int Id) "123x" --- PresentT (Just (123,"x")) --- --- >>> pz @(ReadMaybe Int Id) "123" --- PresentT (Just (123,"")) --- --- >>> pz @(ReadMaybe Int Id) "x123" --- PresentT Nothing --- -data ReadMaybe' t p - --- not as good as ReadQ --- type ReadZ' t p = ReadMaybe' t p >> JustFail "read failed" Id >> (Guard "oops" (Snd Id >> Null) >> Fst Id) - -instance (P p x - , PP p x ~ String - , Typeable (PP t x) - , Show (PP t x) - , Read (PP t x) - ) => P (ReadMaybe' t p) x where - type PP (ReadMaybe' t p) x = Maybe (PP t x, String) - eval _ opts x = do - let msg0 = "ReadMaybe " <> t - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> - let msg1 = msg0 <> " (" <> s <> ")" - hhs = [hh pp] - in case reads @(PP t x) s of - [(b,rest)] -> mkNode opts (PresentT (Just (b,rest))) (lit01 opts msg1 b s) hhs - o -> mkNode opts (PresentT Nothing) (msg1 <> " failed " <> show o) hhs - -data ReadMaybe (t :: Type) p -type ReadMaybeT (t :: Type) p = ReadMaybe' (Hole t) p - -instance P (ReadMaybeT t p) x => P (ReadMaybe t p) x where - type PP (ReadMaybe t p) x = PP (ReadMaybeT t p) x - eval _ = eval (Proxy @(ReadMaybeT t p)) - --- | emulates ReadP -data ReadQ' t p -type ReadQT' t p = ReadMaybe' t p >> MaybeIn (Failp "read failed") (Guard "oops" (Snd Id >> Null) >> Fst Id) - -instance P (ReadQT' t p) x => P (ReadQ' t p) x where - type PP (ReadQ' t p) x = PP (ReadQT' t p) x - eval _ = eval (Proxy @(ReadQT' t p)) - -data ReadQ (t :: Type) p -type ReadQT (t :: Type) p = ReadQ' (Hole t) p - -instance P (ReadQT t p) x => P (ReadQ t p) x where - type PP (ReadQ t p) x = PP (ReadQT t p) x - eval _ = eval (Proxy @(ReadQT t p)) - --- | similar to 'sum' --- --- >>> pz @Sum [10,4,5,12,3,4] --- PresentT 38 --- --- >>> pz @Sum [] --- PresentT 0 --- -data Sum - -instance (Num a, Show a) => P Sum [a] where - type PP Sum [a] = a - eval _ opts as = - let msg0 = "Sum" - v = sum as - in pure $ mkNode opts (PresentT v) (show01 opts msg0 v as) [] - --- | similar to 'product' --- --- >>> pz @Product [10,4,5,12,3,4] --- PresentT 28800 --- --- >>> pz @Product [] --- PresentT 1 --- -data Product - -instance (Num a, Show a) => P Product [a] where - type PP Product [a] = a - eval _ opts as = - let msg0 = "Product" - v = product as - in pure $ mkNode opts (PresentT v) (show01 opts msg0 v as) [] - --- | similar to 'minimum' --- --- >>> pz @Min [10,4,5,12,3,4] --- PresentT 3 --- --- >>> pz @Min [] --- FailT "empty list" --- -data Min - -instance (Ord a, Show a) => P Min [a] where - type PP Min [a] = a - eval _ opts as' = do - let msg0 = "Min" - pure $ case as' of - [] -> mkNode opts (FailT "empty list") (msg0 <> "(empty list)") [] - as@(_:_) -> - let v = minimum as - in mkNode opts (PresentT v) (show01 opts msg0 v as) [] - --- | similar to 'maximum' --- --- >>> pz @Max [10,4,5,12,3,4] --- PresentT 12 --- --- >>> pz @Max [] --- FailT "empty list" --- - -data Max - -instance (Ord a, Show a) => P Max [a] where - type PP Max [a] = a - eval _ opts as' = do - let msg0 = "Max" - pure $ case as' of - [] -> mkNode opts (FailT "empty list") (msg0 <> "(empty list)") [] - as@(_:_) -> - let v = maximum as - in mkNode opts (PresentT v) (show01 opts msg0 v as) [] - --- | sort a list --- --- >>> pz @(SortOn (Fst Id) Id) [(10,"abc"), (3,"def"), (4,"gg"), (10,"xyz"), (1,"z")] --- PresentT [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] --- --- >>> pz @(SortBy (OrdP (Snd Id) (Fst Id)) Id) [(10,"ab"),(4,"x"),(20,"bbb")] --- PresentT [(20,"bbb"),(10,"ab"),(4,"x")] --- --- >>> pz @(SortBy 'LT Id) [1,5,2,4,7,0] --- PresentT [1,5,2,4,7,0] --- --- >>> pz @(SortBy 'GT Id) [1,5,2,4,7,0] --- PresentT [0,7,4,2,5,1] --- --- >>> pz @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Fst Id) ==! Snd (Snd Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] --- PresentT [(4,"a"),(4,"x"),(4,"y"),(10,"ab"),(20,"bbb")] --- --- >>> pz @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Snd Id) ==! Snd (Fst Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] --- PresentT [(4,"y"),(4,"x"),(4,"a"),(10,"ab"),(20,"bbb")] --- -data SortBy p q - -type SortByHelperT p = Partition (p == 'GT) Id - -instance (P p (a,a) - , P q x - , Show a - , PP q x ~ [a] - , PP p (a,a) ~ Ordering - ) => P (SortBy p q) x where - type PP (SortBy p q) x = PP q x - eval _ opts x = do - let msg0 = "SortBy" - qq <- eval (Proxy @q) opts x - case getValueLR opts (msg0 <> " q failed") qq [] of - Left e -> pure e - Right as -> do - let ff :: MonadEval m => [a] -> m (TT [a]) - ff = \case - [] -> pure $ mkNode opts (PresentT mempty) (msg0 <> " empty") [hh qq] - [w] -> pure $ mkNode opts (PresentT [w]) (msg0 <> " one element " <> show w) [hh qq] - w:ys@(_:_) -> do - pp <- (if isVerbose opts then - eval (Proxy @(SortByHelperT p)) - else eval (Proxy @(Hide (SortByHelperT p)))) opts (map (w,) ys) --- pp <- eval (Proxy @(Hide (Partition (p >> Id == 'GT) Id))) opts (map (w,) ys) --- too much output: dont need (Map (Snd Id) *** Map (Snd Id)) -- just do map snd in code --- pp <- eval (Proxy @(Partition (p >> (Id == 'GT)) Id >> (Map (Snd Id) *** Map (Snd Id)))) opts (map (w,) ys) - case getValueLR opts msg0 pp [hh qq] of - Left e -> pure e - Right (ll', rr') -> do - lhs <- ff (map snd ll') - case getValueLR opts msg0 lhs [hh qq, hh pp] of - Left _ -> pure lhs -- dont rewrap - Right ll -> do - rhs <- ff (map snd rr') - case getValueLR opts msg0 rhs [hh qq, hh pp, hh lhs] of - Left _ -> pure rhs - Right rr -> - pure $ mkNode opts (PresentT (ll ++ w : rr)) - (msg0 <> show0 opts " lhs=" ll <> " pivot " <> show w <> show0 opts " rhs=" rr) - (hh pp : [hh lhs | length ll > 1] ++ [hh rhs | length rr > 1]) - ret <- ff as - pure $ case getValueLR opts msg0 ret [hh qq] of - Left _e -> ret -- dont rewrap else will double up messages: already handled - Right xs -> mkNode opts (_tBool ret) (msg0 <> show0 opts " " xs) [hh qq, hh ret] - -data SortOn p q -type SortOnT p q = SortBy (OrdA p) q - -instance P (SortOnT p q) x => P (SortOn p q) x where - type PP (SortOn p q) x = PP (SortOnT p q) x - eval _ = eval (Proxy @(SortOnT p q)) - -data SortOnDesc p q -type SortOnDescT p q = SortBy (Swap >> OrdA p) q - -instance P (SortOnDescT p q) x => P (SortOnDesc p q) x where - type PP (SortOnDesc p q) x = PP (SortOnDescT p q) x - eval _ = eval (Proxy @(SortOnDescT p q)) - --- | similar to 'length' --- --- >>> pz @Len [10,4,5,12,3,4] --- PresentT 6 --- --- >>> pz @Len [] --- PresentT 0 --- -data Len -instance (Show a, as ~ [a]) => P Len as where - type PP Len as = Int - eval _ opts as = - let msg0 = "Len" - n = length as - in pure $ mkNode opts (PresentT n) (show01 opts msg0 n as) [] - --- | similar to 'length' for 'Foldable' instances --- --- >>> pz @(Length Id) (Left "aa") --- PresentT 0 --- --- >>> pz @(Length Id) (Right "aa") --- PresentT 1 --- --- >>> pz @(Length (Right' Id)) (Right "abcd") --- PresentT 4 --- --- >>> pz @(Length (Thd (Snd Id))) (True,(23,'x',[10,9,1,3,4,2])) --- PresentT 6 --- -data Length p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t) => P (Length p) x where - type PP (Length p) x = Int - eval _ opts x = do - let msg0 = "Length" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let n = length p - in mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] - --- | similar to 'fst' --- --- >>> pz @(Fst Id) (10,"Abc") --- PresentT 10 --- --- >>> pz @(Fst Id) (10,"Abc",'x') --- PresentT 10 --- --- >>> pz @(Fst Id) (10,"Abc",'x',False) --- PresentT 10 --- -data Fst p - -instance (Show (ExtractL1T (PP p x)) - , ExtractL1C (PP p x) - , P p x - , Show (PP p x) - ) => P (Fst p) x where - type PP (Fst p) x = ExtractL1T (PP p x) - eval _ opts x = do - let msg0 = "Fst" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL1C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data L1 p -type L1T p = Fst p - -instance P (L1T p) x => P (L1 p) x where - type PP (L1 p) x = PP (L1T p) x - eval _ = eval (Proxy @(L1T p)) - -class ExtractL1C tp where - type ExtractL1T tp - extractL1C :: tp -> ExtractL1T tp -instance ExtractL1C (a,b) where - type ExtractL1T (a,b) = a - extractL1C (a,_) = a -instance ExtractL1C (a,b,c) where - type ExtractL1T (a,b,c) = a - extractL1C (a,_,_) = a -instance ExtractL1C (a,b,c,d) where - type ExtractL1T (a,b,c,d) = a - extractL1C (a,_,_,_) = a -instance ExtractL1C (a,b,c,d,e) where - type ExtractL1T (a,b,c,d,e) = a - extractL1C (a,_,_,_,_) = a -instance ExtractL1C (a,b,c,d,e,f) where - type ExtractL1T (a,b,c,d,e,f) = a - extractL1C (a,_,_,_,_,_) = a - --- | similar to 'snd' --- --- >>> pz @(Snd Id) (10,"Abc") --- PresentT "Abc" --- --- >>> pz @(Snd Id) (10,"Abc",True) --- PresentT "Abc" --- -data Snd p - -instance (Show (ExtractL2T (PP p x)) - , ExtractL2C (PP p x) - , P p x - , Show (PP p x) - ) => P (Snd p) x where - type PP (Snd p) x = ExtractL2T (PP p x) - eval _ opts x = do - let msg0 = "Snd" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL2C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data L2 p -type L2T p = Snd p - -instance P (L2T p) x => P (L2 p) x where - type PP (L2 p) x = PP (L2T p) x - eval _ = eval (Proxy @(L2T p)) - -class ExtractL2C tp where - type ExtractL2T tp - extractL2C :: tp -> ExtractL2T tp -instance ExtractL2C (a,b) where - type ExtractL2T (a,b) = b - extractL2C (_,b) = b -instance ExtractL2C (a,b,c) where - type ExtractL2T (a,b,c) = b - extractL2C (_,b,_) = b -instance ExtractL2C (a,b,c,d) where - type ExtractL2T (a,b,c,d) = b - extractL2C (_,b,_,_) = b -instance ExtractL2C (a,b,c,d,e) where - type ExtractL2T (a,b,c,d,e) = b - extractL2C (_,b,_,_,_) = b -instance ExtractL2C (a,b,c,d,e,f) where - type ExtractL2T (a,b,c,d,e,f) = b - extractL2C (_,b,_,_,_,_) = b - --- | similar to 3rd element in a n-tuple --- --- >>> pz @(Thd Id) (10,"Abc",133) --- PresentT 133 --- --- >>> pz @(Thd Id) (10,"Abc",133,True) --- PresentT 133 --- -data Thd p - -instance (Show (ExtractL3T (PP p x)) - , ExtractL3C (PP p x) - , P p x - , Show (PP p x) - ) => P (Thd p) x where - type PP (Thd p) x = ExtractL3T (PP p x) - eval _ opts x = do - let msg0 = "Thd" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL3C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data L3 p -type L3T p = Thd p - -instance P (L3T p) x => P (L3 p) x where - type PP (L3 p) x = PP (L3T p) x - eval _ = eval (Proxy @(L3T p)) - -class ExtractL3C tp where - type ExtractL3T tp - extractL3C :: tp -> ExtractL3T tp -instance ExtractL3C (a,b) where - type ExtractL3T (a,b) = GL.TypeError ('GL.Text "Thd doesn't work for 2-tuples") - extractL3C _ = errorInProgram "Thd doesn't work for 2-tuples" -instance ExtractL3C (a,b,c) where - type ExtractL3T (a,b,c) = c - extractL3C (_,_,c) = c -instance ExtractL3C (a,b,c,d) where - type ExtractL3T (a,b,c,d) = c - extractL3C (_,_,c,_) = c -instance ExtractL3C (a,b,c,d,e) where - type ExtractL3T (a,b,c,d,e) = c - extractL3C (_,_,c,_,_) = c -instance ExtractL3C (a,b,c,d,e,f) where - type ExtractL3T (a,b,c,d,e,f) = c - extractL3C (_,_,c,_,_,_) = c - --- | similar to 4th element in a n-tuple --- --- >>> pz @(L4 Id) (10,"Abc",'x',True) --- PresentT True --- --- >>> pz @(L4 (Fst (Snd Id))) ('x',((10,"Abc",'x',999),"aa",1),9) --- PresentT 999 --- -data L4 p - -instance (Show (ExtractL4T (PP p x)) - , ExtractL4C (PP p x) - , P p x - , Show (PP p x) - ) => P (L4 p) x where - type PP (L4 p) x = ExtractL4T (PP p x) - eval _ opts x = do - let msg0 = "L4" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL4C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -class ExtractL4C tp where - type ExtractL4T tp - extractL4C :: tp -> ExtractL4T tp -instance ExtractL4C (a,b) where - type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 doesn't work for 2-tuples") - extractL4C _ = errorInProgram "L4 doesn't work for 2-tuples" -instance ExtractL4C (a,b,c) where - type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 doesn't work for 3-tuples") - extractL4C _ = errorInProgram "L4 doesn't work for 3-tuples" -instance ExtractL4C (a,b,c,d) where - type ExtractL4T (a,b,c,d) = d - extractL4C (_,_,_,d) = d -instance ExtractL4C (a,b,c,d,e) where - type ExtractL4T (a,b,c,d,e) = d - extractL4C (_,_,_,d,_) = d -instance ExtractL4C (a,b,c,d,e,f) where - type ExtractL4T (a,b,c,d,e,f) = d - extractL4C (_,_,_,d,_,_) = d - --- | similar to 5th element in a n-tuple --- --- >>> pz @(L5 Id) (10,"Abc",'x',True,1) --- PresentT 1 --- -data L5 p - -instance (Show (ExtractL5T (PP p x)) - , ExtractL5C (PP p x) - , P p x - , Show (PP p x) - ) => P (L5 p) x where - type PP (L5 p) x = ExtractL5T (PP p x) - eval _ opts x = do - let msg0 = "L5" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL5C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -class ExtractL5C tp where - type ExtractL5T tp - extractL5C :: tp -> ExtractL5T tp -instance ExtractL5C (a,b) where - type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 doesn't work for 2-tuples") - extractL5C _ = errorInProgram "L5 doesn't work for 2-tuples" -instance ExtractL5C (a,b,c) where - type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 doesn't work for 3-tuples") - extractL5C _ = errorInProgram "L5 doesn't work for 3-tuples" -instance ExtractL5C (a,b,c,d) where - type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 doesn't work for 4-tuples") - extractL5C _ = errorInProgram "L5 doesn't work for 4-tuples" -instance ExtractL5C (a,b,c,d,e) where - type ExtractL5T (a,b,c,d,e) = e - extractL5C (_,_,_,_,e) = e -instance ExtractL5C (a,b,c,d,e,f) where - type ExtractL5T (a,b,c,d,e,f) = e - extractL5C (_,_,_,_,e,_) = e - - --- | similar to 6th element in a n-tuple --- --- >>> pz @(L6 Id) (10,"Abc",'x',True,1,99) --- PresentT 99 --- -data L6 p - -instance (Show (ExtractL6T (PP p x)) - , ExtractL6C (PP p x) - , P p x - , Show (PP p x) - ) => P (L6 p) x where - type PP (L6 p) x = ExtractL6T (PP p x) - eval _ opts x = do - let msg0 = "L6" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL6C p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -class ExtractL6C tp where - type ExtractL6T tp - extractL6C :: tp -> ExtractL6T tp -instance ExtractL6C (a,b) where - type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 doesn't work for 2-tuples") - extractL6C _ = errorInProgram "L6 doesn't work for 2-tuples" -instance ExtractL6C (a,b,c) where - type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 doesn't work for 3-tuples") - extractL6C _ = errorInProgram "L6 doesn't work for 3-tuples" -instance ExtractL6C (a,b,c,d) where - type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 doesn't work for 4-tuples") - extractL6C _ = errorInProgram "L6 doesn't work for 4-tuples" -instance ExtractL6C (a,b,c,d,e) where - type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 doesn't work for 5-tuples") - extractL6C _ = errorInProgram "L6 doesn't work for 5-tuples" -instance ExtractL6C (a,b,c,d,e,f) where - type ExtractL6T (a,b,c,d,e,f) = f - extractL6C (_,_,_,_,_,f) = f - - --- | 'fromString' function where you need to provide the type \'t\' of the result --- --- >>> :set -XFlexibleContexts --- >>> pz @(FromString (Identity _) Id) "abc" --- PresentT (Identity "abc") --- --- >>> pz @(FromString (Seq.Seq Char) Id) "abc" --- PresentT (fromList "abc") -data FromString' t s - -instance (P s a - , PP s a ~ String - , Show (PP t a) - , IsString (PP t a) - ) => P (FromString' t s) a where - type PP (FromString' t s) a = PP t a - eval _ opts a = do - let msg0 = "FromString" - ss <- eval (Proxy @s) opts a - pure $ case getValueLR opts msg0 ss [] of - Left e -> e - Right s -> - let b = fromString @(PP t a) s - in mkNode opts (PresentT b) (msg0 <> show0 opts " " b) [hh ss] - -data FromString (t :: Type) p -type FromStringPT (t :: Type) p = FromString' (Hole t) p - -instance P (FromStringPT t p) x => P (FromString t p) x where - type PP (FromString t p) x = PP (FromStringPT t p) x - eval _ = eval (Proxy @(FromStringPT t p)) - - --- | 'fromInteger' function where you need to provide the type \'t\' of the result --- --- >>> pz @(FromInteger (SG.Sum _) Id) 23 --- PresentT (Sum {getSum = 23}) --- --- >>> pz @(FromInteger Rational 44) 12 --- PresentT (44 % 1) --- --- >>> pz @(FromInteger Rational Id) 12 --- PresentT (12 % 1) --- -data FromInteger' t n - -instance (Num (PP t a) - , Integral (PP n a) - , P n a - , Show (PP t a) - ) => P (FromInteger' t n) a where - type PP (FromInteger' t n) a = PP t a - eval _ opts a = do - let msg0 = "FromInteger" - nn <- eval (Proxy @n) opts a - pure $ case getValueLR opts msg0 nn [] of - Left e -> e - Right n -> - let b = fromInteger (fromIntegral n) - in mkNode opts (PresentT b) (msg0 <> show0 opts " " b) [hh nn] - -data FromInteger (t :: Type) p -type FromIntegerT (t :: Type) p = FromInteger' (Hole t) p ---type FromIntegerP n = FromInteger' Unproxy n - -instance P (FromIntegerT t p) x => P (FromInteger t p) x where - type PP (FromInteger t p) x = PP (FromIntegerT t p) x - eval _ = eval (Proxy @(FromIntegerT t p)) - --- | 'fromIntegral' function where you need to provide the type \'t\' of the result --- --- >>> pz @(FromIntegral (SG.Sum _) Id) 23 --- PresentT (Sum {getSum = 23}) -data FromIntegral' t n - -instance (Num (PP t a) - , Integral (PP n a) - , P n a - , Show (PP t a) - , Show (PP n a) - ) => P (FromIntegral' t n) a where - type PP (FromIntegral' t n) a = PP t a - eval _ opts a = do - let msg0 = "FromIntegral" - nn <- eval (Proxy @n) opts a - pure $ case getValueLR opts msg0 nn [] of - Left e -> e - Right n -> - let b = fromIntegral n - in mkNode opts (PresentT b) (show01 opts msg0 b n) [hh nn] - -data FromIntegral (t :: Type) p -type FromIntegralT (t :: Type) p = FromIntegral' (Hole t) p - -instance P (FromIntegralT t p) x => P (FromIntegral t p) x where - type PP (FromIntegral t p) x = PP (FromIntegralT t p) x - eval _ = eval (Proxy @(FromIntegralT t p)) - --- | 'toRational' function --- --- >>> pz @(ToRational Id) 23.5 --- PresentT (47 % 2) - -data ToRational p - -instance (a ~ PP p x - , Show a - , Real a - , P p x) - => P (ToRational p) x where - type PP (ToRational p) x = Rational - eval _ opts x = do - let msg0 = "ToRational" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a -> - let r = toRational a - in mkNode opts (PresentT r) (show01 opts msg0 r a) [hh pp] - --- | 'fromRational' function where you need to provide the type \'t\' of the result --- --- >>> pz @(FromRational Rational Id) 23.5 --- PresentT (47 % 2) -data FromRational' t r - -instance (P r a - , PP r a ~ Rational - , Show (PP t a) - , Fractional (PP t a) - ) => P (FromRational' t r) a where - type PP (FromRational' t r) a = PP t a - eval _ opts a = do - let msg0 = "FromRational" - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts msg0 rr [] of - Left e -> e - Right r -> - let b = fromRational @(PP t a) r - in mkNode opts (PresentT b) (show01 opts msg0 b r) [hh rr] - -data FromRational (t :: Type) p -type FromRationalT (t :: Type) p = FromRational' (Hole t) p - -instance P (FromRationalT t p) x => P (FromRational t p) x where - type PP (FromRational t p) x = PP (FromRationalT t p) x - eval _ = eval (Proxy @(FromRationalT t p)) - --- | 'truncate' function where you need to provide the type \'t\' of the result --- --- >>> pz @(Truncate Int Id) (23 % 5) --- PresentT 4 -data Truncate' t p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Truncate' t p) x where - type PP (Truncate' t p) x = PP t x - eval _ opts x = do - let msg0 = "Truncate" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = truncate p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data Truncate (t :: Type) p -type TruncateT (t :: Type) p = Truncate' (Hole t) p - -instance P (TruncateT t p) x => P (Truncate t p) x where - type PP (Truncate t p) x = PP (TruncateT t p) x - eval _ = eval (Proxy @(TruncateT t p)) - --- | 'ceiling' function where you need to provide the type \'t\' of the result --- --- >>> pz @(Ceiling Int Id) (23 % 5) --- PresentT 5 -data Ceiling' t p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Ceiling' t p) x where - type PP (Ceiling' t p) x = PP t x - eval _ opts x = do - let msg0 = "Ceiling" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = ceiling p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data Ceiling (t :: Type) p -type CeilingT (t :: Type) p = Ceiling' (Hole t) p - -instance P (CeilingT t p) x => P (Ceiling t p) x where - type PP (Ceiling t p) x = PP (CeilingT t p) x - eval _ = eval (Proxy @(CeilingT t p)) - --- | 'floor' function where you need to provide the type \'t\' of the result --- --- >>> pz @(Floor Int Id) (23 % 5) --- PresentT 4 -data Floor' t p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Floor' t p) x where - type PP (Floor' t p) x = PP t x - eval _ opts x = do - let msg0 = "Floor" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = floor p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data Floor (t :: Type) p -type FloorT (t :: Type) p = Floor' (Hole t) p - -instance P (FloorT t p) x => P (Floor t p) x where - type PP (Floor t p) x = PP (FloorT t p) x - eval _ = eval (Proxy @(FloorT t p)) --- | converts a value to a 'Proxy': the same as '\'Proxy' --- --- >>> pz @MkProxy 'x' --- PresentT Proxy --- -data MkProxy - -instance Show a => P MkProxy a where - type PP MkProxy a = Proxy a - eval _ opts a = - let msg0 = "MkProxy" - b = Proxy @a - in pure $ mkNode opts (PresentT b) (msg0 <> show1 opts " | " a) [] - --- | processes a type level list predicates running each in sequence: see 'Predicate.>>' --- --- >>> pz @(Do [Pred Id, ShowP Id, Id &&& Len]) 9876543 --- PresentT ("9876542",7) --- --- >>> pz @(Do '[W 123, W "xyz", Len &&& Id, Pred Id *** Id<>Id]) () --- PresentT (2,"xyzxyz") --- -data Do (ps :: [k]) - -instance (P (DoExpandT ps) a) => P (Do ps) a where - type PP (Do ps) a = PP (DoExpandT ps) a - eval _ = eval (Proxy @(DoExpandT ps)) - -type family DoExpandT (ps :: [k]) :: Type where - DoExpandT '[] = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") - DoExpandT '[p] = Id >> p -- need this else fails cos 1 is nat and would mean that the result is nat not Type! - -- if p >> Id then turns TrueT to PresentT True - DoExpandT (p ': p1 ': ps) = p >> DoExpandT (p1 ': ps) - --- | Convenient method to convert a value \'p\' to a 'Maybe' based on a predicate '\b\' --- if '\b\' then Just \'p'\ else Nothing --- --- >>> pz @(MaybeBool (Id > 4) Id) 24 --- PresentT (Just 24) --- --- >>> pz @(MaybeBool (Id > 4) Id) (-5) --- PresentT Nothing --- -data MaybeBool b p - -instance (Show (PP p a) - , P b a - , P p a - , PP b a ~ Bool - ) => P (MaybeBool b p) a where - type PP (MaybeBool b p) a = Maybe (PP p a) - eval _ opts z = do - let msg0 = "MaybeBool" - bb <- evalBool (Proxy @b) opts z - case getValueLR opts (msg0 <> " b failed") bb [] of - Left e -> pure e - Right True -> do - pp <- eval (Proxy @p) opts z - pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of - Left e -> e - Right p -> mkNode opts (PresentT (Just p)) (msg0 <> "(False)" <> show0 opts " Just " p) [hh bb, hh pp] - Right False -> pure $ mkNode opts (PresentT Nothing) (msg0 <> "(True)") [hh bb] - --- | Convenient method to convert a \'p\' or '\q'\ to a 'Either' based on a predicate '\b\' --- if \'b\' then Right \'p\' else Left '\q\' --- --- >>> pz @(EitherBool (Fst Id > 4) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (24,(-1,999)) --- PresentT (Right 999) --- --- >>> pz @(EitherBool (Fst Id > 4) (Fst (Snd Id)) (Snd (Snd Id))) (1,(-1,999)) --- PresentT (Left (-1)) --- -data EitherBool b p q - -instance (Show (PP p a) - , P p a - , Show (PP q a) - , P q a - , P b a - , PP b a ~ Bool - ) => P (EitherBool b p q) a where - type PP (EitherBool b p q) a = Either (PP p a) (PP q a) - eval _ opts z = do - let msg0 = "EitherBool" - bb <- evalBool (Proxy @b) opts z - case getValueLR opts (msg0 <> " b failed") bb [] of - Left e -> pure e - Right False -> do - pp <- eval (Proxy @p) opts z - pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of - Left e -> e - Right p -> mkNode opts (PresentT (Left p)) (msg0 <> "(False)" <> show0 opts " Left " p) [hh bb, hh pp] - Right True -> do - qq <- eval (Proxy @q) opts z - pure $ case getValueLR opts (msg0 <> " q failed") qq [hh bb] of - Left e -> e - Right q -> mkNode opts (PresentT (Right q)) (msg0 <> "(True)" <> show0 opts " Right " q) [hh bb, hh qq] - --- | pad \'q\' with '\n'\ values from '\p'\ --- --- >>> pz @(PadL 5 999 Id) [12,13] --- PresentT [999,999,999,12,13] --- --- >>> pz @(PadR 5 (Fst Id) '[12,13]) (999,'x') --- PresentT [12,13,999,999,999] --- --- >>> pz @(PadR 2 (Fst Id) '[12,13,14]) (999,'x') --- PresentT [12,13,14] --- -data PadImpl (left :: Bool) n p q - -instance (P n a - , GetBool left - , Integral (PP n a) - , [PP p a] ~ PP q a - , P p a - , P q a - , Show (PP p a) - ) => P (PadImpl left n p q) a where - type PP (PadImpl left n p q) a = PP q a - eval _ opts a = do - let msg0 = "Pad" <> (if lft then "L" else "R") - lft = getBool @left - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] - case lr of - Left e -> pure e - Right (fromIntegral -> n,p,nn,pp) -> do - let msg1 = msg0 <> show0 opts " " n <> " pad=" <> show p - hhs = [hh nn, hh pp] - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts (msg1 <> " q failed") qq hhs of - Left e -> e - Right q -> - let l = length q - diff = if n<=l then 0 else n-l - bs = if lft - then replicate diff p <> q - else q <> replicate diff p - in mkNode opts (PresentT bs) (show01 opts msg1 bs q) (hhs <> [hh qq]) - -data PadL n p q -type PadLT n p q = PadImpl 'True n p q - -instance P (PadLT n p q) x => P (PadL n p q) x where - type PP (PadL n p q) x = PP (PadLT n p q) x - eval _ = eval (Proxy @(PadLT n p q)) - -data PadR n p q -type PadRT n p q = PadImpl 'False n p q - -instance P (PadRT n p q) x => P (PadR n p q) x where - type PP (PadR n p q) x = PP (PadRT n p q) x - eval _ = eval (Proxy @(PadRT n p q)) - --- | split a list \'p\' into parts using the lengths in the type level list \'ns\' --- --- >>> pz @(SplitAts '[2,3,1,1] Id) "hello world" --- PresentT ["he","llo"," ","w","orld"] --- --- >>> pz @(SplitAts '[2] Id) "hello world" --- PresentT ["he","llo world"] --- --- >>> pz @(SplitAts '[10,1,1,5] Id) "hello world" --- PresentT ["hello worl","d","",""] --- -data SplitAts ns p - -instance (P ns x - , P p x - , PP p x ~ [a] - , Show n - , Show a - , PP ns x ~ [n] - , Integral n - ) => P (SplitAts ns p) x where - type PP (SplitAts ns p) x = [PP p x] - eval _ opts x = do - let msg0 = "SplitAts" - lr <- runPQ msg0 (Proxy @ns) (Proxy @p) opts x [] - pure $ case lr of - Left e -> e - Right (ns,p,nn,pp) -> - let zs = foldr (\n k s -> let (a,b) = splitAtNeg (fromIntegral n) s - in a:k b - ) (\as -> if null as then [] else [as]) ns p - in mkNode opts (PresentT zs) (show01' opts msg0 zs "ns=" ns <> show1 opts " | " p) [hh nn, hh pp] - --- | similar to 'splitAt' --- --- >>> pz @(SplitAt 4 Id) "hello world" --- PresentT ("hell","o world") --- --- >>> pz @(SplitAt 20 Id) "hello world" --- PresentT ("hello world","") --- --- >>> pz @(SplitAt 0 Id) "hello world" --- PresentT ("","hello world") --- --- >>> pz @(SplitAt (Snd Id) (Fst Id)) ("hello world",4) --- PresentT ("hell","o world") --- --- >>> pz @(SplitAt (Negate 2) Id) "hello world" --- PresentT ("hello wor","ld") --- -data SplitAt n p - -instance (PP p a ~ [b] - , P n a - , P p a - , Show b - , Integral (PP n a) - ) => P (SplitAt n p) a where - type PP (SplitAt n p) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "SplitAt" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] - pure $ case lr of - Left e -> e -- (Left e, tt') - Right (fromIntegral -> n,p,pp,qq) -> - let msg1 = msg0 <> show0 opts " " n <> show0 opts " " p - ret = splitAtNeg n p - in mkNode opts (PresentT ret) (show01' opts msg1 ret "n=" n <> show1 opts " | " p) [hh pp, hh qq] - -splitAtNeg :: Int -> [a] -> ([a], [a]) -splitAtNeg n as = splitAt (if n<0 then length as + n else n) as - - -data Take n p -type TakeT n p = Fst (SplitAt n p) - -instance P (TakeT n p) x => P (Take n p) x where - type PP (Take n p) x = PP (TakeT n p) x - eval _ = eval (Proxy @(TakeT n p)) - -data Drop n p -type DropT n p = Snd (SplitAt n p) - -instance P (DropT n p) x => P (Drop n p) x where - type PP (Drop n p) x = PP (DropT n p) x - eval _ = eval (Proxy @(DropT n p)) - ---type Tail = Uncons >> 'Just (Snd Id) ---type Head = Uncons >> 'Just (Fst Id) ---type Init = Unsnoc >> 'Just (Fst Id) ---type Last = Unsnoc >> 'Just (Snd Id) - --- | similar to 'Control.Arrow.&&&' -data p &&& q -infixr 3 &&& -type WAmpT p q = W '(p, q) - -instance P (WAmpT p q) x => P (p &&& q) x where - type PP (p &&& q) x = PP (WAmpT p q) x - eval _ = eval (Proxy @(WAmpT p q)) - --- | similar to 'Control.Arrow.***' --- --- >>> pz @(Pred Id *** ShowP Id) (13, True) --- PresentT (12,"True") --- --- >>> pl @(FlipT (***) Len (Id * 12)) (99,"cdef") --- Present (1188,4) ((***) (1188,4) | (99,"cdef")) --- PresentT (1188,4) --- -data p *** q -infixr 3 *** - -instance (Show (PP p a) - , Show (PP q b) - , P p a - , P q b - , Show a - , Show b - ) => P (p *** q) (a,b) where - type PP (p *** q) (a,b) = (PP p a, PP q b) - eval _ opts (a,b) = do - let msg0 = "(***)" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right a1 -> do - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - Right b1 -> mkNode opts (PresentT (a1,b1)) (msg0 <> show0 opts " " (a1,b1) <> show1 opts " | " (a,b)) [hh pp, hh qq] - -data First p -type FirstT p = p *** I - -instance P (FirstT p) x => P (First p) x where - type PP (First p) x = PP (FirstT p) x - eval _ = eval (Proxy @(FirstT p)) - -data Second q -type SecondT q = I *** q - -instance P (SecondT q) x => P (Second q) x where - type PP (Second q) x = PP (SecondT q) x - eval _ = eval (Proxy @(SecondT q)) - --- | similar 'Control.Arrow.|||' --- --- >>> pz @(Pred Id ||| Id) (Left 13) --- PresentT 12 --- --- >>> pz @(ShowP Id ||| Id) (Right "hello") --- PresentT "hello" --- -data p ||| q -infixr 2 ||| -type EitherIn p q = p ||| q - -instance (Show (PP p a) - , P p a - , P q b - , PP p a ~ PP q b - , Show a - , Show b - ) => P (p ||| q) (Either a b) where - type PP (p ||| q) (Either a b) = PP p a - eval _ opts lr = do - let msg0 = "(|||)" - case lr of - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a1 -> let msg1 = msg0 ++ " Left" - in mkNode opts (_tBool pp) (show01 opts msg1 a1 a) [hh pp] - Right a -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Right" - in mkNode opts (_tBool qq) (show01 opts msg1 a1 a) [hh qq] - --- | similar to 'isLeft' --- --- >>> pz @(IsLeft Id) (Right 123) --- FalseT --- --- >>> pz @(IsLeft Id) (Left 'a') --- TrueT --- -data IsLeft p - -instance (P p x, PP p x ~ Either a b) => P (IsLeft p) x where - type PP (IsLeft p) x = Bool - eval _ opts x = do - let msg0 = "IsLeft" - pp <- eval (Proxy @p) opts x - let hhs = [hh pp] - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (Left _) -> mkNodeB opts True msg0 hhs - Right (Right _) -> mkNodeB opts False msg0 hhs - --- | similar to 'isRight' --- --- >>> pz @(IsRight Id) (Right 123) --- TrueT --- --- >>> pz @(IsRight Id) (Left "aa") --- FalseT --- - -data IsRight p - -instance (P p x, PP p x ~ Either a b) => P (IsRight p) x where - type PP (IsRight p) x = Bool - eval _ opts x = do - let msg0 = "IsRight" - pp <- eval (Proxy @p) opts x - let hhs = [hh pp] - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (Left _) -> mkNodeB opts False msg0 hhs - Right (Right _) -> mkNodeB opts True msg0 hhs - - --- | similar 'Control.Arrow.+++' --- --- >>> pz @(Pred Id +++ Id) (Left 13) --- PresentT (Left 12) --- --- >>> pz @(ShowP Id +++ Reverse) (Right "hello") --- PresentT (Right "olleh") --- -data p +++ q -infixr 2 +++ - -instance (Show (PP p a) - , Show (PP q b) - , P p a - , P q b - , Show a - , Show b - ) => P (p +++ q) (Either a b) where - type PP (p +++ q) (Either a b) = Either (PP p a) (PP q b) - eval _ opts lr = do - let msg0 = "(+++)" - case lr of - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Left" - in mkNode opts (PresentT (Left a1)) (msg1 <> show0 opts " " a1 <> show1 opts " | " a) [hh pp] - Right a -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Right" - in mkNode opts (PresentT (Right a1)) (msg1 <> show0 opts " " a1 <> show1 opts " | " a) [hh qq] - -data Dup -type DupT = W '(Id, Id) - -instance Show x => P Dup x where - type PP Dup x = PP DupT x - eval _ = eval (Proxy @DupT) - -data BinOp = BMult | BSub | BAdd deriving (Show,Eq) - -data p + q -infixl 6 + - -type AddT p q = Bin 'BAdd p q - -instance P (AddT p q) x => P (p + q) x where - type PP (p + q) x = PP (AddT p q) x - eval _ = eval (Proxy @(AddT p q)) - -data p - q -infixl 6 - - -type SubT p q = Bin 'BSub p q - -instance P (SubT p q) x => P (p - q) x where - type PP (p - q) x = PP (SubT p q) x - eval _ = eval (Proxy @(SubT p q)) - -data p * q -infixl 7 * - -type MultT p q = Bin 'BMult p q - -instance P (MultT p q) x => P (p * q) x where - type PP (p * q) x = PP (MultT p q) x - eval _ = eval (Proxy @(MultT p q)) - --- | similar to 'GHC.Real.(^)' --- --- >>> pz @(Fst Id ^ Snd Id) (10,4) --- PresentT 10000 --- -data p ^ q -infixr 8 ^ - -instance (P p a - , P q a - , Show (PP p a) - , Show (PP q a) - , Num (PP p a) - , Integral (PP q a) - ) => P (p ^ q) a where - type PP (p ^ q) a = PP p a - eval _ opts a = do - let msg0 = "Pow" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - Right q -> - let hhs = [hh pp, hh qq] - in if q < 0 then mkNode opts (FailT (msg0 <> " negative exponent")) msg0 hhs - else let d = p ^ q - in mkNode opts (PresentT d) (show p <> " ^ " <> show q <> " = " <> show d) hhs - --- | similar to 'GHC.Float.(**)' --- --- >>> pz @(Fst Id ** Snd Id) (10,4) --- PresentT 10000.0 --- -data p ** q -infixr 8 ** - -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Floating (PP p a) - , Ord (PP q a) - ) => P (p ** q) a where - type PP (p ** q) a = PP p a - eval _ opts a = do - let msg0 = "Exp" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in if q < 0 then mkNode opts (FailT (msg0 <> " negative exponent")) msg0 hhs - else if p == 0 && q == 0 then mkNode opts (FailT (msg0 <> " zero/zero")) msg0 hhs - else let d = p ** q - in mkNode opts (PresentT d) (show p <> " ** " <> show q <> " = " <> show d) hhs - --- | similar to 'logBase' --- --- >>> pz @(Fst Id `LogBase` Snd Id >> Truncate Int Id) (10,12345) --- PresentT 4 --- -data LogBase p q -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP q a) - , Floating (PP q a) - , Ord (PP p a) - ) => P (LogBase p q) a where - type PP (LogBase p q) a = PP p a - eval _ opts a = do - let msg0 = "LogBase" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in if p <= 0 then mkNode opts (FailT (msg0 <> " non-positive base")) (msg0 <> " non-positive base") hhs - else let d = logBase p q - in mkNode opts (PresentT d) (msg0 <> " " <> show p <> " " <> show q <> " = " <> show d) hhs - -data p > q -infix 4 > - -instance P (Cmp 'CGt p q) x => P (p > q) x where - type PP (p > q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CGt p q)) - -data p >= q -infix 4 >= - -instance P (Cmp 'CGe p q) x => P (p >= q) x where - type PP (p >= q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CGe p q)) - -data p == q -infix 4 == - -instance P (Cmp 'CEq p q) x => P (p == q) x where - type PP (p == q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CEq p q)) - -data p <= q -infix 4 <= - -instance P (Cmp 'CLe p q) x => P (p <= q) x where - type PP (p <= q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CLe p q)) - -data p < q -infix 4 < - -instance P (Cmp 'CLt p q) x => P (p < q) x where - type PP (p < q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CLt p q)) - -data p /= q -infix 4 /= - -instance P (Cmp 'CNe p q) x => P (p /= q) x where - type PP (p /= q) x = Bool - eval _ = evalBool (Proxy @(Cmp 'CNe p q)) - ---type p + q = Bin 'BAdd p q ---type p - q = Bin 'BSub p q ---type p * q = Bin 'BMult p q - ---type p > q = Cmp 'CGt p q ---type p >= q = Cmp 'CGe p q ---type p == q = Cmp 'CEq p q ---type p /= q = Cmp 'CNe p q ---type p <= q = Cmp 'CLe p q ---type p < q = Cmp 'CLt p q - -type Gt n = I > n -type Ge n = I >= n -type Same n = I == n -type Le n = I <= n -type Lt n = I < n -type Ne n = I /= n - ---type p >~ q = CmpI 'CGt p q ---type p >=~ q = CmpI 'CGe p q ---type p ==~ q = CmpI 'CEq p q ---type p <=~ q = CmpI 'CLe p q ---type p <~ q = CmpI 'CLt p q ---type p /=~ q = CmpI 'CNe p q - -data p >~ q -infix 4 >~ - -instance P (CmpI 'CGt p q) x => P (p >~ q) x where - type PP (p >~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CGt p q)) - -data p >=~ q -infix 4 >=~ - -instance P (CmpI 'CGe p q) x => P (p >=~ q) x where - type PP (p >=~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CGe p q)) - -data p ==~ q -infix 4 ==~ - -instance P (CmpI 'CEq p q) x => P (p ==~ q) x where - type PP (p ==~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CEq p q)) - -data p <=~ q -infix 4 <=~ - -instance P (CmpI 'CLe p q) x => P (p <=~ q) x where - type PP (p <=~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CLe p q)) - -data p <~ q -infix 4 <~ - -instance P (CmpI 'CLt p q) x => P (p <~ q) x where - type PP (p <~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CLt p q)) - -data p /=~ q -infix 4 /=~ - -instance P (CmpI 'CNe p q) x => P (p /=~ q) x where - type PP (p /=~ q) x = Bool - eval _ = evalBool (Proxy @(CmpI 'CNe p q)) - - -class GetBinOp (k :: BinOp) where - getBinOp :: (Num a, a ~ b) => (String, a -> b -> a) - -instance GetBinOp 'BMult where - getBinOp = ("*",(*)) -instance GetBinOp 'BSub where - getBinOp = ("-",(-)) -instance GetBinOp 'BAdd where - getBinOp = ("+",(+)) - --- | addition, multiplication and subtraction --- --- >>> pz @(Fst Id * Snd Id) (13,5) --- PresentT 65 --- --- >>> pz @(Fst Id + 4 * Length (Snd Id) - 4) (3,"hello") --- PresentT 19 --- -data Bin (op :: BinOp) p q - -instance (GetBinOp op - , PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Num (PP p a) - ) => P (Bin op p q) a where - type PP (Bin op p q) a = PP p a - eval _ opts a = do - let (s,f) = getBinOp @op - lr <- runPQ s (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p `f` q - in mkNode opts (PresentT d) (show p <> " " <> s <> " " <> show q <> " = " <> show d) [hh pp, hh qq] - --- | fractional division --- --- >>> pz @(Fst Id / Snd Id) (13,2) --- PresentT 6.5 --- --- >>> pz @(ToRational 13 / Id) 0 --- FailT "(/) zero denominator" --- --- >>> pz @(12 % 7 / 14 % 5 + Id) 12.4 --- PresentT (3188 % 245) --- -data p / q -infixl 7 / - -instance (PP p a ~ PP q a - , Eq (PP q a) - , P p a - , P q a - , Show (PP p a) - , Fractional (PP p a) - ) => P (p / q) a where - type PP (p / q) a = PP p a - eval _ opts a = do - let msg0 = "(/)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) - | q == 0 -> let msg1 = msg0 <> " zero denominator" - in mkNode opts (FailT msg1) msg1 [hh pp, hh qq] - | otherwise -> - let d = p / q - in mkNode opts (PresentT d) (show p <> " / " <> show q <> " = " <> show d) [hh pp, hh qq] - --- | creates a 'Rational' value --- --- >>> pz @(Id < 21 % 5) (-3.1) --- TrueT --- --- >>> pz @(Id < 21 % 5) 4.5 --- FalseT --- --- >>> pz @(Fst Id % Snd Id) (13,2) --- PresentT (13 % 2) --- --- >>> pz @(13 % Id) 0 --- FailT "(%) zero denominator" --- --- >>> pz @(4 % 3 + 5 % 7) "asfd" --- PresentT (43 % 21) --- --- >>> pz @(4 -% 7 * 5 -% 3) "asfd" --- PresentT (20 % 21) --- --- >>> pz @(Negate (14 % 3)) () --- PresentT ((-14) % 3) --- --- >>> pz @(14 % 3) () --- PresentT (14 % 3) --- --- >>> pz @(Negate (14 % 3) ==! FromIntegral _ (Negate 5)) () --- PresentT GT --- --- >>> pz @(14 -% 3 ==! 5 -% 1) "aa" --- PresentT GT --- --- >>> pz @(Negate (14 % 3) ==! Negate 5 % 2) () --- PresentT LT --- --- >>> pz @(14 -% 3 * 5 -% 1) () --- PresentT (70 % 3) --- --- >>> pz @(14 % 3 ==! 5 % 1) () --- PresentT LT --- --- >>> pz @(15 % 3 / 4 % 2) () --- PresentT (5 % 2) --- -data p % q -infixl 8 % - -instance (Integral (PP p x) - , Integral (PP q x) - , Eq (PP q x) - , P p x - , P q x - , Show (PP p x) - , Show (PP q x) - ) => P (p % q) x where - type PP (p % q) x = Rational - eval _ opts x = do - let msg0 = "(%)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) - | q == 0 -> let msg1 = msg0 <> " zero denominator" - in mkNode opts (FailT msg1) msg1 [hh pp, hh qq] - | otherwise -> - let d = fromIntegral p % fromIntegral q - in mkNode opts (PresentT d) (show p <> " % " <> show q <> " = " <> show d) [hh pp, hh qq] - -data p -% q -- = Negate (p % q) -infixl 8 -% -type NegateRatioT p q = Negate (p % q) - -instance P (NegateRatioT p q) x => P (p -% q) x where - type PP (p -% q) x = PP (NegateRatioT p q) x - eval _ = eval (Proxy @(NegateRatioT p q)) - - --- | similar to 'negate' --- --- >>> pz @(Negate Id) 14 --- PresentT (-14) --- --- >>> pz @(Negate (Fst Id * Snd Id)) (14,3) --- PresentT (-42) --- --- >>> pz @(Negate (15 -% 4)) "abc" --- PresentT (15 % 4) --- --- >>> pz @(Negate (15 % 3)) () --- PresentT ((-5) % 1) --- --- >>> pz @(Negate (Fst Id % Snd Id)) (14,3) --- PresentT ((-14) % 3) --- -data Negate p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Negate p) x where - type PP (Negate p) x = PP p x - eval _ opts x = do - let msg0 = "Negate" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = negate p - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - - --- | similar to 'abs' --- --- >>> pz @(Abs Id) (-14) --- PresentT 14 --- --- >>> pz @(Abs (Snd Id)) ("xx",14) --- PresentT 14 --- --- >>> pz @(Abs Id) 0 --- PresentT 0 --- --- >>> pz @(Abs (Negate 44)) "aaa" --- PresentT 44 --- -data Abs p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Abs p) x where - type PP (Abs p) x = PP p x - eval _ opts x = do - let msg0 = "Abs" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = abs p - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - - - --- | similar to 'signum' --- --- >>> pz @(Signum Id) (-14) --- PresentT (-1) --- --- >>> pz @(Signum Id) 14 --- PresentT 1 --- --- >>> pz @(Signum Id) 0 --- PresentT 0 --- -data Signum p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Signum p) x where - type PP (Signum p) x = PP p x - eval _ opts x = do - let msg0 = "Signum" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = signum p - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | unwraps a value (see '_Wrapped'') --- --- >>> pz @(Unwrap Id) (SG.Sum (-13)) --- PresentT (-13) --- -data Unwrap p - -instance (PP p x ~ s - , P p x - , Show s - , Show (Unwrapped s) - , Wrapped s - ) => P (Unwrap p) x where - type PP (Unwrap p) x = Unwrapped (PP p x) - eval _ opts x = do - let msg0 = "Unwrap" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = p ^. _Wrapped' - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | wraps a value (see '_Wrapped'' and '_Unwrapped'') --- --- >>> :m + Data.List.NonEmpty --- >>> pz @(Wrap (SG.Sum _) Id) (-13) --- PresentT (Sum {getSum = -13}) --- --- >>> pz @(Wrap SG.Any (Ge 4)) 13 --- PresentT (Any {getAny = True}) --- --- >>> pz @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" --- PresentT ('a' :| "bcd") --- -data Wrap' t p - -instance (Show (PP p x) - , P p x - , Unwrapped (PP s x) ~ PP p x - , Wrapped (PP s x) - , Show (PP s x) - ) => P (Wrap' s p) x where - type PP (Wrap' s p) x = PP s x - eval _ opts x = do - let msg0 = "Wrap" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = p ^. _Unwrapped' - in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - -data Wrap (t :: Type) p -type WrapT (t :: Type) p = Wrap' (Hole t) p - -instance P (WrapT t p) x => P (Wrap t p) x where - type PP (Wrap t p) x = PP (WrapT t p) x - eval _ = eval (Proxy @(WrapT t p)) --- | similar to 'coerce' --- --- >>> pz @(Coerce (SG.Sum Integer)) (Identity (-13)) --- PresentT (Sum {getSum = -13}) --- -data Coerce (t :: k) - -instance (Show a - , Show t - , Coercible t a - ) => P (Coerce t) a where - type PP (Coerce t) a = t - eval _ opts a = - let msg0 = "Coerce" - d = a ^. coerced - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d a) [] - --- can coerce over a functor: but need to provide type of 'a' and 't' explicitly - --- | see 'Coerce': coerce over a functor --- --- >>> pz @(Coerce2 (SG.Sum Integer)) [Identity (-13), Identity 4, Identity 99] --- PresentT [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] --- --- >>> pz @(Coerce2 (SG.Sum Integer)) (Just (Identity (-13))) --- PresentT (Just (Sum {getSum = -13})) --- --- >>> pz @(Coerce2 (SG.Sum Int)) (Nothing @(Identity Int)) --- PresentT Nothing --- -data Coerce2 (t :: k) -instance (Show (f a) - , Show (f t) - , Coercible t a - , Functor f - ) => P (Coerce2 t) (f a) where - type PP (Coerce2 t) (f a) = f t - eval _ opts fa = - let msg0 = "Coerce2" - d = view coerced <$> fa - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d fa) [] - --- | lift mempty over a Functor --- --- >>> pz @(MEmpty2 (SG.Product Int)) [Identity (-13), Identity 4, Identity 99] --- PresentT [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] --- -data MEmpty2' t - -instance (Show (f a) - , Show (f (PP t (f a))) - , Functor f - , Monoid (PP t (f a)) - ) => P (MEmpty2' t) (f a) where - type PP (MEmpty2' t) (f a) = f (PP t (f a)) - eval _ opts fa = - let msg0 = "MEmpty2" - b = mempty <$> fa - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b fa) [] - -data MEmpty2 (t :: Type) -type MEmpty2T (t :: Type) = MEmpty2' (Hole t) - -instance P (MEmpty2T t) x => P (MEmpty2 t) x where - type PP (MEmpty2 t) x = PP (MEmpty2T t) x - eval _ = eval (Proxy @(MEmpty2T t)) - --- | lift pure over a Functor --- --- >>> pz @(Pure2 (Either String)) [1,2,4] --- PresentT [Right 1,Right 2,Right 4] --- -data Pure2 (t :: Type -> Type) - -instance (Show (f (t a)) - , Show (f a) - , Applicative t - , Functor f - ) => P (Pure2 t) (f a) where - type PP (Pure2 t) (f a) = f (t a) - eval _ opts fa = - let msg0 = "Pure2" - b = fmap pure fa - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b fa) [] - --- | similar to 'reverse' --- --- >>> pz @Reverse [1,2,4] --- PresentT [4,2,1] --- --- >>> pz @Reverse "AbcDeF" --- PresentT "FeDcbA" --- -data Reverse - -instance (Show a, as ~ [a]) => P Reverse as where - type PP Reverse as = as - eval _ opts as = - let msg0 = "Reverse" - d = reverse as - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d as) [] - --- | reverses using 'reversing' --- --- >>> pz @ReverseL (T.pack "AbcDeF") --- PresentT "FeDcbA" --- --- >>> pz @ReverseL ("AbcDeF" :: String) --- PresentT "FeDcbA" --- -data ReverseL - -instance (Show t, Reversing t) => P ReverseL t where - type PP ReverseL t = t - eval _ opts as = - let msg0 = "ReverseL" - d = as ^. reversed - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d as) [] - --- | swaps using 'SwapC' --- --- >>> pz @Swap (Left 123) --- PresentT (Right 123) --- --- >>> pz @Swap (Right 123) --- PresentT (Left 123) --- --- >>> pz @Swap (These 'x' 123) --- PresentT (These 123 'x') --- --- >>> pz @Swap (This 'x') --- PresentT (That 'x') --- --- >>> pz @Swap (That 123) --- PresentT (This 123) --- --- >>> pz @Swap (123,'x') --- PresentT ('x',123) --- --- >>> pz @Swap (Left "abc") --- PresentT (Right "abc") --- --- >>> pz @Swap (Right 123) --- PresentT (Left 123) --- -data Swap - -class Bifunctor p => SwapC p where -- (p :: Type -> Type -> Type) where - swapC :: p a b -> p b a -instance SwapC Either where - swapC (Left a) = Right a - swapC (Right a) = Left a -instance SwapC These where - swapC (This a) = That a - swapC (That b) = This b - swapC (These a b) = These b a -instance SwapC (,) where - swapC (a,b) = (b,a) - -instance (Show (p a b) - , SwapC p - , Show (p b a) - ) => P Swap (p a b) where - type PP Swap (p a b) = p b a - eval _ opts pabx = - let msg0 = "Swap" - d = swapC pabx - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabx) [] - --- | assoc using 'AssocC' --- --- >>> pz @Assoc (This (These 123 'x')) --- PresentT (These 123 (This 'x')) --- --- >>> pz @Assoc ((99,'a'),True) --- PresentT (99,('a',True)) --- --- >>> pz @Assoc ((99,'a'),True) --- PresentT (99,('a',True)) --- --- >>> pz @Assoc (Right "Abc" :: Either (Either () ()) String) --- PresentT (Right (Right "Abc")) --- --- >>> pz @Assoc (Left (Left 'x')) --- PresentT (Left 'x') --- -data Assoc - -class AssocC p where - assoc :: p (p a b) c -> p a (p b c) - unassoc :: p a (p b c) -> p (p a b) c -instance AssocC Either where - assoc (Left (Left a)) = Left a - assoc (Left (Right b)) = Right (Left b) - assoc (Right b) = Right (Right b) - unassoc (Left a) = Left (Left a) - unassoc (Right (Left b)) = Left (Right b) - unassoc (Right (Right b)) = Right b -instance AssocC These where - assoc (This (This a)) = This a - assoc (This (That b)) = That (This b) - assoc (That b) = That (That b) - assoc (These (This a) c) = These a (That c) - assoc (These (That b) c) = That (These b c) - assoc (These (These a b) c) = These a (These b c) - assoc (This (These a b)) = These a (This b) - unassoc (This a) = This (This a) - unassoc (That (This b)) = This (That b) - unassoc (That (That b)) = That b - unassoc (These a (That c)) = These (This a) c - unassoc (That (These b c)) = These (That b) c - unassoc (These a (These b c)) = These (These a b) c - unassoc (These a (This b)) = This (These a b) - --- copied from Data.These -partitionThese :: [These a b] -> ([a], [b], [(a, b)]) -partitionThese [] = ([], [], []) -partitionThese (t:ts) = case t of - This x -> (x : xs, ys, xys) - That y -> ( xs, y : ys, xys) - These x y -> ( xs, ys, (x,y) : xys) - where - ~(xs,ys,xys) = partitionThese ts - -instance AssocC (,) where - assoc ((a,b),c) = (a,(b,c)) - unassoc (a,(b,c)) = ((a,b),c) - -instance (Show (p (p a b) c) - , Show (p a (p b c)) - , AssocC p - ) => P Assoc (p (p a b) c) where - type PP Assoc (p (p a b) c) = p a (p b c) - eval _ opts pabc = - let msg0 = "Assoc" - d = assoc pabc - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabc) [] - --- | unassoc using 'AssocC' --- --- >>> pz @Unassoc (These 123 (This 'x')) --- PresentT (This (These 123 'x')) --- --- >>> pz @Unassoc (99,('a',True)) --- PresentT ((99,'a'),True) --- --- >>> pz @Unassoc (This 10 :: These Int (These Bool ())) --- PresentT (This (This 10)) --- --- >>> pz @Unassoc (Right (Right 123)) --- PresentT (Right 123) --- --- >>> pz @Unassoc (Left 'x' :: Either Char (Either Bool Double)) --- PresentT (Left (Left 'x')) --- -data Unassoc - -instance (Show (p (p a b) c) - , Show (p a (p b c)) - , AssocC p - ) => P Unassoc (p a (p b c)) where - type PP Unassoc (p a (p b c)) = p (p a b) c - eval _ opts pabc = - let msg0 = "Unassoc" - d = unassoc pabc - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabc) [] - --- | bounded 'succ' function --- --- >>> pz @(SuccB' Id) (13 :: Int) --- PresentT 14 --- --- >>> pz @(SuccB' Id) LT --- PresentT EQ --- --- >>> pz @(SuccB 'LT Id) GT --- PresentT LT --- --- >>> pz @(SuccB' Id) GT --- FailT "Succ bounded" --- -instance (PP q x ~ a - , P q x - , P p (Proxy a) - , PP p (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (SuccB p q) x where - type PP (SuccB p q) x = PP q x - eval _ opts x = do - let msg0 = "SuccB" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case succMay q of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @p) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh qq, hh pp] - Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n q) [hh qq] - -data SuccB p q - -data SuccB' q -type SuccBT' q = SuccB (Failp "Succ bounded") q - -instance P (SuccBT' q) x => P (SuccB' q) x where - type PP (SuccB' q) x = PP (SuccBT' q) x - eval _ = eval (Proxy @(SuccBT' q)) - --- | bounded 'pred' function --- --- >>> pz @(PredB' Id) (13 :: Int) --- PresentT 12 --- --- >>> pz @(PredB' Id) LT --- FailT "Pred bounded" --- -data PredB' q -type PredBT' q = PredB (Failp "Pred bounded") q - -instance (PP q x ~ a - , P q x - , P p (Proxy a) - , PP p (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (PredB p q) x where - type PP (PredB p q) x = PP q x - eval _ opts x = do - let msg0 = "PredB" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case predMay q of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @p) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh qq, hh pp] - Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n q) [hh qq] - - --- | unbounded 'succ' function --- --- >>> pz @(Succ Id) 13 --- PresentT 14 --- --- >>> pz @(Succ Id) LT --- PresentT EQ --- --- >>> pz @(Succ Id) GT --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" --- -data Succ p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (Succ p) x where - type PP (Succ p) x = PP p x - eval _ opts x = do - let msg0 = "Succ" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (succ p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (msg0 <> show0 opts " " p) [hh pp] - Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] - - --- | unbounded 'pred' function --- --- >>> pz @(Pred Id) 13 --- PresentT 12 --- --- >>> pz @(Pred Id) LT --- FailT "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" --- - -data Pred p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (Pred p) x where - type PP (Pred p) x = PP p x - eval _ opts x = do - let msg0 = "Pred" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (pred p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (msg0 <> show0 opts " " p) [hh pp] - Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] - -data PredB p q - -instance P (PredBT' q) x => P (PredB' q) x where - type PP (PredB' q) x = PP (PredBT' q) x - eval _ = eval (Proxy @(PredBT' q)) - - --- | 'fromEnum' function --- --- >>> pz @(FromEnum Id) 'x' --- PresentT 120 --- -data FromEnum p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (FromEnum p) x where - type PP (FromEnum p) x = Int - eval _ opts x = do - let msg0 = "FromEnum" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let n = fromEnum p - in mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] - --- | unsafe 'toEnum' function --- --- >>> pz @(ToEnum Char Id) 120 --- PresentT 'x' -data ToEnum' t p - -instance (PP p x ~ a - , P p x - , Show a - , Enum (PP t x) - , Show (PP t x) - , Integral a - ) => P (ToEnum' t p) x where - type PP (ToEnum' t p) x = PP t x - eval _ opts x = do - let msg0 = "ToEnum" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (msg0 <> show0 opts " " p) [hh pp] - Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] - -data ToEnum (t :: Type) p -type ToEnumT (t :: Type) p = ToEnum' (Hole t) p - -instance P (ToEnumT t p) x => P (ToEnum t p) x where - type PP (ToEnum t p) x = PP (ToEnumT t p) x - eval _ = eval (Proxy @(ToEnumT t p)) --- | bounded 'toEnum' function --- --- >>> pz @(ToEnumBDef Ordering LT) 2 --- PresentT GT --- --- >>> pz @(ToEnumBDef Ordering LT) 6 --- PresentT LT --- --- >>> pz @(ToEnumBFail Ordering) 6 --- FailT "ToEnum bounded" --- -data ToEnumBDef' t def - -instance (P def (Proxy (PP t a)) - , PP def (Proxy (PP t a)) ~ PP t a - , Show a - , Show (PP t a) - , Bounded (PP t a) - , Enum (PP t a) - , Integral a - ) => P (ToEnumBDef' t def) a where - type PP (ToEnumBDef' t def) a = PP t a - eval _ opts a = do - let msg0 = "ToEnumBDef" - case toEnumMay $ fromIntegral a of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @def) opts (Proxy @(PP t a)) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh pp] - Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n a) [] - -data ToEnumBDef (t :: Type) def -type ToEnumBDefT (t :: Type) def = ToEnumBDef' (Hole t) def - -instance P (ToEnumBDefT t def) x => P (ToEnumBDef t def) x where - type PP (ToEnumBDef t def) x = PP (ToEnumBDefT t def) x - eval _ = eval (Proxy @(ToEnumBDefT t def)) - -data ToEnumBFail (t :: Type) -type ToEnumBFailT (t :: Type) = ToEnumBDef' (Hole t) (Failp "ToEnum bounded") - -instance P (ToEnumBFailT t) x => P (ToEnumBFail t) x where - type PP (ToEnumBFail t) x = PP (ToEnumBFailT t) x - eval _ = eval (Proxy @(ToEnumBFailT t)) - --- | a predicate on prime numbers --- --- >>> pz @(Prime Id) 2 --- TrueT --- --- >>> pz @(Map '(Id,Prime Id) Id) [0..12] --- PresentT [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] --- -data Prime p - -instance (PP p x ~ a - , P p x - , Show a - , Integral a - ) => P (Prime p) x where - type PP (Prime p) x = Bool - eval _ opts x = do - let msg0 = "Prime" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = p > 1 && isPrime (fromIntegral p) - in mkNodeB opts b (msg0 <> show1 opts " | " p) [hh pp] - --- | get the next prime number --- --- >>> pz @(PrimeNext Id) 6 --- PresentT 7 --- --- >>> pz @(IterateN 4 (PrimeNext Id)) 3 --- PresentT [3,5,7,11] --- -data PrimeNext p - -instance (PP p x ~ a - , P p x - , Show a - , Integral a - ) => P (PrimeNext p) x where - type PP (PrimeNext p) x = Int - eval _ opts x = do - let msg0 = "PrimeNext" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let ret = head $ dropWhile (not . isPrime) [max 0 (fromIntegral p + 1) ..] - in mkNode opts (PresentT ret) (msg0 <> show1 opts " | " p) [hh pp] - --- empty lists at the type level wont work here - --- | filters a list \'q\' keeping or removing those elements in \'p\' --- --- >>> pz @(Keep '[5] '[1,5,5,2,5,2]) () --- PresentT [5,5,5] --- --- >>> pz @(Keep '[0,1,1,5] '[1,5,5,2,5,2]) () --- PresentT [1,5,5,5] --- --- >>> pz @(Remove '[5] '[1,5,5,2,5,2]) () --- PresentT [1,2,2] --- --- >>> pz @(Remove '[0,1,1,5] '[1,5,5,2,5,2]) () --- PresentT [2,2] --- --- >>> pz @(Remove '[99] '[1,5,5,2,5,2]) () --- PresentT [1,5,5,2,5,2] --- --- >>> pz @(Remove '[99,91] '[1,5,5,2,5,2]) () --- PresentT [1,5,5,2,5,2] --- --- >>> pz @(Remove Id '[1,5,5,2,5,2]) [] --- PresentT [1,5,5,2,5,2] --- --- >>> pz @(Remove '[] '[1,5,5,2,5,2]) 44 -- works if you make this a number! --- PresentT [1,5,5,2,5,2] --- -data KeepImpl (keep :: Bool) p q - -instance (GetBool keep - , Eq a - , Show a - , P p x - , P q x - , PP p x ~ PP q x - , PP q x ~ [a] - ) => P (KeepImpl keep p q) x where - type PP (KeepImpl keep p q) x = PP q x - eval _ opts x = do - let msg0 = if keep then "Keep" else "Remove" - keep = getBool @keep - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let ret = filter (bool not id keep . (`elem` p)) q - in mkNode opts (PresentT ret) (show01' opts msg0 ret "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - -data Keep p q -type KeepT p q = KeepImpl 'True p q - -instance P (KeepT p q) x => P (Keep p q) x where - type PP (Keep p q) x = PP (KeepT p q) x - eval _ = eval (Proxy @(KeepT p q)) - -data Remove p q -type RemoveT p q = KeepImpl 'False p q - -instance P (RemoveT p q) x => P (Remove p q) x where - type PP (Remove p q) x = PP (RemoveT p q) x - eval _ = eval (Proxy @(RemoveT p q)) - --- | 'elem' function --- --- >>> pz @(Elem (Fst Id) (Snd Id)) ('x',"abcdxy") --- TrueT --- --- >>> pz @(Elem (Fst Id) (Snd Id)) ('z',"abcdxy") --- FalseT --- -data Elem p q - -instance ([PP p a] ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Eq (PP p a) - ) => P (Elem p q) a where - type PP (Elem p q) a = Bool - eval _ opts a = do - let msg0 = "Elem" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `elem` q - in mkNodeB opts b (show p <> " `elem` " <> show q) [hh pp, hh qq] - ---type Head' p = HeadFail "Head(empty)" p ---type Tail' p = TailFail "Tail(empty)" p ---type Last p = LastFail "Last(empty)" p ---type Init' p = InitFail "Init(empty)" p - --- | similar to fmap fst --- --- >>> pz @FMapFst (Just (13,"Asf")) --- PresentT (Just 13) --- --- to make this work we grab the fst or snd out of the Maybe so it is a head or not/ is a tail or not etc! --- we still have access to the whole original list so we dont lose anything! -data FMapFst - -instance Functor f => P FMapFst (f (a,x)) where - type PP FMapFst (f (a,x)) = f a - eval _ opts mb = pure $ mkNode opts (PresentT (fst <$> mb)) "FMapFst" [] - --- | similar to fmap snd --- --- >>> pz @FMapSnd (Just ("asf",13)) --- PresentT (Just 13) --- -data FMapSnd - -instance Functor f => P FMapSnd (f (x,a)) where - type PP FMapSnd (f (x,a)) = f a - eval _ opts mb = pure $ mkNode opts (PresentT (snd <$> mb)) "FMapSnd" [] - --- | takes the head or default of a list-like object --- --- see 'ConsT' for other supported types eg 'Seq.Seq' --- --- >>> pz @(HeadDef 444 Id) [] --- PresentT 444 --- --- >>> pz @(HeadDef 444 Id) [1..5] --- PresentT 1 --- --- >>> pz @(HeadDef 444 Id) [1..5] --- PresentT 1 --- --- >>> pz @(HeadDef (Char1 "w") Id) (Seq.fromList "abcdef") --- PresentT 'a' --- --- >>> pz @(HeadDef (Char1 "w") Id) Seq.empty --- PresentT 'w' --- --- >>> :set -XFlexibleContexts --- >>> pz @(HeadDef (MEmptyT _) Id) ([] :: [SG.Sum Int]) --- PresentT (Sum {getSum = 0}) --- --- >>> pz @(HeadDef (MEmptyT String) '[ "abc","def","asdfadf" ]) () --- PresentT "abc" --- --- >>> pz @(HeadDef (MEmptyT _) (Snd Id)) (123,[ "abc","def","asdfadf" ]) --- PresentT "abc" --- --- >>> pz @(HeadDef (MEmptyT _) (Snd Id)) (123,[]) --- PresentT () --- -data HeadDef p q -type HeadDefT p q = JustDef p (q >> Uncons >> FMapFst) - -instance P (HeadDefT p q) x => P (HeadDef p q) x where - type PP (HeadDef p q) x = PP (HeadDefT p q) x - eval _ = eval (Proxy @(HeadDefT p q)) - - --- | takes the head of a list or fail --- --- see 'ConsT' for other supported types eg 'Seq.Seq' --- --- >>> pz @(HeadFail "dude" Id) [ "abc","def","asdfadf" ] --- PresentT "abc" --- --- >>> pz @(HeadFail "empty list" Id) [] --- FailT "empty list" --- -data HeadFail msg q -type HeadFailT msg q = JustFail msg (q >> Uncons >> FMapFst) - -instance P (HeadFailT msg q) x => P (HeadFail msg q) x where - type PP (HeadFail msg q) x = PP (HeadFailT msg q) x - eval _ = eval (Proxy @(HeadFailT msg q)) - -data TailDef p q -type TailDefT p q = JustDef p (q >> Uncons >> FMapSnd) - -instance P (TailDefT p q) x => P (TailDef p q) x where - type PP (TailDef p q) x = PP (TailDefT p q) x - eval _ = eval (Proxy @(TailDefT p q)) - - -data TailFail msg q -type TailFailT msg q = JustFail msg (q >> Uncons >> FMapSnd) - -instance P (TailFailT msg q) x => P (TailFail msg q) x where - type PP (TailFail msg q) x = PP (TailFailT msg q) x - eval _ = eval (Proxy @(TailFailT msg q)) - - -data LastDef p q -type LastDefT p q = JustDef p (q >> Unsnoc >> FMapSnd) - -instance P (LastDefT p q) x => P (LastDef p q) x where - type PP (LastDef p q) x = PP (LastDefT p q) x - eval _ = eval (Proxy @(LastDefT p q)) - -data LastFail msg q -type LastFailT msg q = JustFail msg (q >> Unsnoc >> FMapSnd) - -instance P (LastFailT msg q) x => P (LastFail msg q) x where - type PP (LastFail msg q) x = PP (LastFailT msg q) x - eval _ = eval (Proxy @(LastFailT msg q)) - -data InitDef p q -type InitDefT p q = JustDef p (q >> Unsnoc >> FMapFst) - -instance P (InitDefT p q) x => P (InitDef p q) x where - type PP (InitDef p q) x = PP (InitDefT p q) x - eval _ = eval (Proxy @(InitDefT p q)) - -data InitFail msg q -type InitFailT msg q = JustFail msg (q >> Unsnoc >> FMapFst) - -instance P (InitFailT msg q) x => P (InitFail msg q) x where - type PP (InitFail msg q) x = PP (InitFailT msg q) x - eval _ = eval (Proxy @(InitFailT msg q)) - -data LookupDef' v w p q -type LookupDefT' v w p q = JustDef p (q >> Lookup v w) - -instance P (LookupDefT' v w p q) x => P (LookupDef' v w p q) x where - type PP (LookupDef' v w p q) x = PP (LookupDefT' v w p q) x - eval _ = eval (Proxy @(LookupDefT' v w p q)) - -data LookupFail' msg v w q -type LookupFailT' msg v w q = JustFail msg (q >> Lookup v w) - -instance P (LookupFailT' msg v w q) x => P (LookupFail' msg v w q) x where - type PP (LookupFail' msg v w q) x = PP (LookupFailT' msg v w q) x - eval _ = eval (Proxy @(LookupFailT' msg v w q)) - -data LookupDef v w p -type LookupDefT v w p = LookupDef' v w p I - -instance P (LookupDefT v w p) x => P (LookupDef v w p) x where - type PP (LookupDef v w p) x = PP (LookupDefT v w p) x - eval _ = eval (Proxy @(LookupDefT v w p)) - -data LookupFail msg v w -type LookupFailT msg v w = LookupFail' msg v w I - -instance P (LookupFailT msg v w) x => P (LookupFail msg v w) x where - type PP (LookupFail msg v w) x = PP (LookupFailT msg v w) x - eval _ = eval (Proxy @(LookupFailT msg v w)) - ---type Just' p = JustFail "expected Just" p -data Left' p -type LeftT' p = LeftFail "expected Left" p - -instance P (LeftT' p) x => P (Left' p) x where - type PP (Left' p) x = PP (LeftT' p) x - eval _ = eval (Proxy @(LeftT' p)) - -data Right' p -type RightT' p = RightFail "expected Right" p - -instance P (RightT' p) x => P (Right' p) x where - type PP (Right' p) x = PP (RightT' p) x - eval _ = eval (Proxy @(RightT' p)) - -data This' p -type ThisT' p = ThisFail "expected This" p - -instance P (ThisT' p) x => P (This' p) x where - type PP (This' p) x = PP (ThisT' p) x - eval _ = eval (Proxy @(ThisT' p)) - -data That' p -type ThatT' p = ThatFail "expected That" p - -instance P (ThatT' p) x => P (That' p) x where - type PP (That' p) x = PP (ThatT' p) x - eval _ = eval (Proxy @(ThatT' p)) - -data These' p -type TheseT' p = TheseFail "expected These" p - -instance P (TheseT' p) x => P (These' p) x where - type PP (These' p) x = PP (TheseT' p) x - eval _ = eval (Proxy @(TheseT' p)) - - --- | similar to 'Control.Arrow.|||' but additionally gives \'p\' and \'q\' the original input --- --- >>> pz @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Left 123) --- PresentT "132" --- --- >>> pz @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Right 'x') --- PresentT "((9,Right 'x'),'x')" --- --- >>> pz @(EitherX (ShowP Id) (ShowP (Second (Succ Id))) (Snd Id)) (9,Right 'x') --- PresentT "((9,Right 'x'),'y')" --- -data EitherX p q r -instance (P r x - , P p (x,a) - , P q (x,b) - , PP r x ~ Either a b - , PP p (x,a) ~ c - , PP q (x,b) ~ c - ) => P (EitherX p q r) x where - type PP (EitherX p q r) x = EitherXT (PP r x) x p - eval _ opts x = do - let msg0 = "EitherX" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right (Left a) -> do - let msg1 = msg0 <> "(Left)" - pp <- eval (Proxy @p) opts (x,a) - pure $ case getValueLR opts msg1 pp [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh rr, hh pp] - Right (Right b) -> do - let msg1 = msg0 <> "(Right)" - qq <- eval (Proxy @q) opts (x,b) - pure $ case getValueLR opts msg1 qq [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool qq) msg1 [hh rr, hh qq] - -type family EitherXT lr x p where - EitherXT (Either a b) x p = PP p (x,a) - EitherXT o _ _ = GL.TypeError ( - 'GL.Text "EitherXT: expected 'Either a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - --- | similar to 'Data.These.mergeTheseWith' but additionally provides \'p\', '\q'\ and \'r\' the original input as the first element in the tuple --- --- >>> pz @(TheseX ((Fst (Fst Id) + Snd Id) >> ShowP Id) (ShowP Id) (Snd (Snd Id)) (Snd Id)) (9,This 123) --- PresentT "132" --- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (This 123) --- PresentT (123,"fromthis") --- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (That "fromthat") --- PresentT (-99,"fromthat") --- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (These 123 "fromthese") --- PresentT (123,"fromthese") --- -data TheseX p q r s - -instance (P s x - , P p (x,a) - , P q (x,b) - , P r (x,(a,b)) - , PP s x ~ These a b - , PP p (x,a) ~ c - , PP q (x,b) ~ c - , PP r (x,(a,b)) ~ c - ) => P (TheseX p q r s) x where - type PP (TheseX p q r s) x = TheseXT (PP s x) x p - eval _ opts x = do - let msg0 = "TheseX" - ss <- eval (Proxy @s) opts x - case getValueLR opts msg0 ss [] of - Left e -> pure e - Right (This a) -> do - let msg1 = msg0 <> "(This)" - pp <- eval (Proxy @p) opts (x,a) - pure $ case getValueLR opts msg1 pp [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh ss, hh pp] - Right (That b) -> do - let msg1 = msg0 <> "(That)" - qq <- eval (Proxy @q) opts (x,b) - pure $ case getValueLR opts msg1 qq [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool qq) msg1 [hh ss, hh qq] - Right (These a b) -> do - let msg1 = msg0 <> "(These)" - rr <- eval (Proxy @r) opts (x,(a,b)) - pure $ case getValueLR opts msg1 rr [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool rr) msg1 [hh ss, hh rr] - -type family TheseXT lr x p where - TheseXT (These a b) x p = PP p (x,a) - --- | similar to 'maybe' --- --- provides a Proxy to the result of \'q\' but does not provide the surrounding context --- --- >>> pz @(MaybeIn "foundnothing" (ShowP (Pred Id))) (Just 20) --- PresentT "19" --- --- >>> pz @(MaybeIn "found nothing" (ShowP (Pred Id))) Nothing --- PresentT "found nothing" --- -data MaybeIn p q - --- tricky: the nothing case is the proxy of PP q a: ie proxy of the final result -instance (P q a - , Show a - , Show (PP q a) - , PP p (Proxy (PP q a)) ~ PP q a - , P p (Proxy (PP q a)) - ) => P (MaybeIn p q) (Maybe a) where - type PP (MaybeIn p q) (Maybe a) = PP q a - eval _ opts ma = do - let msg0 = "MaybeIn" - case ma of - Nothing -> do - let msg1 = msg0 <> "(Nothing)" - pp <- eval (Proxy @p) opts (Proxy @(PP q a)) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) (msg1 <> show0 opts " " b <> " | Proxy") [hh pp] - Just a -> do - let msg1 = msg0 <> "(Nothing)" - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg1 qq [] of - Left e -> e - Right b -> mkNode opts (_tBool qq) (show01 opts msg1 b a) [hh qq] - --- | similar to 'isJust' --- --- >>> pz @(IsJust Id) Nothing --- FalseT --- --- >>> pz @(IsJust Id) (Just 'a') --- TrueT --- -data IsJust p - -instance (P p x, PP p x ~ Maybe a) => P (IsJust p) x where - type PP (IsJust p) x = Bool - eval _ opts x = do - let msg0 = "IsJust" - pp <- eval (Proxy @p) opts x - let hhs = [hh pp] - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (Just _) -> mkNodeB opts True msg0 hhs - Right Nothing -> mkNodeB opts False msg0 hhs - --- | similar to 'isNothing' --- --- >>> pz @(IsNothing Id) (Just 123) --- FalseT --- --- >>> pz @(IsNothing Id) Nothing --- TrueT --- -data IsNothing p - -instance (P p x, PP p x ~ Maybe a) => P (IsNothing p) x where - type PP (IsNothing p) x = Bool - eval _ opts x = do - let msg0 = "IsNothing" - pp <- eval (Proxy @p) opts x - let hhs = [hh pp] - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (Just _) -> mkNodeB opts False msg0 hhs - Right Nothing -> mkNodeB opts True msg0 hhs - -data MapMaybe p q -type MapMaybeT p q = ConcatMap (p >> MaybeIn MEmptyP '[Id]) q - -instance P (MapMaybeT p q) x => P (MapMaybe p q) x where - type PP (MapMaybe p q) x = PP (MapMaybeT p q) x - eval _ = eval (Proxy @(MapMaybeT p q)) - --- | similar to 'Data.Either.catMaybes' --- --- >>> pl @(CatMaybes Id) [Just 'a',Nothing,Just 'c',Just 'd',Nothing] --- Present "acd" (Concat "acd" | ["a","","c","d",""]) --- PresentT "acd" --- -data CatMaybes q -type CatMaybesT q = MapMaybe Id q - -instance P (CatMaybesT q) x => P (CatMaybes q) x where - type PP (CatMaybes q) x = PP (CatMaybesT q) x - eval _ = eval (Proxy @(CatMaybesT q)) - --- | similar to 'SG.stimes' --- --- >>> pz @(STimes 4 Id) (SG.Sum 3) --- PresentT (Sum {getSum = 12}) --- --- >>> pz @(STimes 4 Id) "ab" --- PresentT "abababab" --- -data STimes n p -instance (P n a - , Integral (PP n a) - , Semigroup (PP p a) - , P p a - , Show (PP p a) - ) => P (STimes n p) a where - type PP (STimes n p) a = PP p a - eval _ opts a = do - let msg0 = "STimes" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] - pure $ case lr of - Left e -> e - Right (fromIntegral -> (n::Int),p,pp,qq) -> - let msg1 = msg0 <> show0 opts " " n <> " p=" <> show p - b = SG.stimes n p - in mkNode opts (PresentT b) (show01' opts msg1 b "n=" n <> show1 opts " | " p) [hh pp, hh qq] - - --- | similar to 'pure' --- --- >>> pz @(Pure Maybe Id) 4 --- PresentT (Just 4) --- --- >>> pz @(Pure [] Id) 4 --- PresentT [4] --- --- >>> pz @(Pure (Either String) (Fst Id)) (13,True) --- PresentT (Right 13) --- -data Pure (t :: Type -> Type) p -instance (P p x - , Show (PP p x) - , Show (t (PP p x)) - , Applicative t - ) => P (Pure t p) x where - type PP (Pure t p) x = t (PP p x) - eval _ opts x = do - let msg0 = "Pure" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a -> - let b = pure a - in mkNode opts (PresentT b) (show01 opts msg0 b a) [hh pp] - --- type PMEmpty = MEmptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MEmptyP - --- | similar to 'mempty' --- --- >>> pz @(MEmptyT (SG.Sum Int)) () --- PresentT (Sum {getSum = 0}) --- --- no Monoid for Maybe a unless a is also a monoid but can use empty! -data MEmptyT' t -instance (Show (PP t a), Monoid (PP t a)) => P (MEmptyT' t) a where - type PP (MEmptyT' t) a = PP t a - eval _ opts _ = - let msg0 = "MEmptyT" - b = mempty @(PP t a) - in pure $ mkNode opts (PresentT b) (msg0 <> show0 opts " " b) [] - -data MEmptyT (t :: Type) -type MEmptyTT (t :: Type) = MEmptyT' (Hole t) - -instance P (MEmptyTT t) x => P (MEmptyT t) x where - type PP (MEmptyT t) x = PP (MEmptyTT t) x - eval _ = eval (Proxy @(MEmptyTT t)) - -data MEmptyP -type MEmptyPT = MEmptyT' Unproxy -- expects a proxy: so only some things work with this: eg MaybeIn - -instance P MEmptyPT x => P MEmptyP x where - type PP MEmptyP x = PP MEmptyPT x - eval _ = eval (Proxy @MEmptyPT) - --- | similar to 'empty' --- --- >>> pz @(EmptyT Maybe Id) () --- PresentT Nothing --- --- >>> pz @(EmptyT [] Id) () --- PresentT [] --- --- >>> pz @(EmptyT [] (Char1 "x")) (13,True) --- PresentT "" --- --- >>> pz @(EmptyT (Either String) (Fst Id)) (13,True) --- PresentT (Left "") --- -data EmptyT (t :: Type -> Type) p - -instance (P p x - , PP p x ~ a - , Show (t a) - , Show a - , Alternative t - ) => P (EmptyT t p) x where - type PP (EmptyT t p) x = t (PP p x) - eval _ opts x = do - let msg0 = "EmptyT" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = empty @t - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - -data MkNothing' t -- works always! MaybeBool is a good alternative and then dont need the extra 't' - --- for this to be useful has to have 't' else we end up with tons of problems -instance P (MkNothing' t) a where - type PP (MkNothing' t) a = Maybe (PP t a) - eval _ opts _ = - let msg0 = "MkNothing" - in pure $ mkNode opts (PresentT Nothing) msg0 [] - -data MkNothing (t :: Type) -type MkNothingT (t :: Type) = MkNothing' (Hole t) - -instance P (MkNothing t) x where - type PP (MkNothing t) x = PP (MkNothingT t) x - eval _ = eval (Proxy @(MkNothingT t)) - --- | 'GHC.Maybe.Just' constructor --- --- >>> pz @(MkJust Id) 44 --- PresentT (Just 44) --- -data MkJust p -instance (PP p x ~ a, P p x, Show a) => P (MkJust p) x where - type PP (MkJust p) x = Maybe (PP p x) - eval _ opts x = do - let msg0 = "MkJust" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Just p - in mkNode opts (PresentT d) (msg0 <> show0 opts " Just " p) [hh pp] - --- | 'Data.Either.Left' constructor --- --- >>> pz @(MkLeft _ Id) 44 --- PresentT (Left 44) --- -data MkLeft' t p - -instance (Show (PP p x), P p x) => P (MkLeft' t p) x where - type PP (MkLeft' t p) x = Either (PP p x) (PP t x) - eval _ opts x = do - let msg0 = "MkLeft" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Left p - in mkNode opts (PresentT d) (msg0 <> show0 opts " Left " p) [hh pp] - -data MkLeft (t :: Type) p -type MkLeftT (t :: Type) p = MkLeft' (Hole t) p - -instance P (MkLeftT t p) x => P (MkLeft t p) x where - type PP (MkLeft t p) x = PP (MkLeftT t p) x - eval _ = eval (Proxy @(MkLeftT t p)) - --- | 'Data.Either.Right' constructor --- --- >>> pz @(MkRight _ Id) 44 --- PresentT (Right 44) --- -data MkRight' t p - -instance (Show (PP p x), P p x) => P (MkRight' t p) x where - type PP (MkRight' t p) x = Either (PP t x) (PP p x) - eval _ opts x = do - let msg0 = "MkRight" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Right p - in mkNode opts (PresentT d) (msg0 <> show0 opts " Right " p) [hh pp] - -data MkRight (t :: Type) p -type MkRightT (t :: Type) p = MkRight' (Hole t) p - -instance P (MkRightT t p) x => P (MkRight t p) x where - type PP (MkRight t p) x = PP (MkRightT t p) x - eval _ = eval (Proxy @(MkRightT t p)) - --- | 'Data.These.This' constructor --- --- >>> pz @(MkThis _ Id) 44 --- PresentT (This 44) --- --- >>> pz @(Proxy Int >> MkThis' Unproxy 10) [] --- PresentT (This 10) --- -data MkThis' t p - -instance (Show (PP p x), P p x) => P (MkThis' t p) x where - type PP (MkThis' t p) x = These (PP p x) (PP t x) - eval _ opts x = do - let msg0 = "MkThis" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = This p - in mkNode opts (PresentT d) (msg0 <> show0 opts " This " p) [hh pp] - -data MkThis (t :: Type) p -type MkThisT (t :: Type) p = MkThis' (Hole t) p - -instance P (MkThisT t p) x => P (MkThis t p) x where - type PP (MkThis t p) x = PP (MkThisT t p) x - eval _ = eval (Proxy @(MkThisT t p)) - --- | 'Data.These.That' constructor --- --- >>> pz @(MkThat _ Id) 44 --- PresentT (That 44) --- -data MkThat' t p - -instance (Show (PP p x), P p x) => P (MkThat' t p) x where - type PP (MkThat' t p) x = These (PP t x) (PP p x) - eval _ opts x = do - let msg0 = "MkThat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = That p - in mkNode opts (PresentT d) (msg0 <> show0 opts " That " p) [hh pp] - -data MkThat (t :: Type) p -type MkThatT (t :: Type) p = MkThat' (Hole t) p - -instance P (MkThatT t p) x => P (MkThat t p) x where - type PP (MkThat t p) x = PP (MkThatT t p) x - eval _ = eval (Proxy @(MkThatT t p)) - --- type MkThat t p = MkThis t p >> Swap --- type MkThat' (t :: Type) = Pure (These t) Id -- t has to be a semigroup - --- | 'Data.These.These' constructor --- --- >>> pz @(MkThese (Fst Id) (Snd Id)) (44,'x') --- PresentT (These 44 'x') --- -data MkThese p q -instance (P p a - , P q a - , Show (PP p a) - , Show (PP q a) - ) => P (MkThese p q) a where - type PP (MkThese p q) a = These (PP p a) (PP q a) - eval _ opts a = do - let msg0 = "MkThese" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = These p q - in mkNode opts (PresentT d) (msg0 <> show0 opts " " d) [hh pp, hh qq] - --- | similar to 'mconcat' --- --- >>> pz @(MConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] --- PresentT (Sum {getSum = 59}) --- -data MConcat p - -instance (PP p x ~ [a] - , P p x - , Show a - , Monoid a - ) => P (MConcat p) x where - type PP (MConcat p) x = ExtractAFromList (PP p x) - eval _ opts x = do - let msg0 = "MConcat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = mconcat p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - --- | similar to a limited form of 'foldMap' --- --- >>> pz @(FoldMap (SG.Sum _) Id) [44, 12, 3] --- PresentT 59 --- --- >>> pz @(FoldMap (SG.Product _) Id) [44, 12, 3] --- PresentT 1584 --- --- >>> type Ands' p = FoldMap SG.All p --- >>> pz @(Ands' Id) [True,False,True,True] --- PresentT False --- --- >>> pz @(Ands' Id) [True,True,True] --- PresentT True --- --- >>> pz @(Ands' Id) [] --- PresentT True --- --- >>> type Ors' p = FoldMap SG.Any p --- >>> pz @(Ors' Id) [False,False,False] --- PresentT False --- --- >>> pz @(Ors' Id) [] --- PresentT False --- --- >>> pz @(Ors' Id) [False,False,False,True] --- PresentT True --- --- >>> type AllPositive' = FoldMap SG.All (Map Positive Id) --- >>> pz @AllPositive' [3,1,-5,10,2,3] --- PresentT False --- --- >>> type AllNegative' = FoldMap SG.All (Map Negative Id) --- >>> pz @AllNegative' [-1,-5,-10,-2,-3] --- PresentT True --- --- >>> :set -XKindSignatures --- >>> type Max' (t :: Type) = FoldMap (SG.Max t) Id -- requires t be Bounded for monoid instance --- >>> pz @(Max' Int) [10,4,5,12,3,4] --- PresentT 12 --- -data FoldMap (t :: Type) p -type FoldMapT (t :: Type) p = Map (Wrap t Id) p >> Unwrap (MConcat Id) - -instance P (FoldMapT t p) x => P (FoldMap t p) x where - type PP (FoldMap t p) x = PP (FoldMapT t p) x - eval _ = eval (Proxy @(FoldMapT t p)) - --- | similar to 'concat' --- --- >>> pz @(Concat Id) ["abc","D","eF","","G"] --- PresentT "abcDeFG" --- --- >>> pz @(Concat (Snd Id)) ('x',["abc","D","eF","","G"]) --- PresentT "abcDeFG" --- -data Concat p - -instance (Show a - , Show (t [a]) - , PP p x ~ t [a] - , P p x - , Foldable t - ) => P (Concat p) x where - type PP (Concat p) x = ExtractAFromTA (PP p x) - eval _ opts x = do - let msg0 = "Concat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = concat p - in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] - --- | similar to 'cycle' but for a fixed number \'n\' --- --- >>> pz @(Cycle 5 Id) [1,2] --- PresentT [1,2,1,2,1] --- -data Cycle n p - -instance (Show a - , Show (t a) - , PP p x ~ t a - , P p x - , Integral (PP n x) - , P n x - , Foldable t - ) => P (Cycle n p) x where - type PP (Cycle n p) x = [ExtractAFromTA (PP p x)] - eval _ opts x = do - let msg0 = "Cycle" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts x [] - pure $ case lr of - Left e -> e - Right (fromIntegral -> n,p,nn,pp) -> - let hhs = [hh nn, hh pp] - in case chkSize opts msg0 p hhs of - Left e -> e - Right () -> - let msg1 = msg0 <> "("<> show n <> ")" - d = take n (cycle (toList p)) - in mkNode opts (PresentT d) (show01 opts msg1 d p) hhs - -data ProxyT' t - -instance P (ProxyT' t) x where - type PP (ProxyT' t) x = Proxy (PP t x) - eval _ opts _ = - pure $ mkNode opts (PresentT Proxy) "ProxyT" [] - -data ProxyT (t :: Type) -type ProxyTT (t :: Type) = ProxyT' (Hole t) - -instance P (ProxyT t) x where - type PP (ProxyT t) x = PP (ProxyTT t) x - eval _ = eval (Proxy @(ProxyTT t)) - --- | similar to 'Data.List.!!' --- --- >>> pz @(Ix 4 "not found") ["abc","D","eF","","G"] --- PresentT "G" --- --- >>> pz @(Ix 40 "not found") ["abc","D","eF","","G"] --- PresentT "not found" --- -data Ix (n :: Nat) def - -instance (P def (Proxy a) - , PP def (Proxy a) ~ a - , KnownNat n - , Show a - ) => P (Ix n def) [a] where - type PP (Ix n def) [a] = a - eval _ opts as = do - let n = nat @n - msg0 = "Ix(" <> show n <> ")" - case as ^? ix n of - Nothing -> do - let msg1 = msg0 <> " not found" - pp <- eval (Proxy @def) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh pp] - Just a -> pure $ mkNode opts (PresentT a) (msg0 <> show0 opts " " a) [] - -data Ix' (n :: Nat) -type IxT' (n :: Nat) = Ix n (Failp "Ix index not found") - -instance P (IxT' n) x => P (Ix' n) x where - type PP (Ix' n) x = PP (IxT' n) x - eval _ = eval (Proxy @(IxT' n)) - --- | similar to 'Data.List.!!' leveraging 'Ixed' --- --- >>> pz @(IxL Id 2 "notfound") ["abc","D","eF","","G"] --- PresentT "eF" --- --- >>> pz @(IxL Id 20 "notfound") ["abc","D","eF","","G"] --- PresentT "notfound" --- -data IxL p q def -- p is the big value and q is the index and def is the default - -instance (P q a - , P p a - , Show (PP p a) - , Ixed (PP p a) - , PP q a ~ Index (PP p a) - , Show (Index (PP p a)) - , Show (IxValue (PP p a)) - , P r (Proxy (IxValue (PP p a))) - , PP r (Proxy (IxValue (PP p a))) ~ IxValue (PP p a) - ) - => P (IxL p q r) a where - type PP (IxL p q r) a = IxValue (PP p a) - eval _ opts a = do - let msg0 = "IxL" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" - in case p ^? ix q of - Nothing -> do - rr <- eval (Proxy @r) opts (Proxy @(IxValue (PP p a))) - pure $ case getValueLR opts msg1 rr [hh pp, hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool rr) (msg1 <> " index not found") [hh pp, hh qq] - Just ret -> pure $ mkNode opts (PresentT ret) (show01' opts msg1 ret "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - --- | similar to 'Data.List.!!' leveraging 'Ixed' --- --- >>> pz @(Id !! 2) ["abc","D","eF","","G"] --- PresentT "eF" --- --- >>> pz @(Id !! 20) ["abc","D","eF","","G"] --- FailT "(!!) index not found" --- --- >>> import qualified Data.Map.Strict as M --- >>> pz @(Id !! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) --- PresentT 2 --- -data p !! q -type BangBangT p q = IxL p q (Failp "(!!) index not found") - -instance P (BangBangT p q) a => P (p !! q) a where - type PP (p !! q) a = PP (BangBangT p q) a - eval _ = eval (Proxy @(BangBangT p q)) - --- | 'lookup' leveraging 'Ixed' --- --- >>> pz @(Lookup Id 2) ["abc","D","eF","","G"] --- PresentT (Just "eF") --- --- >>> pz @(Lookup Id 20) ["abc","D","eF","","G"] --- PresentT Nothing --- --- >>> pl @((Id !!? Char1 "d") > MkJust 99 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) --- False (False || False | (Just 4 > Just 99) || (4 <= 3)) --- FalseT --- --- >>> pz @((Id !!? Char1 "d") > MkJust 2 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) --- TrueT --- -data Lookup p q - -instance (P q a - , P p a - , Show (PP p a) - , Ixed (PP p a) - , PP q a ~ Index (PP p a) - , Show (Index (PP p a)) - , Show (IxValue (PP p a)) - ) - => P (Lookup p q) a where - type PP (Lookup p q) a = Maybe (IxValue (PP p a)) - eval _ opts a = do - let msg0 = "Lookup" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" - hhs = [hh pp, hh qq] - in case p ^? ix q of - Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " not found") hhs - Just ret -> mkNode opts (PresentT (Just ret)) (show01' opts msg1 ret "p=" p <> show1 opts " | q=" q) hhs - -data p !!? q -type BangBangQT p q = Lookup p q - -instance P (BangBangQT p q) a => P (p !!? q) a where - type PP (p !!? q) a = PP (BangBangQT p q) a - eval _ = eval (Proxy @(BangBangQT p q)) - - --- | 'Data.List.ands' --- --- >>> pz @(Ands Id) [True,True,True] --- TrueT --- --- >>> pl @(Ands Id) [True,True,True,False] --- False (Ands(4) i=3 | [True,True,True,False]) --- FalseT --- --- >>> pz @(Ands Id) [] --- TrueT --- -data Ands p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , a ~ Bool - ) => P (Ands p) x where - type PP (Ands p) x = Bool - eval _ opts x = do - let msg0 = "Ands" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let msg1 = msg0 ++ "(" ++ show (length p) ++ ")" - w = case findIndex not (toList p) of - Nothing -> "" - Just i -> " i="++show i - in mkNodeB opts (and p) (msg1 <> w <> show1 opts " | " p) [hh pp] - --- | 'Data.List.ors' --- --- >>> pz @(Ors Id) [False,False,False] --- FalseT --- --- >>> pl @(Ors Id) [True,True,True,False] --- True (Ors(4) i=0 | [True,True,True,False]) --- TrueT --- --- >>> pl @(Ors Id) [] --- False (Ors(0) | []) --- FalseT --- -data Ors p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , a ~ Bool - ) => P (Ors p) x where - type PP (Ors p) x = Bool - eval _ opts x = do - let msg0 = "Ors" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let msg1 = msg0 ++ "(" ++ show (length p) ++ ")" - w = case findIndex id (toList p) of - Nothing -> "" - Just i -> " i="++show i - in mkNodeB opts (or p) (msg1 <> w <> show1 opts " | " p) [hh pp] - - --- | similar to (++) --- --- >>> pz @(Fst Id ++ Snd Id) ([9,10,11],[1,2,3,4]) --- PresentT [9,10,11,1,2,3,4] --- --- >>> pz @(Snd Id ++ Fst Id) ([],[5]) --- PresentT [5] --- --- >>> pz @(Char1 "xyz" :+ W "ab" ++ W "cdefg") () --- PresentT "xabcdefg" --- --- >>> pz @([1,2,3] ++ EmptyList _) "somestuff" --- PresentT [1,2,3] --- -data p ++ q -infixr 5 ++ - -instance (P p x - , P q x - , Show (PP p x) - , PP p x ~ [a] - , PP q x ~ [a] - ) => P (p ++ q) x where - type PP (p ++ q) x = PP q x - eval _ opts z = do - let msg0 = "(++)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p ++ q - in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - - - --- cant directly create a singleton type using '[] since the type of '[] is unknown. instead use 'Singleton' or 'EmptyT' - --- | similar to cons --- --- >>> pz @(Fst Id :+ Snd Id) (99,[1,2,3,4]) --- PresentT [99,1,2,3,4] --- --- >>> pz @(Snd Id :+ Fst Id) ([],5) --- PresentT [5] --- --- >>> pz @(123 :+ EmptyList _) "somestuff" --- PresentT [123] --- -data p :+ q -infixr 5 :+ - -instance (P p x - , P q x - , Show (PP p x) - , Show (PP q x) - , Cons (PP q x) (PP q x) (PP p x) (PP p x) - ) => P (p :+ q) x where - type PP (p :+ q) x = PP q x - eval _ opts z = do - let msg0 = "(:+)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `cons` q - in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - --- | similar to snoc --- --- >>> pz @(Snd Id +: Fst Id) (99,[1,2,3,4]) --- PresentT [1,2,3,4,99] --- --- >>> pz @(Fst Id +: Snd Id) ([],5) --- PresentT [5] --- --- >>> pz @(EmptyT [] Id +: 5) 5 --- PresentT [5] --- -data p +: q -infixl 5 +: - -instance (P p x - , P q x - , Show (PP q x) - , Show (PP p x) - , Snoc (PP p x) (PP p x) (PP q x) (PP q x) - ) => P (p +: q) x where - type PP (p +: q) x = PP p x - eval _ opts z = do - let msg0 = "(+:)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `snoc` q - in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - --- | 'Control.Lens.uncons' --- --- >>> pz @Uncons [1,2,3,4] --- PresentT (Just (1,[2,3,4])) --- --- >>> pz @Uncons [] --- PresentT Nothing --- --- >>> pz @Uncons (Seq.fromList "abc") --- PresentT (Just ('a',fromList "bc")) --- --- >>> pz @Uncons ("xyz" :: T.Text) --- PresentT (Just ('x',"yz")) --- -data Uncons - -instance (Show (ConsT s) - , Show s - , Cons s s (ConsT s) (ConsT s) - ) => P Uncons s where - type PP Uncons s = Maybe (ConsT s,s) - eval _ opts as = - let msg0 = "Uncons" - b = as ^? _Cons - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] - --- | 'Control.Lens.unsnoc' --- --- >>> pz @Unsnoc [1,2,3,4] --- PresentT (Just ([1,2,3],4)) --- --- >>> pz @Unsnoc [] --- PresentT Nothing --- --- >>> pz @Unsnoc ("xyz" :: T.Text) --- PresentT (Just ("xy",'z')) --- -data Unsnoc - -instance (Show (ConsT s) - , Show s - , Snoc s s (ConsT s) (ConsT s) - ) => P Unsnoc s where - type PP Unsnoc s = Maybe (s,ConsT s) - eval _ opts as = - let msg0 = "Unsnoc" - b = as ^? _Snoc - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] - --- | similar to 'null' using 'AsEmpty' --- --- >>> pz @IsEmpty [1,2,3,4] --- FalseT --- --- >>> pz @IsEmpty [] --- TrueT --- --- >>> pz @IsEmpty LT --- FalseT --- --- >>> pz @IsEmpty EQ --- TrueT --- -data IsEmpty - -instance (Show as, AsEmpty as) => P IsEmpty as where - type PP IsEmpty as = Bool - eval _ opts as = - let b = has _Empty as - in pure $ mkNodeB opts b ("IsEmpty" <> show1 opts " | " as) [] - -data Null' p - -instance (Show (t a) - , Foldable t - , t a ~ PP p x - , P p x - ) => P (Null' p) x where - type PP (Null' p) x = Bool - eval _ opts x = do - let msg0 = "Null" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = null p - in mkNodeB opts b ("Null" <> show1 opts " | " p) [hh pp] - --- | similar to 'null' using 'Foldable' --- --- >>> pz @Null [1,2,3,4] --- FalseT --- --- >>> pz @Null [] --- TrueT --- --- >>> pz @Null Nothing --- TrueT --- -data Null -type NullT = Null' Id -instance P NullT a => P Null a where - type PP Null a = Bool - eval _ = evalBool (Proxy @NullT) - --- | similar to 'enumFromTo' --- --- >>> pz @(EnumFromTo 2 5) () --- PresentT [2,3,4,5] --- --- >>> pz @(EnumFromTo 'LT 'GT) () --- PresentT [LT,EQ,GT] --- --- >>> pz @(EnumFromTo 'GT 'LT) () --- PresentT [] --- --- >>> pz @(EnumFromTo (Pred Id) (Succ Id)) (SG.Max 10) --- PresentT [Max {getMax = 9},Max {getMax = 10},Max {getMax = 11}] --- --- >>> pz @(EnumFromTo 1 20 >> Map '(Id, (If (Id `Mod` 3 == 0) "Fizz" "" <> If (Id `Mod` 5 == 0) "Buzz" "" )) Id) 123 --- PresentT [(1,""),(2,""),(3,"Fizz"),(4,""),(5,"Buzz"),(6,"Fizz"),(7,""),(8,""),(9,"Fizz"),(10,"Buzz"),(11,""),(12,"Fizz"),(13,""),(14,""),(15,"FizzBuzz"),(16,""),(17,""),(18,"Fizz"),(19,""),(20,"Buzz")] --- -data EnumFromTo p q - -instance (P p x - , P q x - , PP p x ~ a - , Show a - , PP q x ~ a - , Enum a - ) => P (EnumFromTo p q) x where - type PP (EnumFromTo p q) x = [PP p x] - eval _ opts z = do - let msg0 = "EnumFromTo" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> mkNode opts (PresentT (enumFromTo p q)) (msg0 <> " [" <> show p <> " .. " <> show q <> "]") [hh pp, hh qq] - --- | similar to 'enumFromThenTo' --- --- >>> pz @(EnumFromThenTo (ToEnum Day 10) (ToEnum Day 20) (ToEnum Day 70)) () --- PresentT [1858-11-27,1858-12-07,1858-12-17,1858-12-27,1859-01-06,1859-01-16,1859-01-26] --- --- >>> pz @(EnumFromThenTo (ReadP Day "2020-01-12") (ReadP Day "2020-02-12") (ReadP Day "2020-08-12")) () --- PresentT [2020-01-12,2020-02-12,2020-03-14,2020-04-14,2020-05-15,2020-06-15,2020-07-16] --- -data EnumFromThenTo p q r - -instance (P p x - , P q x - , P r x - , PP p x ~ a - , Show a - , PP q x ~ a - , PP r x ~ a - , Enum a - ) => P (EnumFromThenTo p q r) x where - type PP (EnumFromThenTo p q r) x = [PP p x] - eval _ opts z = do - let msg0 = "EnumFromThenTo" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - rr <- eval (Proxy @r) opts z - pure $ case getValueLR opts (msg0 ++ " r failed") rr [hh pp, hh qq] of - Left e -> e - Right r -> - mkNode opts (PresentT (enumFromThenTo p q r)) (msg0 <> " [" <> show p <> ", " <> show q <> " .. " <> show r <> "]") [hh pp, hh qq, hh rr] - --- | similar to 'partitionEithers' --- --- >>> pz @PartitionEithers [Left 'a',Right 2,Left 'c',Right 4,Right 99] --- PresentT ("ac",[2,4,99]) --- --- >>> pz @PartitionEithers [Right 2,Right 4,Right 99] --- PresentT ([],[2,4,99]) --- --- >>> pz @PartitionEithers [Left 'a',Left 'c'] --- PresentT ("ac",[]) --- --- >>> pz @PartitionEithers ([] :: [Either () Int]) --- PresentT ([],[]) --- -data PartitionEithers - -instance (Show a, Show b) => P PartitionEithers [Either a b] where - type PP PartitionEithers [Either a b] = ([a], [b]) - eval _ opts as = - let msg0 = "PartitionEithers" - b = partitionEithers as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] - --- | similar to 'partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract --- --- >>> pz @PartitionThese [This 'a', That 2, This 'c', These 'z' 1, That 4, These 'a' 2, That 99] --- PresentT ("ac",[2,4,99],[('z',1),('a',2)]) --- -data PartitionThese - -instance (Show a, Show b) => P PartitionThese [These a b] where - type PP PartitionThese [These a b] = ([a], [b], [(a, b)]) - eval _ opts as = - let msg0 = "PartitionThese" - b = partitionThese as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] - -data Thiss -type ThissT = Fst PartitionThese - -instance P ThissT x => P Thiss x where - type PP Thiss x = PP ThissT x - eval _ = eval (Proxy @ThissT) - -data Thats -type ThatsT = Snd PartitionThese - -instance P ThatsT x => P Thats x where - type PP Thats x = PP ThatsT x - eval _ = eval (Proxy @ThatsT) - -data Theses -type ThesesT = Thd PartitionThese - -instance P ThesesT x => P Theses x where - type PP Theses x = PP ThesesT x - eval _ = eval (Proxy @ThesesT) - --- want to pass Proxy b to q but then we have no way to calculate 'b' - --- | similar to 'scanl' --- --- >>> pz @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[1..5]) --- PresentT [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] --- --- >>> pz @(ScanN 4 Id (Succ Id)) 'c' --- PresentT "cdefg" --- --- >>> pz @(FoldN 4 Id (Succ Id)) 'c' --- PresentT 'g' --- --- >>> pz @(Dup >> ScanN 4 Id (Pred Id *** Succ Id)) 'g' --- PresentT [('g','g'),('f','h'),('e','i'),('d','j'),('c','k')] --- -data Scanl p q r --- scanr :: (a -> b -> b) -> b -> [a] -> [b] --- result is scanl but signature is flipped ((a,b) -> b) -> b -> [a] -> [b] - -instance (PP p (b,a) ~ b - , PP q x ~ b - , PP r x ~ [a] - , P p (b,a) - , P q x - , P r x - , Show b - , Show a - ) - => P (Scanl p q r) x where - type PP (Scanl p q r) x = [PP q x] - eval _ opts z = do - let msg0 = "Scanl" - lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts z [] - case lr of - Left e -> pure e - Right (q,r,qq,rr) -> - case chkSize opts msg0 r [hh rr] of - Left e -> pure e - Right () -> do - let msg1 = msg0 -- <> show0 opts " " q <> show0 opts " " r - ff i b as' rs - | i >= oRecursion opts = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> showIndex i)) (msg1 <> " (b,as')=" <> show (b,as')) []) - | otherwise = - case as' of - [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (PresentT q) (msg1 <> "(done)") [])], Right ()) - a:as -> do - pp :: TT b <- eval (Proxy @p) opts (b,a) - case getValueLR opts (msg1 <> " i=" <> showIndex i <> " a=" <> show a) pp [] of - Left e -> pure (rs,Left e) - Right b' -> ff (i+1) b' as (rs ++ [((i,b), pp)]) - (ts,lrx) :: ([((Int, b), TT b)], Either (TT [b]) ()) <- ff 1 q r [] - pure $ case splitAndAlign opts msg1 (((0,q), mkNode opts (PresentT q) (msg1 <> "(initial)") []) : ts) of - Left e -> errorInProgram $ "Scanl e=" ++ show (fromTT e) - Right abcs -> - let vals = map (view _1) abcs - itts = map (view _2 &&& view _3) abcs - in case lrx of - Left e -> mkNode opts (_tBool e) msg1 (hh qq : hh rr : map (hh . fixit) itts ++ [hh e]) - Right () -> mkNode opts (PresentT vals) (show01' opts msg1 vals "b=" q <> show1 opts " | as=" r) (hh qq : hh rr : map (hh . fixit) itts) - -data ScanN n p q -type ScanNT n p q = Scanl (Fst Id >> q) p (EnumFromTo 1 n) -- n times using q then run p - -instance P (ScanNT n p q) x => P (ScanN n p q) x where - type PP (ScanN n p q) x = PP (ScanNT n p q) x - eval _ = eval (Proxy @(ScanNT n p q)) - -data ScanNA q -type ScanNAT q = ScanN (Fst Id) (Snd Id) q - -instance P (ScanNAT q) x => P (ScanNA q) x where - type PP (ScanNA q) x = PP (ScanNAT q) x - eval _ = eval (Proxy @(ScanNAT q)) - -data FoldN n p q -type FoldNT n p q = Last (ScanN n p q) - -instance P (FoldNT n p q) x => P (FoldN n p q) x where - type PP (FoldN n p q) x = PP (FoldNT n p q) x - eval _ = eval (Proxy @(FoldNT n p q)) - -data FoldL p q r -type FoldLT p q r = Last (Scanl p q r) - -instance P (FoldLT p q r) x => P (FoldL p q r) x where - type PP (FoldL p q r) x = PP (FoldLT p q r) x - eval _ = eval (Proxy @(FoldLT p q r)) - --- | similar to 'unfoldr' --- --- >>> pz @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] --- PresentT [[1,2],[3,4],[5]] --- -data Unfoldr p q ---type IterateN (t :: Type) n f = Unfoldr (If (Fst Id == 0) (MkNothing t) (Snd Id &&& (Pred Id *** f) >> MkJust Id)) '(n, Id) - -instance (PP q a ~ s - , PP p s ~ Maybe (b,s) - , P q a - , P p s - , Show s - , Show b - ) - => P (Unfoldr p q) a where - type PP (Unfoldr p q) a = [UnfoldT (PP p (PP q a))] - eval _ opts z = do - let msg0 = "Unfoldr" - qq <- eval (Proxy @q) opts z - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - let msg1 = msg0 <> show0 opts " " q - ff i s rs | i >= oRecursion opts = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> showIndex i)) (msg1 <> " s=" <> show s) []) - | otherwise = do - pp :: TT (PP p s) <- eval (Proxy @p) opts s - case getValueLR opts (msg1 <> " i=" <> showIndex i <> " s=" <> show s) pp [] of - Left e -> pure (rs, Left e) - Right Nothing -> pure (rs, Right ()) - Right w@(Just (_b,s')) -> ff (i+1) s' (rs ++ [((i,w), pp)]) - (ts,lr) :: ([((Int, PP p s), TT (PP p s))], Either (TT [b]) ()) <- ff 1 q [] - pure $ case splitAndAlign opts msg1 ts of - Left e -> errorInProgram $ "Unfoldr e=" ++ show (fromTT e) - Right abcs -> - let vals = map (view _1) abcs - itts = map (view _2 &&& view _3) abcs - in case lr of - Left e -> mkNode opts (_tBool e) msg1 (hh qq : map (hh . fixit) itts ++ [hh e]) - Right () -> - let ret = fst <$> catMaybes vals - in mkNode opts (PresentT ret) (show01' opts msg1 ret "s=" q ) (hh qq : map (hh . fixit) itts) - -type family UnfoldT mbs where - UnfoldT (Maybe (b,s)) = b - --- | like 'iterate' but for a fixed number of elements --- --- >>> pz @(IterateN 4 (Succ Id)) 4 --- PresentT [4,5,6,7] --- --- >>> pz @('(0,1) >> IterateN 20 '(Snd Id, Fst Id + Snd Id) >> Map (Fst Id) Id) "sdf" --- PresentT [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181] --- -data IterateN n f -type IterateNT n f = Unfoldr (MaybeBool (Fst Id > 0) '(Snd Id, Pred Id *** f)) '(n, Id) - -instance P (IterateNT n f) x => P (IterateN n f) x where - type PP (IterateN n f) x = PP (IterateNT n f) x - eval _ = eval (Proxy @(IterateNT n f)) - -data IterateUntil p f -type IterateUntilT p f = IterateWhile (Not p) f - -instance P (IterateUntilT p f) x => P (IterateUntil p f) x where - type PP (IterateUntil p f) x = PP (IterateUntilT p f) x - eval _ = eval (Proxy @(IterateUntilT p f)) - -data IterateWhile p f -type IterateWhileT p f = Unfoldr (MaybeBool p '(Id, f)) Id - -instance P (IterateWhileT p f) x => P (IterateWhile p f) x where - type PP (IterateWhile p f) x = PP (IterateWhileT p f) x - eval _ = eval (Proxy @(IterateWhileT p f)) - -data IterateNWhile n p f -type IterateNWhileT n p f = '(n, Id) >> IterateWhile (Fst Id > 0 && (Snd Id >> p)) (Pred Id *** f) >> Map (Snd Id) Id - -instance P (IterateNWhileT n p f) x => P (IterateNWhile n p f) x where - type PP (IterateNWhile n p f) x = PP (IterateNWhileT n p f) x - eval _ = eval (Proxy @(IterateNWhileT n p f)) - -data IterateNUntil n p f -type IterateNUntilT n p f = IterateNWhile n (Not p) f - -instance P (IterateNUntilT n p f) x => P (IterateNUntil n p f) x where - type PP (IterateNUntil n p f) x = PP (IterateNUntilT n p f) x - eval _ = eval (Proxy @(IterateNUntilT n p f)) - --- | similar to 'map' --- --- >>> pz @(Map (Pred Id) Id) [1..5] --- PresentT [0,1,2,3,4] --- -data Map p q - -instance (Show (PP p a) - , P p a - , PP q x ~ f a - , P q x - , Show a - , Show (f a) - , Foldable f - ) => P (Map p q) x where - type PP (Map p q) x = [PP p (ExtractAFromTA (PP q x))] - eval _ opts x = do - let msg0 = "Map" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - ts <- zipWithM (\i a -> ((i, a),) <$> eval (Proxy @p) opts a) [0::Int ..] (toList q) - pure $ case splitAndAlign opts msg0 ts of - Left e -> e - Right abcs -> - let vals = map (view _1) abcs - in mkNode opts (PresentT vals) (show01 opts msg0 vals q) (hh qq : map (hh . fixit) ts) - -data ConcatMap p q -type ConcatMapT p q = Concat (Map p q) - -instance P (ConcatMapT p q) x => P (ConcatMap p q) x where - type PP (ConcatMap p q) x = PP (ConcatMapT p q) x - eval _ = eval (Proxy @(ConcatMapT p q)) - --- | if p then run q else run r --- --- >>> pz @(If (Gt 4) "greater than 4" "less than or equal to 4" ) 10 --- PresentT "greater than 4" --- --- >>> pz @(If (Gt 4) "greater than 4" "less than or equal to 4") 0 --- PresentT "less than or equal to 4" --- --- >>> pz @(If (Snd Id == "a") '("xxx",Fst Id + 13) (If (Snd Id == "b") '("yyy",Fst Id + 7) (Failt _ "oops"))) (99,"b") --- PresentT ("yyy",106) --- -data If p q r - -instance (Show (PP r a) - , P p a - , PP p a ~ Bool - , P q a - , P r a - , PP q a ~ PP r a - ) => P (If p q r) a where - type PP (If p q r) a = PP q a - eval _ opts a = do - let msg0 = "If" - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msg0 <> " condition failed") pp [] of - Left e -> pure e - Right b -> do - qqrr <- if b - then eval (Proxy @q) opts a - else eval (Proxy @r) opts a - pure $ case getValueLR opts (msg0 <> " [" <> show b <> "]") qqrr [hh pp, hh qqrr] of - Left e -> e - Right ret -> mkNode opts (_tBool qqrr) (msg0 <> " " <> if b then "(true cond)" else "(false cond)" <> show0 opts " " ret) [hh pp, hh qqrr] - --- | creates a list of overlapping pairs of elements. requires two or more elements --- --- >>> pz @Pairs [1,2,3,4] --- PresentT [(1,2),(2,3),(3,4)] --- --- >>> pz @Pairs [] --- FailT "Pairs no data found" --- --- >>> pz @Pairs [1] --- FailT "Pairs only one element found" --- -data Pairs -instance Show a => P Pairs [a] where - type PP Pairs [a] = [(a,a)] - eval _ opts as = - let msg0 = "Pairs" - lr = case as of - [] -> Left (msg0 <> " no data found") - [_] -> Left (msg0 <> " only one element found") - _:bs@(_:_) -> Right (zip as bs) - in pure $ case lr of - Left e -> mkNode opts (FailT e) e [] - Right zs -> mkNode opts (PresentT zs) (show01 opts msg0 zs as ) [] - - --- | similar to 'partition' --- --- >>> pz @(Partition (Ge 3) Id) [10,4,1,7,3,1,3,5] --- PresentT ([10,4,7,3,3,5],[1,1]) --- --- >>> pz @(Partition (Prime Id) Id) [10,4,1,7,3,1,3,5] --- PresentT ([7,3,3,5],[10,4,1,1]) --- --- >>> pz @(Partition (Ge 300) Id) [10,4,1,7,3,1,3,5] --- PresentT ([],[10,4,1,7,3,1,3,5]) --- --- >>> pz @(Partition (Id < 300) Id) [10,4,1,7,3,1,3,5] --- PresentT ([10,4,1,7,3,1,3,5],[]) --- -data Partition p q - -instance (P p x - , Show x - , PP q a ~ [x] - , PP p x ~ Bool - , P q a - ) => P (Partition p q) a where - type PP (Partition p q) a = (PP q a, PP q a) - eval _ opts a' = do - let msg0 = "Partition" - qq <- eval (Proxy @q) opts a' - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case chkSize opts msg0 q [hh qq] of - Left e -> pure e - Right () -> do - ts <- zipWithM (\i a -> ((i, a),) <$> evalBool (Proxy @p) opts a) [0::Int ..] q - pure $ case splitAndAlign opts msg0 ts of - Left e -> e - Right abcs -> - let itts = map (view _2 &&& view _3) abcs - w0 = partition (view _1) abcs - zz1 = (map (view (_2 . _2)) *** map (view (_2 . _2))) w0 - in mkNode opts (PresentT zz1) (show01' opts msg0 zz1 "s=" q) (hh qq : map (hh . fixit) itts) - --- | groups values based on a function --- --- >>> pl @(GroupOn Ordering (Case (Failt _ "asdf") '[Id < 2, Id == 2, Id > 2] '[ 'LT, 'EQ, 'GT] Id) Id) [-4,2,5,6,7,1,2,3,4] --- Present fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])] (GroupOn fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])] | s=[-4,2,5,6,7,1,2,3,4]) --- PresentT (fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])]) --- --- >>> pl @(GroupOn Ordering (Case (Failt _ "xyzxyzxyzzyyysyfsyfydf") '[Id < 2, Id == 2, Id > 3] '[ 'LT, 'EQ, 'GT] Id) Id) [-4,2,5,6,7,1,2,3,4] --- Error xyzxyzxyzzyyysyfsyfydf (GroupOn(i=7, a=3) excnt=1) --- FailT "xyzxyzxyzzyyysyfsyfydf" --- -data GroupOn t p q - -instance (P p x - , Ord t - , Show x - , Show t - , PP q a ~ [x] - , PP p x ~ t - , P q a - ) => P (GroupOn t p q) a where - type PP (GroupOn t p q) a = M.Map t (PP q a) - eval _ opts a' = do - let msg0 = "GroupOn" - qq <- eval (Proxy @q) opts a' - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case chkSize opts msg0 q [hh qq] of - Left e -> pure e - Right () -> do - ts <- zipWithM (\i a -> ((i, a),) <$> eval (Proxy @p) opts a) [0::Int ..] q - pure $ case splitAndAlign opts msg0 ts of - Left e -> e - Right abcs -> - let kvs = map (view _1 &&& ((:[]) . view (_2 . _2))) abcs - itts = map (view _2 &&& view _3) abcs - ret = M.fromListWith (++) kvs - in mkNode opts (PresentT ret) (show01' opts msg0 ret "s=" q ) (hh qq : map (hh . fixit) itts) - -data Filter p q -type FilterT p q = Fst (Partition p q) - -instance P (FilterT p q) x => P (Filter p q) x where - type PP (Filter p q) x = PP (FilterT p q) x - eval _ = eval (Proxy @(FilterT p q)) - --- | similar to 'break' --- --- >>> pz @(Break (Ge 3) Id) [10,4,1,7,3,1,3,5] --- PresentT ([],[10,4,1,7,3,1,3,5]) --- --- >>> pz @(Break (Lt 3) Id) [10,4,1,7,3,1,3,5] --- PresentT ([10,4],[1,7,3,1,3,5]) --- -data Break p q - --- only process up to the pivot! only process while Right False --- a predicate can return PresentP not just TrueP -instance (P p x - , PP q a ~ [x] - , PP p x ~ Bool - , P q a - ) => P (Break p q) a where - type PP (Break p q) a = (PP q a, PP q a) - eval _ opts a' = do - let msg0 = "Break" - qq <- eval (Proxy @q) opts a' - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case chkSize opts msg0 q [hh qq] of - Left e -> pure e - Right () -> do - let ff [] zs = pure (zs, [], Nothing) -- [(ia,qq)] extras | the rest of the data | optional last pivot or failure - ff ((i,a):ias) zs = do - pp <- evalBool (Proxy @p) opts a - let v = ((i,a), pp) - case getValueLR opts msg0 pp [hh qq] of - Right False -> ff ias (zs Seq.|> v) - Right True -> pure (zs,map snd ias,Just v) - Left _ -> pure (zs,map snd ias,Just v) - (ialls,rhs,mpivot) <- ff (itoList q) Seq.empty - pure $ case mpivot of - Nothing -> - mkNode opts (PresentT (map (snd . fst) (toList ialls), rhs)) - (msg0 <> " cnt=" <> show (length ialls, length rhs)) - (map (hh . fixit) (toList ialls)) - Just iall@(ia, tt) -> - case getValueLR opts (msg0 <> " predicate failed") tt (hh qq : map (hh . fixit) (toList (ialls Seq.|> iall))) of - Right True -> - mkNode opts (PresentT (map (snd . fst) (toList ialls), snd ia : rhs)) - (msg0 <> " cnt=" <> show (length ialls, 1+length rhs)) - (hh qq : hh tt : map (hh . fixit) (toList (ialls Seq.|> iall))) - - Right False -> errorInProgram "Break" - Left e -> e - -data Span p q -type SpanT p q = Break (Not p) q - -instance P (SpanT p q) x => P (Span p q) x where - type PP (Span p q) x = PP (SpanT p q) x - eval _ = eval (Proxy @(SpanT p q)) - --- | Fails the computation with a message --- --- >>> pz @(Failt Int (PrintF "value=%03d" Id)) 99 --- FailT "value=099" --- --- >>> pz @(FailS (PrintT "value=%03d string=%s" Id)) (99,"somedata") --- FailT "value=099 string=somedata" --- -data Fail t prt - -instance (P prt a - , PP prt a ~ String - ) => P (Fail t prt) a where - type PP (Fail t prt) a = PP t a - eval _ opts a = do - let msg0 = "Fail" - pp <- eval (Proxy @prt) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> mkNode opts (FailT s) (msg0 <> " " <> s) [hh pp | isVerbose opts] - -data FailS p -instance P (Fail I p) x => P (FailS p) x where - type PP (FailS p) x = PP (Fail I p) x - eval _ = eval (Proxy @(Fail I p)) - -data Failt (t :: Type) p -instance P (Fail (Hole t) p) x => P (Failt t p) x where - type PP (Failt t p) x = PP (Fail (Hole t) p) x - eval _ = eval (Proxy @(Fail (Hole t) p)) - -data Failp p -instance P (Fail Unproxy p) x => P (Failp p) x where - type PP (Failp p) x = PP (Fail Unproxy p) x - eval _ = eval (Proxy @(Fail Unproxy p)) - -data Hole (t :: Type) - --- | Acts as a proxy in this dsl where you can explicitly set the Type. --- --- It is passed around as an argument to help the type checker when needed. --- see 'ParseTimeP', 'ReadBase' --- -instance Typeable t => P (Hole t) a where - type PP (Hole t) a = t -- can only be Type not Type -> Type (can use Proxy but then we go down the rabbithole) - eval _ opts _a = - let msg0 = "Hole(" <> showT @t <> ")" - in pure $ mkNode opts (FailT msg0) (msg0 <> " you probably meant to get access to the type of PP only and not evaluate") [] - -data Unproxy - -instance Typeable a => P Unproxy (Proxy (a :: Type)) where - type PP Unproxy (Proxy a) = a - eval _ opts _a = - let msg0 = "Unproxy(" <> showT @a <> ")" - in pure $ mkNode opts (FailT msg0) (msg0 <> " you probably meant to get access to the type of PP only and not evaluate") [] - --- | catch a failure --- --- >>> pz @(Catch (Succ Id) (Fst Id >> Second (ShowP Id) >> PrintT "%s %s" Id >> 'LT)) GT --- PresentT LT --- --- >>> pz @(Catch' (Succ Id) (Second (ShowP Id) >> PrintT "%s %s" Id)) GT --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT" --- --- >>> pz @(Catch' (Succ Id) (Second (ShowP Id) >> PrintT "%s %s" Id)) LT --- PresentT EQ --- --- >>> pz @(Len > 1 && Catch (Id !! 3 == 66) 'False) [1,2] --- FalseT --- --- more flexible: takes a (String,x) and a proxy so we can still call 'False 'True --- now takes the FailT string and x so you can print more detail if you want --- need the proxy so we can fail without having to explicitly specify a type -data Catch p q -- catch p and if fails runs q only on failt - -data Catch' p s -type CatchT' p s = Catch p (FailCatch s) -- eg set eg s=PrintF "%d" Id or PrintF "%s" (ShowP Id) -type FailCatch s = Fail (Snd Id >> Unproxy) (Fst Id >> s) - -instance P (CatchT' p s) x => P (Catch' p s) x where - type PP (Catch' p s) x = PP (CatchT' p s) x - eval _ = eval (Proxy @(CatchT' p s)) - -instance (P p x - , P q ((String, x) - , Proxy (PP p x)) - , PP p x ~ PP q ((String, x), Proxy (PP p x)) - ) => P (Catch p q) x where - type PP (Catch p q) x = PP p x - eval _ opts x = do - let msg0 = "Catch" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> do - let emsg = e ^?! tBool . _FailT -- extract the failt string a push back into the fail case - qq <- eval (Proxy @q) opts ((emsg, x), Proxy @(PP p x)) - pure $ case getValueLR opts (msg0 <> " default condition failed") qq [hh pp] of - Left e1 -> e1 - Right _ -> mkNode opts (_tBool qq) (msg0 <> " caught exception[" <> emsg <> "]") [hh pp, hh qq] - Right _ -> pure $ mkNode opts (_tBool pp) (msg0 <> " did not fire") [hh pp] - --- | similar to 'even' --- --- >>> pz @(Map Even Id) [9,-4,12,1,2,3] --- PresentT [False,True,True,False,True,False] --- --- >>> pz @(Map '(Even,Odd) Id) [9,-4,12,1,2,3] --- PresentT [(False,True),(True,False),(True,False),(False,True),(True,False),(False,True)] --- -data Even -type EvenT = Mod I 2 == 0 - -instance P EvenT x => P Even x where - type PP Even x = Bool - eval _ = evalBool (Proxy @EvenT) - -data Odd -type OddT = Mod I 2 == 1 - -instance P OddT x => P Odd x where - type PP Odd x = Bool - eval _ = evalBool (Proxy @OddT) - - ---type Div' p q = Fst (DivMod p q) ---type Mod' p q = Snd (DivMod p q) - --- | similar to 'div' --- --- >>> pz @(Div (Fst Id) (Snd Id)) (10,4) --- PresentT 2 --- --- >>> pz @(Div (Fst Id) (Snd Id)) (10,0) --- FailT "Div zero denominator" --- -data Div p q -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (Div p q) a where - type PP (Div p q) a = PP p a - eval _ opts a = do - let msg0 = "Div" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) msg0 hhs - _ -> let d = p `div` q - in mkNode opts (PresentT d) (show p <> " `div` " <> show q <> " = " <> show d) hhs - - --- | similar to 'mod' --- --- >>> pz @(Mod (Fst Id) (Snd Id)) (10,3) --- PresentT 1 --- --- >>> pz @(Mod (Fst Id) (Snd Id)) (10,0) --- FailT "Mod zero denominator" --- -data Mod p q -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (Mod p q) a where - type PP (Mod p q) a = PP p a - eval _ opts a = do - let msg0 = "Mod" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) msg0 hhs - _ -> let d = p `mod` q - in mkNode opts (PresentT d) (show p <> " `mod` " <> show q <> " = " <> show d) hhs - --- | similar to 'divMod' --- --- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,3) --- PresentT (3,1) --- --- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,-3) --- PresentT (-4,-2) --- --- >>> pz @(DivMod (Fst Id) (Snd Id)) (-10,3) --- PresentT (-4,2) --- --- >>> pz @(DivMod (Fst Id) (Snd Id)) (-10,-3) --- PresentT (3,-1) --- --- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,0) --- FailT "DivMod zero denominator" --- -data DivMod p q - -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (DivMod p q) a where - type PP (DivMod p q) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "DivMod" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) msg0 hhs - _ -> let d = p `divMod` q - in mkNode opts (PresentT d) (show p <> " `divMod` " <> show q <> " = " <> show d) hhs - --- | similar to 'quotRem' --- --- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,3) --- PresentT (3,1) --- --- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,-3) --- PresentT (-3,1) --- --- >>> pz @(QuotRem (Fst Id) (Snd Id)) (-10,-3) --- PresentT (3,-1) --- --- >>> pz @(QuotRem (Fst Id) (Snd Id)) (-10,3) --- PresentT (-3,-1) --- --- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,0) --- FailT "QuotRem zero denominator" --- -data QuotRem p q - -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (QuotRem p q) a where - type PP (QuotRem p q) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "QuotRem" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) msg0 hhs - _ -> let d = p `quotRem` q - in mkNode opts (PresentT d) (show p <> " `quotRem` " <> show q <> " = " <> show d) hhs - -data Quot p q -type QuotT p q = Fst (QuotRem p q) - -instance P (QuotT p q) x => P (Quot p q) x where - type PP (Quot p q) x = PP (QuotT p q) x - eval _ = eval (Proxy @(QuotT p q)) - -data Rem p q -type RemT p q = Snd (QuotRem p q) - -instance P (RemT p q) x => P (Rem p q) x where - type PP (Rem p q) x = PP (RemT p q) x - eval _ = eval (Proxy @(RemT p q)) - ---type OneP = Guard "expected list of length 1" (Len == 1) >> Head Id ---type OneP = Guard (PrintF "expected list of length 1 but found length=%d" Len) (Len == 1) >> Head Id - --- k or prt has access to (Int,a) where Int is the current guard position: hence need to use PrintT --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out) - --- | Guards contain a type level list of tuples the action to run on failure of the predicate and the predicate itself --- Each tuple validating against the corresponding value in a value list --- --- \'prt\' receives (Int,a) as input which is the position and value if there is a failure --- --- >>> pz @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 4)]) [17,4] --- PresentT [17,4] --- --- >>> pz @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 5)]) [17,4] --- FailT "arg2 failed" --- --- >>> pz @(Guards '[ '("arg1 failed",Gt 99), '("arg2 failed", Same 4)]) [17,4] --- FailT "arg1 failed" --- --- >>> pz @(Guards '[ '(PrintT "arg %d failed with value %d" Id,Gt 4), '(PrintT "%d %d" Id, Same 4)]) [17,3] --- FailT "1 3" --- --- >>> pz @(GuardsQuick (PrintT "arg %d failed with value %d" Id) '[Gt 4, Ge 3, Same 4]) [17,3,5] --- FailT "arg 2 failed with value 5" --- --- >>> pz @(GuardsQuick (PrintT "arg %d failed with value %d" Id) '[Gt 4, Ge 3, Same 4]) [17,3,5,99] --- FailT "Guards:invalid length(4) expected 3" --- -data GuardsImpl (n :: Nat) (os :: [(k,k1)]) - -data Guards (ps :: [(k,k1)]) - -instance ([a] ~ x, GetLen ps, P (GuardsImpl (LenT ps) ps) x) => P (Guards ps) x where - type PP (Guards ps) x = PP (GuardsImpl (LenT ps) ps) x - eval _ opts as = do - let msg0 = "Guards" - n = getLen @ps - if n /= length as then - let msg1 = msg0 <> badLength as n - in pure $ mkNode opts (FailT msg1) msg1 [] - else eval (Proxy @(GuardsImpl (LenT ps) ps)) opts as - -badLength :: (Foldable t, Show n, Num n) => t a -> n -> String -badLength as n = ":invalid length(" <> show (length as) <> ") expected " ++ show (n+0) - -instance ([a] ~ x, Show a) - => P (GuardsImpl n ('[] :: [(k,k1)])) x where - type PP (GuardsImpl n ('[] :: [(k,k1)])) x = x - eval _ opts as = - let msg0 = "Guards" - in if not (null as) then errorInProgram $ "GuardsImpl base case has extra data " ++ show as - else pure $ mkNode opts (PresentT as) (msg0 <> " no data") [] - -instance (PP prt (Int, a) ~ String - , P prt (Int, a) - , KnownNat n - , GetLen ps - , P p a - , PP p a ~ Bool - , P (GuardsImpl n ps) [a] - , PP (GuardsImpl n ps) [a] ~ [a] - , Show a - , [a] ~ x - ) => P (GuardsImpl n ('(prt,p) ': ps)) x where - type PP (GuardsImpl n ('(prt,p) ': ps)) x = x - eval _ opts as' = do - let cpos = n-pos-1 - msgbase1 = "Guard(" <> show cpos <> ")" - msgbase2 = "Guards" - n :: Int = nat @n - pos = getLen @ps - case as' of - a:as -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msgbase1 <> " p failed") pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts (cpos,a) -- only run prt when predicate is False - pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of - Left e -> e - Right msgx -> mkNode opts (FailT msgx) (msgbase1 <> " failed [" <> msgx <> "]" <> show0 opts " " a) (hh pp : [hh qq | isVerbose opts]) - Right True -> - if pos == 0 then -- we are at the bottom of the tree - pure $ mkNode opts (PresentT [a]) msgbase2 [hh pp] - else do - ss <- eval (Proxy @(GuardsImpl n ps)) opts as - pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of - Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! - Right zs -> (ss & tForest %~ \x -> fromTT pp : x) & tBool .~ PresentT (a:zs) - _ -> errorInProgram "GuardsImpl n+1 case has no data" - -data GuardsQuick (prt :: k) (ps :: [k1]) -type GuardsQuickT (prt :: k) (ps :: [k1]) = Guards (ToGuardsT prt ps) - -instance P (GuardsQuickT prt ps) x => P (GuardsQuick prt ps) x where - type PP (GuardsQuick prt ps) x = PP (GuardsQuickT prt ps) x - eval _ = eval (Proxy @(GuardsQuickT prt ps)) - --- | boolean guard which checks a given a list of predicates against the list of values --- --- prefer 'Bools' as 'BoolsQuick' doesnt give much added value: passes in the index and the value to prt but you already have the index in the message --- --- pulls the top message from the tree if a predicate is false --- --- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,93,14] --- False (Bool(1) [mm] (93 <= 59)) --- FalseT --- --- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,13,94] --- False (Bool(2) [<<<2 94>>>] (94 <= 59)) --- FalseT --- --- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,13,14] --- True (Bools) --- TrueT --- --- >>> pl @(BoolsQuick "abc" '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,14] --- True (Bools) --- TrueT --- --- >>> pl @(BoolsQuick (PrintT "id=%d val=%d" Id) '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,14] --- True (Bools) --- TrueT --- --- >>> pl @(BoolsQuick (PrintT "id=%d val=%d" Id) '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,99] --- False (Bool(2) [id=2 val=99] (99 <= 59)) --- FalseT --- --- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,13,14] --- True (Bools) --- TrueT --- --- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,60,14] --- False (Bool(1) [minutes] (60 <= 59)) --- FalseT --- --- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,60,14,20] --- False (Bools:invalid length(4) expected 3) --- FalseT --- -data Bools (ps :: [(k,k1)]) - -instance ([a] ~ x - , GetLen ps - , P (BoolsImpl (LenT ps) ps) x - , PP (BoolsImpl (LenT ps) ps) x ~ Bool - ) => P (Bools ps) x where - type PP (Bools ps) x = Bool - eval _ opts as = do - let msg0 = "Bools" - msg1 = "Bool("++show n++")" - n = getLen @ps - case chkSize opts msg1 as [] of - Left e -> pure e - Right () -> - if n /= length as then - let msg2 = msg0 <> badLength as n - in pure $ mkNodeB opts False msg2 [] -- was FailT but now just FalseT - else evalBool (Proxy @(BoolsImpl (LenT ps) ps)) opts as - -data BoolsImpl (n :: Nat) (os :: [(k,k1)]) - -instance (KnownNat n - , Show a - , [a] ~ x - ) => P (BoolsImpl n ('[] :: [(k,k1)])) x where - type PP (BoolsImpl n ('[] :: [(k,k1)])) x = Bool - eval _ opts as = - let msg0 = "Bool(" <> show n <> ")" - n :: Int = nat @n - in if not (null as) then errorInProgram $ "BoolsImpl base case has extra data " ++ show as - else pure $ mkNodeB opts True (msg0 <> " empty") [] - -instance (PP prt (Int, a) ~ String - , P prt (Int, a) - , KnownNat n - , GetLen ps - , P p a - , PP p a ~ Bool - , P (BoolsImpl n ps) x - , PP (BoolsImpl n ps) [a] ~ Bool --- , Show a - , [a] ~ x - ) => P (BoolsImpl n ('(prt,p) ': ps)) x where - type PP (BoolsImpl n ('(prt,p) ': ps)) x = Bool - eval _ opts as' = do - let cpos = n-pos-1 - msgbase1 = "Bool(" <> showIndex cpos <> ")" - msgbase2 = "Bools" - n :: Int = nat @n - pos = getLen @ps - case as' of - a:as -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msgbase1 <> " p failed") pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts (cpos,a) -- only run prt when predicate is False - pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of - Left e -> e - Right msgx -> mkNodeB opts False (msgbase1 <> " [" <> msgx <> "] " <> topMessage pp) (hh pp : [hh qq | isVerbose opts]) - Right True -> - if pos == 0 then -- we are at the bottom of the tree - pure $ mkNodeB opts True msgbase2 [hh pp] - else do - ss <- evalBool (Proxy @(BoolsImpl n ps)) opts as - pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of - Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! - Right _ -> ss & tForest %~ \x -> fromTT pp : x - _ -> errorInProgram "BoolsImpl n+1 case has no data" - -data BoolsQuick (prt :: k) (ps :: [k1]) -type BoolsQuickT (prt :: k) (ps :: [k1]) = Bools (ToGuardsT prt ps) - --- why do we need this? when BoolsN works without [use the x ~ [a] trick in BoolsN] -instance (PP (Bools (ToGuardsT prt ps)) x ~ Bool - , P (BoolsQuickT prt ps) x - ) => P (BoolsQuick prt ps) x where - type PP (BoolsQuick prt ps) x = PP (BoolsQuickT prt ps) x - eval _ = evalBool (Proxy @(BoolsQuickT prt ps)) - --- | leverages 'RepeatT' for repeating predicates (passthrough method) --- --- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,256] --- False (Bool(3) [id=3 must be between 0 and 255, found 256] (256 <= 255)) --- FalseT --- --- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,44] --- True (Bools) --- TrueT --- -data BoolsN prt (n :: Nat) (p :: k1) -type BoolsNT prt (n :: Nat) (p :: k1) = Bools (ToGuardsT prt (RepeatT n p)) - -instance (x ~ [a], P (BoolsNT prt n p) x) => P (BoolsN prt n p) x where - type PP (BoolsN prt n p) x = PP (BoolsNT prt n p) x - eval _ = evalBool (Proxy @(BoolsNT prt n p)) - --- | if a predicate fails then then the corresponding symbol and value will be passed to the print function --- --- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [13,59,61] --- FailT "seconds invalid: found 61" --- --- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [27,59,12] --- FailT "hours invalid: found 27" --- --- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [23,59,12] --- PresentT [23,59,12] --- -data GuardsDetailImpl (ps :: [(k,k1)]) - -instance ([a] ~ x - , GetLen ps - , P (GuardsImplX (LenT ps) ps) x - ) => P (GuardsDetailImpl ps) x where - type PP (GuardsDetailImpl ps) x = PP (GuardsImplX (LenT ps) ps) x - eval _ opts as = do - let msg0 = "Guards" - n = getLen @ps - if n /= length as then - let msg1 = msg0 <> badLength as n - in pure $ mkNode opts (FailT msg1) msg1 [] - else eval (Proxy @(GuardsImplX (LenT ps) ps)) opts as - -data GuardsImplX (n :: Nat) (os :: [(k,k1)]) - -instance ([a] ~ x, Show a) - => P (GuardsImplX n ('[] :: [(k,k1)])) x where - type PP (GuardsImplX n ('[] :: [(k,k1)])) x = x - eval _ opts as = - let msg0 = "Guards" - -- n :: Int = nat @n - in if not (null as) then errorInProgram $ "GuardsImplX base case has extra data " ++ show as - else pure $ mkNode opts (PresentT as) msg0 [] - -instance (PP prt a ~ String - , P prt a - , KnownNat n - , GetLen ps - , P p a - , PP p a ~ Bool - , P (GuardsImplX n ps) [a] - , PP (GuardsImplX n ps) [a] ~ [a] - , Show a - , [a] ~ x - ) => P (GuardsImplX n ('(prt,p) ': ps)) x where - type PP (GuardsImplX n ('(prt,p) ': ps)) x = x - eval _ opts as' = do - let cpos = n-pos-1 - msgbase1 = "Guard(" <> showIndex cpos <> ")" - msgbase2 = "Guards" - n :: Int = nat @n - pos = getLen @ps - case as' of - a:as -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msgbase1 <> " p failed") pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts a -- only run prt when predicate is False - pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of - Left e -> e - Right msgx -> mkNode opts (FailT msgx) (msgbase1 <> " failed [" <> msgx <> "]" <> show0 opts " " a) (hh pp : [hh qq | isVerbose opts]) - Right True -> do - ss <- eval (Proxy @(GuardsImplX n ps)) opts as - pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of - Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! - Right zs -> mkNode opts (PresentT (a:zs)) (msgbase1 <> show0 opts " " a) [hh pp, hh ss] - _ -> errorInProgram "GuardsImplX n+1 case has no data" - -data GuardsDetail prt (ps :: [(k0,k1)]) -type GuardsDetailT prt (ps :: [(k0,k1)]) = GuardsDetailImpl (ToGuardsDetailT prt ps) - -instance P (GuardsDetailT prt ps) x => P (GuardsDetail prt ps) x where - type PP (GuardsDetail prt ps) x = PP (GuardsDetailT prt ps) x - eval _ = eval (Proxy @(GuardsDetailT prt ps)) - -type family ToGuardsDetailT (prt :: k1) (os :: [(k2,k3)]) :: [(Type,k3)] where - ToGuardsDetailT prt '[ '(s,p) ] = '(PrintT prt '(s,Id), p) : '[] - ToGuardsDetailT prt ( '(s,p) ': ps) = '(PrintT prt '(s,Id), p) ': ToGuardsDetailT prt ps - ToGuardsDetailT prt '[] = GL.TypeError ('GL.Text "ToGuardsDetailT cannot be empty") - --- | leverages 'RepeatT' for repeating predicates (passthrough method) --- --- >>> pz @(GuardsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,256] --- FailT "id=3 must be between 0 and 255, found 256" --- --- >>> pz @(GuardsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,44] --- PresentT [121,33,7,44] --- -data GuardsN prt (n :: Nat) p -type GuardsNT prt (n :: Nat) p = Guards (ToGuardsT prt (RepeatT n p)) - -instance (x ~ [a], P (GuardsNT prt n p) x) => P (GuardsN prt n p) x where - type PP (GuardsN prt n p) x = PP (GuardsNT prt n p) x - eval _ = eval (Proxy @(GuardsNT prt n p)) - --- | \'p\' is the predicate and on failure of the predicate runs \'prt\' --- --- >>> pz @(Guard "expected > 3" (Gt 3)) 17 --- PresentT 17 --- --- >>> pz @(Guard "expected > 3" (Gt 3)) 1 --- FailT "expected > 3" --- --- >>> pz @(Guard (PrintF "%d not > 3" Id) (Gt 3)) (-99) --- FailT "-99 not > 3" --- -data Guard prt p - -data ExitWhen prt p -type ExitWhenT prt p = Guard prt (Not p) - -instance P (ExitWhenT prt p) x => P (ExitWhen prt p) x where - type PP (ExitWhen prt p) x = PP (ExitWhenT prt p) x - eval _ = eval (Proxy @(ExitWhenT prt p)) - -instance (Show a - , P prt a - , PP prt a ~ String - , P p a - , PP p a ~ Bool - ) => P (Guard prt p) a where - type PP (Guard prt p) a = a - eval _ opts a = do - let msg0 = "Guard" - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts a - pure $ case getValueLR opts (msg0 <> " Msg") qq [hh pp] of - Left e -> e - Right msg1 -> mkNode opts (FailT msg1) (msg0 <> "(failed) [" <> msg1 <> "]" <> show0 opts " | " a) (hh pp : [hh qq | isVerbose opts]) - Right True -> pure $ mkNode opts (PresentT a) (msg0 <> "(ok)" <> show0 opts " | " a) [hh pp] -- dont show the guard message if successful - - --- | similar to 'Guard' but uses the root message of the False predicate case as the failure message --- --- most uses of GuardSimple can be replaced by a boolean predicate unless you require a failure message instead of true/false --- --- >>> pz @(GuardSimple (Luhn Id)) [1..4] --- FailT "(Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4])" --- --- >>> pl @(Luhn Id) [1..4] --- False (Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4]) --- FalseT --- --- >>> pz @(GuardSimple (Luhn Id)) [1,2,3,0] --- PresentT [1,2,3,0] --- --- >>> pz @(GuardSimple (Len > 30)) [1,2,3,0] --- FailT "(4 > 30)" --- -data GuardSimple p - -instance (Show a - , P p a - , PP p a ~ Bool - ) => P (GuardSimple p) a where - type PP (GuardSimple p) a = a - eval _ opts a = do - let msg0 = "GuardSimple" - pp <- evalBool (Proxy @p) (subopts opts) a -- temporarily lift DZero to DLite so as not to lose the failure message - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right False -> - let msgx = topMessage pp - in mkNode opts (FailT msgx) (msg0 <> "(failed) " <> msgx <> show0 opts " | " a) [hh pp] - Right True -> - mkNode opts (PresentT a) (msg0 <> "(ok)" <> show0 opts " | " a) [hh pp] - - --- | just run the effect but skip the value --- for example for use with Stdout so it doesnt interfere with the \'a\' on the rhs unless there is an failure -data Skip p - -instance (Show (PP p a), P p a) => P (Skip p) a where - type PP (Skip p) a = a - eval _ opts a = do - let msg0 = "Skip" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> mkNode opts (PresentT a) (msg0 <> show0 opts " " p) [hh pp] - -data p |> q -type SkipLT p q = Skip p >> q -infixr 1 |> - -instance P (SkipLT p q) x => P (p |> q) x where - type PP (p |> q) x = PP (SkipLT p q) x - eval _ = eval (Proxy @(SkipLT p q)) - -data p >| q -type SkipRT p q = p >> Skip q -infixr 1 >| - -instance P (SkipRT p q) x => P (p >| q) x where - type PP (p >| q) x = PP (SkipRT p q) x - eval _ = eval (Proxy @(SkipRT p q)) - -data p >|> q -type SkipBothT p q = Skip p >> Skip q -infixr 1 >|> - -instance P (SkipBothT p q) x => P (p >|> q) x where - type PP (p >|> q) x = PP (SkipBothT p q) x - eval _ = eval (Proxy @(SkipBothT p q)) - --- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' - --- | This is composition for predicates --- --- >>> pz @(Fst Id >> Succ (Id !! 0)) ([11,12],'x') --- PresentT 12 --- --- >>> pz @(Len *** Succ Id >> ShowP (First (Pred Id))) ([11,12],'x') --- PresentT "(1,'y')" --- -data p >> q -infixr 1 >> - -instance (Show (PP p a) - , Show (PP q (PP p a)) - , P p a - , P q (PP p a) - ) => P (p >> q) a where - type PP (p >> q) a = PP q (PP p a) - eval _ opts a = do - let msg0 = "(>>)" - pp <- eval (Proxy @p) opts a - case getValueLRHide opts "(>>) lhs failed" pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts p - pure $ case getValueLRHide opts (show p <> " (>>) rhs failed") qq [hh pp] of - Left e -> e - Right q -> mkNode opts (_tBool qq) (lit01 opts msg0 q (topMessageEgregious qq)) [hh pp, hh qq] - --- bearbeiten! only used by >> -topMessageEgregious :: TT a -> String -topMessageEgregious pp = innermost (pp ^. tString) - where innermost = ('{':) . reverse . ('}':) . takeWhile (/='{') . dropWhile (=='}') . reverse - -data p << q -type LeftArrowsT p q = q >> p -infixr 1 << - -instance P (LeftArrowsT p q) x => P (p << q) x where - type PP (p << q) x = PP (LeftArrowsT p q) x - eval _ = eval (Proxy @(LeftArrowsT p q)) - -type p >>> q = p >> q -infixl 1 >>> - --- | similar to 'Prelude.&&' --- --- >>> pz @(Fst Id && Snd Id) (True, True) --- TrueT --- --- >>> pz @(Id > 15 && Id < 17) 16 --- TrueT --- --- >>> pz @(Id > 15 && Id < 17) 30 --- FalseT --- --- >>> pz @(Fst Id && (Length (Snd Id) >= 4)) (True,[11,12,13,14]) --- TrueT --- --- >>> pz @(Fst Id && (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) --- FalseT --- -data p && q -infixr 3 && - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p && q) a where - type PP (p && q) a = Bool - eval _ opts a = do - let msg0 = "&&" - lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let zz = case (p,q) of - (True, True) -> "" - (False, True) -> topMessage pp - (True, False) -> topMessage qq - (False, False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - in mkNodeB opts (p&&q) (show p <> " " <> msg0 <> " " <> show q <> (if null zz then zz else " | " <> zz)) [hh pp, hh qq] - --- | short circuit version of boolean And --- --- >>> pl @(Id > 10 &&~ Failt _ "ss") 9 --- False (False &&~ ... | (9 > 10)) --- FalseT --- --- >>> pl @(Id > 10 &&~ Id == 12) 11 --- False (True &&~ False | (11 == 12)) --- FalseT --- --- >>> pl @(Id > 10 &&~ Id == 11) 11 --- True (True &&~ True) --- TrueT --- -data p &&~ q -infixr 3 &&~ - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p &&~ q) a where - type PP (p &&~ q) a = Bool - eval _ opts a = do - let msg0 = "&&~" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right False -> - pure $ mkNodeB opts False ("False" <> " " <> msg0 <> " ... | " <> topMessage pp) [hh pp] - Right True -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - Right q -> - let zz = if q then "" - else " | " <> topMessage qq - in mkNodeB opts q ("True" <> " " <> msg0 <> " " <> show q <> zz) [hh pp, hh qq] - --- | similar to 'Prelude.||' --- --- >>> pz @(Fst Id || (Length (Snd Id) >= 4)) (False,[11,12,13,14]) --- TrueT --- --- >>> pz @(Not (Fst Id) || (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) --- FalseT --- -data p || q -infixr 2 || - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p || q) a where - type PP (p || q) a = Bool - eval _ opts a = do - let msg0 = "||" - lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let zz = case (p,q) of - (False,False) -> " | " <> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - _ -> "" - in mkNodeB opts (p||q) (show p <> " " <> msg0 <> " " <> show q <> zz) [hh pp, hh qq] - --- | short circuit version of boolean Or --- --- >>> pl @(Id > 10 ||~ Failt _ "ss") 11 --- True (True ||~ ...) --- TrueT --- --- >>> pz @(Id > 10 ||~ Id == 9) 9 --- TrueT --- --- >>> pl @(Id > 10 ||~ Id > 9) 9 --- False (False ||~ False | (9 > 10) ||~ (9 > 9)) --- FalseT --- -data p ||~ q -infixr 2 ||~ - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p ||~ q) a where - type PP (p ||~ q) a = Bool - eval _ opts a = do - let msg0 = "||~" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - Right q -> - let zz = if q then "" - else " | " <> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - in mkNodeB opts q ("False" <> " " <> msg0 <> " " <> show q <> zz) [hh pp, hh qq] - Right True -> - pure $ mkNodeB opts True ("True" <> " " <> msg0 <> " ...") [hh pp] - --- | implication --- --- >>> pz @(Fst Id ~> (Length (Snd Id) >= 4)) (True,[11,12,13,14]) --- TrueT --- --- >>> pz @(Fst Id ~> (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) --- FalseT --- --- >>> pz @(Fst Id ~> (Length (Snd Id) == 4)) (False,[12,11,12,13,14]) --- TrueT --- --- >>> pz @(Fst Id ~> (Length (Snd Id) >= 4)) (False,[11,12,13,14]) --- TrueT --- -data p ~> q -infixr 1 ~> - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p ~> q) a where - type PP (p ~> q) a = Bool - eval _ opts a = do - let msg0 = "~>" - lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let zz = case (p,q) of - (True,False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - _ -> "" - in mkNodeB opts (p~>q) (show p <> " " <> msg0 <> " " <> show q <> (if null zz then zz else " | " <> zz)) [hh pp, hh qq] - --- | 'not' function --- --- >>> pz @(Not Id) False --- TrueT --- --- >>> pz @(Not Id) True --- FalseT --- --- >>> pz @(Not (Fst Id)) (True,22) --- FalseT --- --- >>> pl @(Not (Lt 3)) 13 --- True (Not (13 < 3)) --- TrueT --- -data Not p - -instance (PP p x ~ Bool, P p x) => P (Not p) x where - type PP (Not p) x = Bool - eval _ opts x = do - let msg0 = "Not" - pp <- evalBool (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = not p - in mkNodeB opts b (msg0 <> " " <> topMessage pp) [hh pp] - --- | 'id' function on a boolean --- --- >>> pz @(IdBool Id) False --- FalseT --- --- >>> pz @(IdBool Id) True --- TrueT --- --- >>> pz @(IdBool (Fst Id)) (True,22) --- TrueT --- --- >>> pl @(IdBool (Lt 3)) 13 --- False (IdBool (13 < 3)) --- FalseT --- -data IdBool p - -instance (PP p x ~ Bool, P p x) => P (IdBool p) x where - type PP (IdBool p) x = Bool - eval _ opts x = do - let msg0 = "IdBool" - pp <- evalBool (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = p - in mkNodeB opts b (msg0 <> " " <> topMessage pp) [hh pp] - --- | similar to 'compare' --- --- >>> pz @(Fst Id ==! Snd Id) (10,9) --- PresentT GT --- --- >>> pz @(14 % 3 ==! Fst Id -% Snd Id) (-10,7) --- PresentT GT --- --- >>> pz @(Fst Id ==! Snd Id) (10,11) --- PresentT LT --- --- >>> pz @(Snd Id ==! (Fst Id >> Snd Id >> Head Id)) (('x',[10,12,13]),10) --- PresentT EQ --- --- >>> pz @(Snd Id ==! Head (Snd (Fst Id))) (('x',[10,12,13]),10) --- PresentT EQ --- - -data p ==! q -infix 4 ==! - -type OrdP p q = p ==! q - -instance (Ord (PP p a) - , PP p a ~ PP q a - , P p a - , Show (PP q a) - , P q a - ) => P (p ==! q) a where - type PP (p ==! q) a = Ordering - eval _ opts a = do - let msg0 = "(==!)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = compare p q - in mkNode opts (PresentT d) (msg0 <> " " <> show p <> " " <> prettyOrd d <> show0 opts " " q) [hh pp, hh qq] - -data OrdA p - -instance P (OrdA' p p) x => P (OrdA p) x where - type PP (OrdA p) x = PP (OrdA' p p) x - eval _ = eval (Proxy @(OrdA' p p)) - -data OrdA' p q -type OrdAT' p q = (Fst Id >> p) ==! (Snd Id >> q) - -instance P (OrdAT' p q) x => P (OrdA' p q) x where - type PP (OrdA' p q) x = PP (OrdAT' p q) x - eval _ = eval (Proxy @(OrdAT' p q)) - --- | compare two strings ignoring case --- --- >>> pz @(Fst Id ===~ Snd Id) ("abC","aBc") --- PresentT EQ --- --- >>> pz @(Fst Id ===~ Snd Id) ("abC","DaBc") --- PresentT LT --- -type OrdI p q = p ===~ q -data p ===~ q -infix 4 ===~ - -instance (PP p a ~ String - , PP p a ~ PP q a - , P p a - , P q a - ) => P (p ===~ q) a where - type PP (p ===~ q) a = Ordering - eval _ opts a = do - let msg0 = "(===~)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = on compare (map toLower) p q - in mkNode opts (PresentT d) (msg0 <> " " <> p <> " " <> prettyOrd d <> " " <> q) [hh pp, hh qq] - --- | compare two values using the given ordering \'o\' --- --- >>> pl @(Lt 4) 123 --- False (123 < 4) --- FalseT --- --- >>> pl @(Lt 4) 1 --- True (1 < 4) --- TrueT --- --- >>> pl @(Negate 7 <..> 20) (-4) --- True (-7 <= -4 <= 20) --- TrueT --- --- >>> pl @(Negate 7 <..> 20) 21 --- False (21 <= 20) --- FalseT --- -data Cmp (o :: OrderingP) p q - -instance (GetOrd o - , Ord (PP p a) - , Show (PP p a) - , PP p a ~ PP q a - , P p a - , P q a - ) => P (Cmp o p q) a where - type PP (Cmp o p q) a = Bool - eval _ opts a = do - let (sfn, fn) = getOrd @o - lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = fn p q - in mkNodeB opts b (show p <> " " <> sfn <> show0 opts " " q) [hh pp, hh qq] - --- | compare two strings ignoring case using the given ordering \'o\' -data CmpI (o :: OrderingP) p q - -instance (PP p a ~ String - , GetOrd o - , PP p a ~ PP q a - , P p a - , P q a - ) => P (CmpI o p q) a where - type PP (CmpI o p q) a = Bool - eval _ opts a = do - let (sfn, fn) = getOrd @o - lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = on fn (map toLower) p q - in mkNodeB opts b ("CmpI " <> p <> " " <> sfn <> " " <> q) [hh pp, hh qq] - - --- | similar to 'Control.Lens.itoList' --- --- >>> pz @(IToList _ Id) ("aBc" :: String) --- PresentT [(0,'a'),(1,'B'),(2,'c')] --- -data IToList' t p - -instance (Show x - , P p x - , Typeable (PP t (PP p x)) - , Show (PP t (PP p x)) - , FoldableWithIndex (PP t (PP p x)) f - , PP p x ~ f a - , Show a - ) => P (IToList' t p) x where - type PP (IToList' t p) x = [(PP t (PP p x), ExtractAFromTA (PP p x))] - eval _ opts x = do - let msg0 = "IToList" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = itoList p - t = showT @(PP t (PP p x)) - in mkNode opts (PresentT b) (msg0 <> "(" <> t <> ")" <> show0 opts " " b <> show1 opts " | " x) [hh pp] - -data IToList (t :: Type) p -type IToListT (t :: Type) p = IToList' (Hole t) p - -instance P (IToListT t p) x => P (IToList t p) x where - type PP (IToList t p) x = PP (IToListT t p) x - eval _ = eval (Proxy @(IToListT t p)) - --- | similar to 'toList' --- --- >>> pz @ToList ("aBc" :: String) --- PresentT "aBc" --- --- >>> pz @ToList (Just 14) --- PresentT [14] --- --- >>> pz @ToList Nothing --- PresentT [] --- --- >>> pz @ToList (Left "xx") --- PresentT [] --- --- >>> pz @ToList (These 12 "xx") --- PresentT ["xx"] --- -data ToList -instance (Show (t a) - , Foldable t - , Show a - ) => P ToList (t a) where - type PP ToList (t a) = [a] - eval _ opts as = - let msg0 = "ToList" - z = toList as - in pure $ mkNode opts (PresentT z) (show01 opts msg0 z as) [] - --- | similar to 'toList' --- --- >>> pz @(ToList' Id) ("aBc" :: String) --- PresentT "aBc" --- --- >>> pz @(ToList' Id) (Just 14) --- PresentT [14] --- --- >>> pz @(ToList' Id) Nothing --- PresentT [] --- --- >>> pz @(ToList' Id) (Left "xx") --- PresentT [] --- --- >>> pz @(ToList' Id) (These 12 "xx") --- PresentT ["xx"] --- -data ToList' p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , Show a - ) => P (ToList' p) x where - type PP (ToList' p) x = [ExtractAFromTA (PP p x)] -- extra layer of indirection means pan (ToList' Id) "abc" won't work without setting the type of "abc" unlike ToList - eval _ opts x = do - let msg0 = "ToList'" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let hhs = [hh pp] - b = toList p - in mkNode opts (PresentT b) (show01 opts msg0 b p) hhs - --- | invokes 'GE.toList' --- --- >>> pz @ToListExt (M.fromList [(1,'x'),(4,'y')]) --- PresentT [(1,'x'),(4,'y')] --- --- >>> pz @ToListExt (T.pack "abc") --- PresentT "abc" --- -data ToListExt - -instance (Show l - , GE.IsList l - , Show (GE.Item l) - ) => P ToListExt l where - type PP ToListExt l = [GE.Item l] - eval _ opts as = - let msg0 = "ToListExt" - z = GE.toList as - in pure $ mkNode opts (PresentT z) (show01 opts msg0 z as) [] - --- | invokes 'GE.fromList' --- --- >>> import qualified Data.Set as Set --- >>> run @('OMsg "Fred" ':# 'ODebug 'DLite ':# 'ONoColor 'True) @(FromList (Set.Set Int) << '[2,1,5,5,2,5,2]) () --- Fred >>> Present fromList [1,2,5] ((>>) fromList [1,2,5] | {FromList fromList [1,2,5]}) --- PresentT (fromList [1,2,5]) --- -data FromList (t :: Type) -- doesnt work with OverloadedLists unless you cast to [a] explicitly - -instance (a ~ GE.Item t - , Show t - , GE.IsList t - , [a] ~ x - ) => P (FromList t) x where - type PP (FromList t) x = t - eval _ opts as = - let msg0 = "FromList" - z = GE.fromList (as :: [GE.Item t]) :: t - in pure $ mkNode opts (PresentT z) (msg0 <> show0 opts " " z) [] - --- | invokes 'GE.fromList' --- --- requires the OverloadedLists extension --- --- >>> :set -XOverloadedLists --- >>> pz @(FromListExt (M.Map _ _)) [(4,"x"),(5,"dd")] --- PresentT (fromList [(4,"x"),(5,"dd")]) --- -data FromListExt (t :: Type) --- l ~ l' is key -instance (Show l - , GE.IsList l - , l ~ l' - ) => P (FromListExt l') l where - type PP (FromListExt l') l = l' - eval _ opts as = - let msg0 = "FromListExt" - z = GE.fromList (GE.toList @l as) - in pure $ mkNode opts (PresentT z) (msg0 <> show0 opts " " z) [] - --- | predicate on 'These' --- --- >>> pz @(IsThis Id) (This "aBc") --- TrueT --- --- >>> pz @(IsThis Id) (These 1 'a') --- FalseT --- --- >>> pz @(IsThese Id) (These 1 'a') --- TrueT --- --- >>> pl @(IsThat Id) (This 12) --- False (IsThat | This 12) --- FalseT --- --- >>> pl @(IsThis Id) (This 12) --- True (IsThis | This 12) --- TrueT --- --- >>> pl @(IsThese Id) (This 12) --- False (IsThese | This 12) --- FalseT --- --- >>> pl @(IsThese Id) (These 'x' 12) --- True (IsThese | These 'x' 12) --- TrueT --- -data IsTh (th :: These x y) p -- x y can be anything - --- trying to avoid show instance cos of ambiguities -instance (PP p x ~ These a b - , P p x - , Show a - , Show b - , GetThese th - ) => P (IsTh (th :: These x1 x2) p) x where - type PP (IsTh th p) x = Bool - eval _ opts x = do - let msg0 = "Is" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (t,f) = getThese @th - b = f p - in mkNodeB opts b (msg0 <> t <> show1 opts " | " p) [hh pp] - -data IsThis p -type IsThisT p = IsTh ('This '()) p - -instance P (IsThisT p) x => P (IsThis p) x where - type PP (IsThis p) x = PP (IsThisT p) x - eval _ = evalBool (Proxy @(IsThisT p)) - -data IsThat p -type IsThatT p = IsTh ('That '()) p - -instance P (IsThatT p) x => P (IsThat p) x where - type PP (IsThat p) x = PP (IsThatT p) x - eval _ = evalBool (Proxy @(IsThatT p)) - -data IsThese p -type IsTheseT p = IsTh ('These '() '()) p - -instance P (IsTheseT p) x => P (IsThese p) x where - type PP (IsThese p) x = PP (IsTheseT p) x - eval _ = evalBool (Proxy @(IsTheseT p)) - --- | similar to 'Data.These.these' --- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (This 13) --- PresentT 13 --- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (That "this is a long string") --- PresentT 21 --- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (These 20 "somedata") --- PresentT 28 --- --- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (That "this is a long string") --- PresentT (Right "this is a long string") --- --- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 1 "this is a long string") --- PresentT (Right "this is a long string") --- --- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 100 "this is a long string") --- PresentT (Left 100) --- -data TheseIn p q r - -instance (Show a - , Show b - , Show (PP p a) - , P p a - , P q b - , P r (a,b) - , PP p a ~ PP q b - , PP p a ~ PP r (a,b) - , PP q b ~ PP r (a,b) - ) => P (TheseIn p q r) (These a b) where - type PP (TheseIn p q r) (These a b) = PP p a - eval _ opts th = do - let msg0 = "TheseIn" - case th of - This a -> do - let msg1 = "This " - msg2 = msg0 <> msg1 - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts (msg2 <> "p failed") pp [] of - Left e -> e - Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 a) [hh pp] - That b -> do - let msg1 = "That " - msg2 = msg0 <> msg1 - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg2 <> "q failed") qq [] of - Left e -> e - Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 b) [hh qq] - These a b -> do - let msg1 = "These " - msg2 = msg0 <> msg1 - rr <- eval (Proxy @r) opts (a,b) - pure $ case getValueLR opts (msg2 <> "r failed") rr [] of - Left e -> e - Right c -> mkNode opts (PresentT c) (show01 opts msg0 c (These a b)) [hh rr] - -data TheseId p q -type TheseIdT p q = TheseIn '(I, p) '(q, I) I - -instance P (TheseIdT p q) x => P (TheseId p q) x where - type PP (TheseId p q) x = PP (TheseIdT p q) x - eval _ = eval (Proxy @(TheseIdT p q)) --- | creates an empty list of the given type --- --- >>> pz @(Id :+ EmptyList _) 99 --- PresentT [99] --- -data EmptyList' t - -instance P (EmptyList' t) x where - type PP (EmptyList' t) x = [PP t x] - eval _ opts _ = - pure $ mkNode opts (PresentT []) "EmptyList" [] - -data EmptyList (t :: Type) -type EmptyListT (t :: Type) = EmptyList' (Hole t) - -instance P (EmptyList t) x where - type PP (EmptyList t) x = PP (EmptyListT t) x - eval _ = eval (Proxy @(EmptyListT t)) - --- | creates a singleton from a value --- --- >>> pz @(Singleton (Char1 "aBc")) () --- PresentT "a" --- --- >>> pz @(Singleton Id) False --- PresentT [False] --- --- >>> pz @(Singleton (Snd Id)) (False,"hello") --- PresentT ["hello"] --- -data Singleton p - -instance P p x => P (Singleton p) x where - type PP (Singleton p) x = [PP p x] - eval _ opts x = do - let msg0 = "Singleton" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> mkNode opts (PresentT [p]) msg0 [hh pp] - ---type Singleton p = p :+ EmptyT [] p - --- | extracts the first character from a non empty 'Symbol' --- --- >>> pz @(Char1 "aBc") () --- PresentT 'a' --- -data Char1 (s :: Symbol) -- gets the first char from the Symbol [requires that Symbol is not empty] -instance (KnownSymbol s, GL.CmpSymbol s "" ~ 'GT) => P (Char1 s) a where - type PP (Char1 s) a = Char - eval _ opts _ = - case symb @s of - [] -> errorInProgram "Char1: found empty Symbol/string" - c:_ -> pure $ mkNode opts (PresentT c) ("Char1" <> show0 opts " " c) [] - --- | similar to 'Data.Align.align' thats pads with 'Data.These.This' or 'Data.These.That' if one list is shorter than the other --- --- the key is that all information about both lists are preserved --- --- >>> pz @(ZipThese (Fst Id) (Snd Id)) ("aBc", [1..5]) --- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] --- --- >>> pz @(ZipThese (Fst Id) (Snd Id)) ("aBcDeF", [1..3]) --- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] --- --- >>> pz @(ZipThese Id Reverse) "aBcDeF" --- PresentT [These 'a' 'F',These 'B' 'e',These 'c' 'D',These 'D' 'c',These 'e' 'B',These 'F' 'a'] --- --- >>> pz @(ZipThese Id '[]) "aBcDeF" --- PresentT [This 'a',This 'B',This 'c',This 'D',This 'e',This 'F'] --- --- >>> pz @(ZipThese '[] Id) "aBcDeF" --- PresentT [That 'a',That 'B',That 'c',That 'D',That 'e',That 'F'] --- --- >>> pz @(ZipThese '[] '[]) "aBcDeF" --- PresentT [] --- -data ZipThese p q - -instance (PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (ZipThese p q) a where - type PP (ZipThese p q) a = [These (ExtractAFromList (PP p a)) (ExtractAFromList (PP q a))] - eval _ opts a = do - let msg0 = "ZipThese" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> e - Right () -> - let d = simpleAlign p q - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> show1 opts " | q=" q) hhs - -simpleAlign :: [a] -> [b] -> [These a b] -simpleAlign as [] = map This as -simpleAlign [] bs = map That bs -simpleAlign (a:as) (b:bs) = These a b : simpleAlign as bs - -type family ExtractAFromTA (ta :: Type) :: Type where - ExtractAFromTA (t a) = a - ExtractAFromTA z = GL.TypeError ( - 'GL.Text "ExtractAFromTA: expected (t a) but found something else" - ':$$: 'GL.Text "t a = " - ':<>: 'GL.ShowType z) - --- todo: get ExtractAFromList failure to fire if wrong Type --- | extract \'a\' from \'[a]\' which I need for type PP -type family ExtractAFromList (as :: Type) :: Type where - ExtractAFromList [a] = a - ExtractAFromList z = GL.TypeError ( - 'GL.Text "ExtractAFromList: expected [a] but found something else" - ':$$: 'GL.Text "as = " - ':<>: 'GL.ShowType z) - - --- | Zip two lists to their maximum length using padding if needed --- --- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abc", [1..5]) --- PresentT [('a',1),('b',2),('c',3),('Z',4),('Z',5)] --- --- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcdefg", [1..5]) --- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5),('f',99),('g',99)] --- --- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcde", [1..5]) --- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5)] --- --- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("", [1..5]) --- PresentT [('Z',1),('Z',2),('Z',3),('Z',4),('Z',5)] --- --- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcde", []) --- PresentT [('a',99),('b',99),('c',99),('d',99),('e',99)] --- -data ZipPad l r p q - -instance (PP l a ~ x - , PP r a ~ y - , P l a - , P r a - , PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (ZipPad l r p q) a where - type PP (ZipPad l r p q) a = [(PP l a, PP r a)] - eval _ opts a = do - let msg0 = "ZipPad" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> pure e - Right () -> do - let lls = (length p,length q) - case uncurry compare lls of - LT -> do - ll <- eval (Proxy @l) opts a - pure $ case getValueLR opts (msg0 <> " l failed") ll hhs of - Left e -> e - Right l -> - let d = zip (p ++ repeat l) q - in mkNode opts (PresentT d) (show01' opts (msg0 <> " Left pad") d "p=" p <> show1 opts " | q=" q) (hhs ++ [hh ll]) - GT -> do - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts (msg0 <> " r failed") rr hhs of - Left e -> e - Right r -> - let d =zip p (q ++ repeat r) - in mkNode opts (PresentT d) (show01' opts (msg0 <> " Right pad") d "p=" p <> show1 opts " | q=" q) (hhs ++ [hh rr]) - EQ -> - let d = zip p q - in pure $ mkNode opts (PresentT d) (show01' opts (msg0 <> " No pad") d "p=" p <> show1 opts " | q=" q) hhs - - --- | zip two lists padding the left hand side if needed --- --- >>> pl @(ZipL 99 '[1,2,3] "abc") () --- Present [(1,'a'),(2,'b'),(3,'c')] (ZipL [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") --- PresentT [(1,'a'),(2,'b'),(3,'c')] --- --- >>> pl @(ZipL 99 '[1,2] "abc") () --- Present [(1,'a'),(2,'b'),(99,'c')] (ZipL [(1,'a'),(2,'b'),(99,'c')] | p=[1,2] | q="abc") --- PresentT [(1,'a'),(2,'b'),(99,'c')] --- --- >>> pl @(ZipL 99 '[1] "abc") () --- Present [(1,'a'),(99,'b'),(99,'c')] (ZipL [(1,'a'),(99,'b'),(99,'c')] | p=[1] | q="abc") --- PresentT [(1,'a'),(99,'b'),(99,'c')] --- --- >>> pl @(ZipL 99 '[1,2,3] "ab") () --- Error ZipL(3,2) rhs would be truncated (ZipL(3,2) | p=[1,2,3] | q="ab") --- FailT "ZipL(3,2) rhs would be truncated" --- -data ZipL l p q -instance (PP l a ~ x - , P l a - , PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (ZipL l p q) a where - type PP (ZipL l p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] - eval _ opts a = do - let msg0 = "ZipL" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> pure e - Right () -> do - let lls = (length p,length q) - case uncurry compare lls of - GT -> let msg1 = msg0 ++ show lls - in pure $ mkNode opts (FailT (msg1 ++ " rhs would be truncated")) (msg1 <> show1 opts " | p=" p <> show1 opts " | q=" q) hhs - _ -> do - ll <- eval (Proxy @l) opts a - pure $ case getValueLR opts (msg0 <> " l failed") ll hhs of - Left e -> e - Right l -> - let d = zip (p ++ repeat l) q - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> show1 opts " | q=" q) (hhs ++ [hh ll]) - --- | zip two lists padding the right hand side if needed --- --- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "abc") () --- Present [(1,'a'),(2,'b'),(3,'c')] (ZipR [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") --- PresentT [(1,'a'),(2,'b'),(3,'c')] --- --- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "ab") () --- Present [(1,'a'),(2,'b'),(3,'Z')] (ZipR [(1,'a'),(2,'b'),(3,'Z')] | p=[1,2,3] | q="ab") --- PresentT [(1,'a'),(2,'b'),(3,'Z')] --- --- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "a") () --- Present [(1,'a'),(2,'Z'),(3,'Z')] (ZipR [(1,'a'),(2,'Z'),(3,'Z')] | p=[1,2,3] | q="a") --- PresentT [(1,'a'),(2,'Z'),(3,'Z')] --- --- >>> pl @(ZipR (Char1 "Z") '[1,2] "abc") () --- Error ZipR(2,3) rhs would be truncated (ZipR(2,3) | p=[1,2] | q="abc") --- FailT "ZipR(2,3) rhs would be truncated" --- -data ZipR r p q -instance (PP r a ~ y - , P r a - , PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (ZipR r p q) a where - type PP (ZipR r p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] - eval _ opts a = do - let msg0 = "ZipR" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> pure e - Right () -> do - let lls = (length p,length q) - case uncurry compare lls of - LT -> let msg1 = msg0 ++ show lls - in pure $ mkNode opts (FailT (msg1 ++ " rhs would be truncated")) (msg1 <> show1 opts " | p=" p <> show1 opts " | q=" q) hhs - _ -> do - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts (msg0 <> " l failed") rr hhs of - Left e -> e - Right r -> - let d = zip p (q ++ repeat r) - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> show1 opts " | q=" q) (hhs ++ [hh rr]) - --- | zip two lists with the same length --- --- >>> pl @(Zip '[1,2,3] "abc") () --- Present [(1,'a'),(2,'b'),(3,'c')] (Zip [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") --- PresentT [(1,'a'),(2,'b'),(3,'c')] --- --- >>> pl @(Zip '[1,2,3] "ab") () --- Error Zip(3,2) length mismatch (Zip(3,2) | p=[1,2,3] | q="ab") --- FailT "Zip(3,2) length mismatch" --- --- >>> pl @(Zip '[1,2] "abc") () --- Error Zip(2,3) length mismatch (Zip(2,3) | p=[1,2] | q="abc") --- FailT "Zip(2,3) length mismatch" --- -data Zip p q -instance (PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (Zip p q) a where - type PP (Zip p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] - eval _ opts a = do - let msg0 = "Zip" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> e - Right () -> - let lls = (length p, length q) - in case uncurry compare lls of - EQ -> let d = zip p q - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> show1 opts " | q=" q) hhs - _ -> let msg1 = msg0 ++ show lls - in mkNode opts (FailT (msg1 <> " length mismatch")) (msg1 <> show1 opts " | p=" p <> show1 opts " | q=" q) hhs - --- | Luhn predicate check on last digit --- --- >>> pz @(Luhn Id) [1,2,3,0] --- TrueT --- --- >>> pz @(Luhn Id) [1,2,3,4] --- FalseT --- --- >>> pz @(GuardSimple (Luhn Id)) [15,4,3,1,99] --- FailT "(Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99])" --- --- >>> pl @(Luhn Id) [15,4,3,1,99] --- False (Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99]) --- FalseT --- -data Luhn p - -instance (PP p x ~ [Int] - , P p x - ) => P (Luhn p) x where - type PP (Luhn p) x = Bool - eval _ opts x = do - let msg0 = "Luhn" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let xs = zipWith (*) (reverse p) (cycle [1,2]) - ys = map (\w -> if w>=10 then w-9 else w) xs - z = sum ys - ret = z `mod` 10 - hhs = [hh pp] - in if ret == 0 then mkNodeB opts True (msg0 <> show0 opts " | " p) hhs - else mkNodeB opts False (msg0 <> " map=" <> show ys <> " sum=" <> show z <> " ret=" <> show ret <> show1 opts " | " p) hhs - --- | Read a number using base 2 through a maximum of 36 --- --- >>> pz @(ReadBase Int 16 Id) "00feD" --- PresentT 4077 --- --- >>> pz @(ReadBase Int 16 Id) "-ff" --- PresentT (-255) --- --- >>> pz @(ReadBase Int 2 Id) "10010011" --- PresentT 147 --- --- >>> pz @(ReadBase Int 8 Id) "Abff" --- FailT "invalid base 8" --- --- >>> pl @(ReadBase Int 16 Id >> GuardSimple (Id > 0xffff) >> ShowBase 16 Id) "12344" --- Present "12344" ((>>) "12344" | {ShowBase(16) 12344 | 74564}) --- PresentT "12344" --- --- >>> :set -XBinaryLiterals --- >>> pz @(ReadBase Int 16 Id >> GuardSimple (Id > 0b10011111) >> ShowBase 16 Id) "7f" --- FailT "(127 > 159)" --- - --- supports negative numbers unlike readInt -data ReadBase' t (n :: Nat) p - -instance (Typeable (PP t x) - , ZwischenT 2 36 n - , Show (PP t x) - , Num (PP t x) - , KnownNat n - , PP p x ~ String - , P p x - ) => P (ReadBase' t n p) x where - type PP (ReadBase' t n p) x = PP t x - eval _ opts x = do - let n = nat @n - xs = getValidBase n - msg0 = "ReadBase(" <> t <> "," <> show n <> ")" - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (ff,p1) = case p of - '-':q -> (negate,q) - _ -> (id,p) - in case readInt (fromIntegral n) - ((`elem` xs) . toLower) - (fromJust . (`elemIndex` xs) . toLower) - p1 of - [(b,"")] -> mkNode opts (PresentT (ff b)) (msg0 <> show0 opts " " (ff b) <> show1 opts " | " p) [hh pp] - o -> mkNode opts (FailT ("invalid base " <> show n)) (msg0 <> " as=" <> p <> " err=" <> show o) [hh pp] - -data ReadBase (t :: Type) (n :: Nat) p -type ReadBaseT (t :: Type) (n :: Nat) p = ReadBase' (Hole t) n p - -instance P (ReadBaseT t n p) x => P (ReadBase t n p) x where - type PP (ReadBase t n p) x = PP (ReadBaseT t n p) x - eval _ = eval (Proxy @(ReadBaseT t n p)) - -getValidBase :: Int -> String -getValidBase n = - let xs = ['0'..'9'] <> ['a'..'z'] - len = length xs - in if n > len || n < 2 then errorInProgram $ "getValidBase: oops invalid base valid is 2 thru " ++ show len ++ " found " ++ show n - else take n xs - --- | Display a number at base 2 to 36, similar to 'showIntAtBase' but supports signed numbers --- --- >>> pz @(ShowBase 16 Id) 4077 --- PresentT "fed" --- --- >>> pz @(ShowBase 16 Id) (-255) --- PresentT "-ff" --- --- >>> pz @(ShowBase 2 Id) 147 --- PresentT "10010011" --- --- >>> pz @(ShowBase 2 (Negate 147)) "whatever" --- PresentT "-10010011" --- -data ShowBase (n :: Nat) p - -instance (PP p x ~ a - , P p x - , Show a - , 2 GL.<= n - , n GL.<= 36 - , KnownNat n - , Integral a - ) => P (ShowBase n p) x where - type PP (ShowBase n p) x = String - eval _ opts x = do - let n = nat @n - xs = getValidBase n - msg0 = "ShowBase(" <> show n <> ")" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (ff,a') = if p < 0 then (('-':), abs p) else (id,p) - b = showIntAtBase (fromIntegral n) (xs !!) a' "" - in mkNode opts (PresentT (ff b)) (msg0 <> showLit0 opts " " (ff b) <> show1 opts " | " p) [hh pp] - --- | intercalate two lists --- --- >>> pz @(Intercalate '["aB"] '["xxxx","yz","z","www","xyz"]) () --- PresentT ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] --- --- >>> pz @(Intercalate '[W 99,Negate 98] Id) [1..5] --- PresentT [1,99,-98,2,99,-98,3,99,-98,4,99,-98,5] --- --- >>> pz @(Intercalate '[99,100] Id) [1..5] ---PresentT [1,99,100,2,99,100,3,99,100,4,99,100,5] --- -data Intercalate p q - -instance (PP p x ~ [a] - , PP q x ~ PP p x - , P p x - , P q x - , Show a - ) => P (Intercalate p q) x where - type PP (Intercalate p q) x = PP p x - eval _ opts x = do - let msg0 = "Intercalate" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of - Left e -> e - Right () -> - let d = intercalate p (map pure q) - in mkNode opts (PresentT d) (show01 opts msg0 d p <> show1 opts " | " q) hhs - --- | uses PrintF to format output for a single value --- --- >>> pz @(PrintF "value=%03d" Id) 12 --- PresentT "value=012" --- --- >>> pz @(PrintF "%s" (Fst Id)) ("abc",'x') --- PresentT "abc" --- --- >>> pz @(PrintF "%d" (Fst Id)) ("abc",'x') --- FailT "PrintF (IO e=printf: bad formatting char 'd')" --- -data PrintF s p - -instance (PrintfArg (PP p x) - , Show (PP p x) - , PP s x ~ String - , P s x - , P p x - ) => P (PrintF s p) x where - type PP (PrintF s p) x = String - eval _ opts x = do - let msg0 = "PrintF" - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] - case lrx of - Left e -> pure e - Right (s,p,ss,pp) -> do - let msg1 = msg0 - lr <- catchitNF @_ @E.SomeException (printf s p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg1 <> " (" <> e <> ")")) (msg1 <> show0 opts " " p <> " s=" <> s) [hh ss, hh pp] - Right ret -> mkNode opts (PresentT ret) (msg1 <> " [" <> showLit0 opts "" ret <> "]" <> show1 opts " | p=" p <> showLit1 opts " | s=" s) [hh ss, hh pp] - -type family GuardsT (ps :: [k]) where - GuardsT '[] = '[] - GuardsT (p ': ps) = Guard "fromGuardsT" p ': GuardsT ps - ---type Guards' (ps :: [k]) = Para (GuardsT ps) - ---type ToGuards (prt :: k) (os :: [k1]) = Proxy (Guards (ToGuardsT prt os)) - -type family ToGuardsT (prt :: k) (os :: [k1]) :: [(k,k1)] where - ToGuardsT prt '[] = GL.TypeError ('GL.Text "ToGuardsT cannot be empty") - ToGuardsT prt '[p] = '(prt,p) : '[] - ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps - --- | runs values in parallel unlike 'Do' which is serial --- --- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30] --- PresentT [10,21,120] --- --- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30,40] --- FailT "Para:invalid length(4) expected 3" --- -data ParaImpl (n :: Nat) (os :: [k]) - -data Para (ps :: [k]) - --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out -instance ([a] ~ x - , GetLen ps - , P (ParaImpl (LenT ps) ps) x - ) => P (Para ps) x where - type PP (Para ps) x = PP (ParaImpl (LenT ps) ps) x - eval _ opts as = do - let msg0 = "Para" - n = getLen @ps - if n /= length as then - let msg1 = msg0 <> badLength as n - in pure $ mkNode opts (FailT msg1) msg1 [] - else eval (Proxy @(ParaImpl (LenT ps) ps)) opts as - --- only allow non empty lists -- might need [a] ~ x but it seems fine -instance GL.TypeError ('GL.Text "ParaImpl '[] invalid: requires at least one value in the list") - => P (ParaImpl n ('[] :: [k])) x where - type PP (ParaImpl n ('[] :: [k])) x = Void - eval _ _ _ = errorInProgram "ParaImpl empty list" - -instance (Show (PP p a) - , KnownNat n - , Show a - , P p a - ) => P (ParaImpl n '[p]) [a] where - type PP (ParaImpl n '[p]) [a] = [PP p a] - eval _ opts as' = do - let msgbase0 = "Para" - msgbase1 = msgbase0 <> "(" <> show n <> ")" - n :: Int - n = nat @n - case as' of - [a] -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msgbase1 pp [] of - Left e -> e - -- show1 opts " " [b] fails but using 'b' is ok and (b : []) also works! - -- GE.List problem - Right b -> mkNode opts (PresentT [b]) (msgbase1 <> show0 opts " " [b] <> show1 opts " | " a) [hh pp] - _ -> errorInProgram $ "ParaImpl base case should have exactly one element but found " ++ show as' - -instance (KnownNat n - , GetLen ps - , P p a - , P (ParaImpl n (p1 ': ps)) [a] - , PP (ParaImpl n (p1 ': ps)) [a] ~ [PP p a] - , Show a - , Show (PP p a) - ) - => P (ParaImpl n (p ': p1 ': ps)) [a] where - type PP (ParaImpl n (p ': p1 ': ps)) [a] = [PP p a] - eval _ opts as' = do - let cpos = n-pos-1 - msgbase0 = msgbase2 <> "(" <> showIndex cpos <> " of " <> show n <> ")" - msgbase1 = msgbase2 <> "(" <> showIndex cpos <> ")" - msgbase2 = "Para" - n = nat @n - pos = 1 + getLen @ps -- cos p1! - case as' of - a:as -> do - pp <- eval (Proxy @p) opts a - case getValueLR opts msgbase0 pp [] of - Left e -> pure e - Right b -> do - qq <- eval (Proxy @(ParaImpl n (p1 ': ps))) opts as - pure $ case getValueLRHide opts (msgbase1 <> " rhs failed " <> show b) qq [hh pp] of - Left e -> e - Right bs -> mkNode opts (PresentT (b:bs)) (msgbase1 <> show0 opts " " (b:bs) <> show1 opts " | " as') [hh pp, hh qq] - _ -> errorInProgram "ParaImpl n+1 case has no data left" - --- | leverages 'Para' for repeating predicates (passthrough method) --- --- >>> pz @(ParaN 4 (Succ Id)) [1..4] --- PresentT [2,3,4,5] --- --- >>> pz @(ParaN 4 (Succ Id)) "azwxm" --- FailT "Para:invalid length(5) expected 4" --- --- >>> pz @(ParaN 4 (Succ Id)) "azwx" --- PresentT "b{xy" --- -data ParaN (n :: Nat) p - -instance ( P (ParaImpl (LenT (RepeatT n p)) (RepeatT n p)) x - , GetLen (RepeatT n p) - , x ~ [a] - ) => P (ParaN n p) x where - type PP (ParaN n p) x = PP (Para (RepeatT n p)) x - eval _ = eval (Proxy @(Para (RepeatT n p))) - --- | tries each predicate ps and on the first match runs the corresponding qs but if there is no match on ps then runs the fail case e --- --- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 50 --- PresentT "50 is same50" --- --- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 9 --- PresentT "9 is lt10" --- --- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 3 --- PresentT "3 is lt4" --- --- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 99 --- FailT "asdf" --- --- >>> pz @(Case (FailS "asdf" >> Snd Id >> Unproxy) '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 99 --- FailT "asdf" --- --- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "b" --- PresentT "there" --- --- >>> pz @(Case (Failt _ "x") '[Id == "a",Id == "b"] '["hey","there"] Id) "a" --- PresentT "hey" --- --- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "c" --- FailT "x" --- -data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) --- ps = conditions --- qs = what to do [one to one --- r = the value --- e = otherwise -- leave til later -data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) -data Case' (ps :: [k]) (qs :: [k1]) (r :: k2) -data Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) - -type CaseT' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd Id >> Failp "Case:no match") ps qs r -type CaseT'' s (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (FailCaseT s) ps qs r -- eg s= PrintF "%s" (ShowP Id) - -instance P (CaseT'' s ps qs r) x => P (Case'' s ps qs r) x where - type PP (Case'' s ps qs r) x = PP (CaseT'' s ps qs r) x - eval _ = eval (Proxy @(CaseT'' s ps qs r)) - -instance P (CaseT' ps qs r) x => P (Case' ps qs r) x where - type PP (Case' ps qs r) x = PP (CaseT' ps qs r) x - eval _ = eval (Proxy @(CaseT' ps qs r)) - -type FailCaseT p = Fail (Snd Id >> Unproxy) (Fst Id >> p) - -type CaseImplT e ps qs r = CaseImpl (LenT ps) e ps qs r - --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out -instance (FailUnlessT (LenT ps DE.== LenT qs) - ('GL.Text "lengths are not the same " - ':<>: 'GL.ShowType (LenT ps) - ':<>: 'GL.Text " vs " - ':<>: 'GL.ShowType (LenT qs)) - , P (CaseImplT e ps qs r) x - ) => P (Case e ps qs r) x where - type PP (Case e ps qs r) x = PP (CaseImplT e ps qs r) x - eval _ = eval (Proxy @(CaseImplT e ps qs r)) - --- only allow non empty lists! -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lhs requires at least one value in the list")) - => P (CaseImpl n e ('[] :: [k]) (q ': qs) r) x where - type PP (CaseImpl n e ('[] :: [k]) (q ': qs) r) x = Void - eval _ _ _ = errorInProgram "CaseImpl lhs empty" - -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: rhs requires at least one value in the list")) - => P (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x where - type PP (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x = Void - eval _ _ _ = errorInProgram "CaseImpl rhs empty" - -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lists are both empty")) - => P (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x where - type PP (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x = Void - eval _ _ _ = errorInProgram "CaseImpl both lists empty" - -instance (P r x - , P q (PP r x) - , Show (PP q (PP r x)) - , P p (PP r x) - , PP p (PP r x) ~ Bool - , KnownNat n - , Show (PP r x) - , P e (PP r x, Proxy (PP q (PP r x))) - , PP e (PP r x, Proxy (PP q (PP r x))) ~ PP q (PP r x) - ) => P (CaseImpl n e '[p] '[q] r) x where - type PP (CaseImpl n e '[p] '[q] r) x = PP q (PP r x) - eval _ opts z = do - let msgbase0 = "Case(" <> show n <> ")" - n :: Int = nat @n - rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of - Left e -> pure e - Right a -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msgbase0 pp [hh rr] of - Left e -> pure e - Right True -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msgbase0 qq [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) (hh rr : hh pp : [hh qq | isVerbose opts]) - Right False -> do - ee <- eval (Proxy @e) opts (a, Proxy @(PP q (PP r x))) - pure $ case getValueLR opts (msgbase0 <> " otherwise failed") ee [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) [hh rr, hh pp, hh ee] - -instance (KnownNat n - , GetLen ps - , P r x - , P p (PP r x) - , P q (PP r x) - , PP p (PP r x) ~ Bool - , Show (PP q (PP r x)) - , Show (PP r x) - , P (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x - , PP (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x ~ PP q (PP r x) - ) - => P (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x where - type PP (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x = PP q (PP r x) - eval _ opts z = do - let cpos = n-pos-1 - msgbase0 = msgbase2 <> "(" <> showIndex cpos <> " of " <> show n <> ")" - msgbase1 = msgbase2 <> "(" <> showIndex cpos <> ")" - msgbase2 = "Case" - n = nat @n - pos = 1 + getLen @ps -- cos p1! - rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of - Left e -> pure e - Right a -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msgbase0 pp [hh rr] of - Left e -> pure e - Right True -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msgbase0 qq [hh pp, hh rr] of - Left e -> e - Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) (hh rr : hh pp : [hh qq | isVerbose opts]) - Right False -> do - ww <- eval (Proxy @(CaseImpl n e (p1 ': ps) (q1 ': qs) r)) opts z - pure $ case getValueLR opts (msgbase1 <> " failed rhs") ww [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) (show01 opts msgbase1 b a) [hh rr, hh pp, hh ww] - --- | similar to 'sequenceA' --- --- >>> pz @Sequence [Just 10, Just 20, Just 30] --- PresentT (Just [10,20,30]) --- --- >>> pz @Sequence [Just 10, Just 20, Just 30, Nothing, Just 40] --- PresentT Nothing --- -data Sequence - -instance (Show (f (t a)) - , Show (t (f a)) - , Traversable t - , Applicative f - ) => P Sequence (t (f a)) where - type PP Sequence (t (f a)) = f (t a) - eval _ opts tfa = - let d = sequenceA tfa - in pure $ mkNode opts (PresentT d) ("Sequence" <> show0 opts " " d <> show1 opts " | " tfa) [] - -data Traverse p q -type TraverseT p q = Map p q >> Sequence - -instance P (TraverseT p q) x => P (Traverse p q) x where - type PP (Traverse p q) x = PP (TraverseT p q) x - eval _ = eval (Proxy @(TraverseT p q)) - --- | run the expression \'p\' but remove the subtrees -data Hide p --- type H p = Hide p -- doesnt work with % -- unsaturated! - -instance P p x => P (Hide p) x where - type PP (Hide p) x = PP p x - eval _ opts x = do - tt <- eval (Proxy @(Msg "!" p)) opts x - pure $ tt & tForest .~ [] - --- | similar to 'readFile' --- --- >>> pz @(ReadFile "LICENSE" >> 'Just Id >> Len > 0) () --- TrueT --- --- >>> pz @(FileExists "xyzzy") () --- FalseT --- -data ReadFile p - -data FileExists p -type FileExistsT p = IsJust (ReadFile p) - -instance P (FileExistsT p) x => P (FileExists p) x where - type PP (FileExists p) x = PP (FileExistsT p) x - eval _ = evalBool (Proxy @(FileExistsT p)) - -instance (PP p x ~ String, P p x) => P (ReadFile p) x where - type PP (ReadFile p) x = Maybe String - eval _ opts x = do - let msg0 = "ReadFile" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ do - b <- doesFileExist p - if b then Just <$> readFile p - else pure Nothing - pure $ case mb of - Nothing -> mkNode opts (FailT msg1) msg1 [hh pp] - Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] - Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> showLit0 opts " Just " b) [hh pp] - --- | does the directory exists --- --- >>> pz @(DirExists ".") () --- TrueT --- -data ReadDir p -data DirExists p -type DirExistsT p = IsJust (ReadDir p) - -instance P (DirExistsT p) x => P (DirExists p) x where - type PP (DirExists p) x = PP (DirExistsT p) x - eval _ = evalBool (Proxy @(DirExistsT p)) - - -instance (PP p x ~ String, P p x) => P (ReadDir p) x where - type PP (ReadDir p) x = Maybe [FilePath] - eval _ opts x = do - let msg0 = "ReadDir" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ do - b <- doesDirectoryExist p - if b then Just <$> listDirectory p - else pure Nothing - pure $ case mb of - Nothing -> mkNode opts (FailT msg1) msg1 [hh pp] - Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] - Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> show0 opts " Just " b) [hh pp] - --- | read an environment variable --- --- >>> pz @(ReadEnv "PATH" >> 'Just Id >> 'True) () --- TrueT --- -data ReadEnv p - -instance (PP p x ~ String, P p x) => P (ReadEnv p) x where - type PP (ReadEnv p) x = Maybe String - eval _ opts x = do - let msg0 = "ReadEnv" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ lookupEnv p - pure $ case mb of - Nothing -> mkNode opts (FailT msg1) msg1 [hh pp] - Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] - Just (Just v) -> mkNode opts (PresentT (Just v)) (msg1 <> showLit0 opts " " v) [hh pp] - --- | read all the environment variables as key value pairs -data ReadEnvAll - -instance P ReadEnvAll a where - type PP ReadEnvAll a = [(String,String)] - eval _ opts _ = do - let msg0 = "ReadEnvAll" - mb <- runIO getEnvironment - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") [] - Just v -> mkNode opts (PresentT v) (msg0 <> " count=" <> show (length v)) [] - --- | get the current time using 'UTCTime' -data TimeUtc - -instance P TimeUtc a where - type PP TimeUtc a = UTCTime - eval _ opts _a = do - let msg0 = "TimeUtc" - mb <- runIO getCurrentTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") [] - Just v -> mkNode opts (PresentT v) (msg0 <> show0 opts " " v) [] - --- | get the current time using 'ZonedTime' -data TimeZt - -instance P TimeZt a where - type PP TimeZt a = ZonedTime - eval _ opts _a = do - let msg0 = "TimeZt" - mb <- runIO getZonedTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") [] - Just v -> mkNode opts (PresentT v) (msg0 <> show0 opts " " v) [] - -data FHandle s = FStdout | FStderr | FOther !s !WFMode deriving Show - -class GetFHandle (x :: FHandle Symbol) where getFHandle :: FHandle String -instance GetFHandle 'FStdout where getFHandle = FStdout -instance GetFHandle 'FStderr where getFHandle = FStderr -instance (GetMode w, KnownSymbol s) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w) - -data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq) - -class GetMode (x :: WFMode) where getMode :: WFMode -instance GetMode 'WFAppend where getMode = WFAppend -instance GetMode 'WFWriteForce where getMode = WFWriteForce -instance GetMode 'WFWrite where getMode = WFWrite - -data WriteFileImpl (hh :: FHandle Symbol) p - --- | append to a file -data AppendFile (s :: Symbol) p -type AppendFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFAppend) p - -instance P (AppendFileT s p) x => P (AppendFile s p) x where - type PP (AppendFile s p) x = PP (AppendFileT s p) x - eval _ = eval (Proxy @(AppendFileT s p)) - - --- | write to file, overwriting if needed -data WriteFile' (s :: Symbol) p -type WriteFileT' (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWriteForce) p - -instance P (WriteFileT' s p) x => P (WriteFile' s p) x where - type PP (WriteFile' s p) x = PP (WriteFileT' s p) x - eval _ = eval (Proxy @(WriteFileT' s p)) - --- | write to file, without overwriting -data WriteFile (s :: Symbol) p -type WriteFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWrite) p - -instance P (WriteFileT s p) x => P (WriteFile s p) x where - type PP (WriteFile s p) x = PP (WriteFileT s p) x - eval _ = eval (Proxy @(WriteFileT s p)) - --- | write a string value to stdout -data Stdout p -type StdoutT p = WriteFileImpl 'FStdout p - -instance P (StdoutT p) x => P (Stdout p) x where - type PP (Stdout p) x = PP (StdoutT p) x - eval _ = eval (Proxy @(StdoutT p)) - --- | write a string value to stderr -data Stderr p -type StderrT p = WriteFileImpl 'FStderr p - -instance P (StderrT p) x => P (Stderr p) x where - type PP (Stderr p) x = PP (StderrT p) x - eval _ = eval (Proxy @(StderrT p)) - -instance (GetFHandle fh - , P p a - , PP p a ~ String - ) => P (WriteFileImpl fh p) a where - type PP (WriteFileImpl fh p) a = () - eval _ opts a = do - let fh = getFHandle @fh - msg0 = case fh of - FStdout -> "Stdout" - FStderr -> "Stderr" - FOther s w -> (<>("[" <> s <> "]")) $ case w of - WFAppend -> "AppendFile" - WFWrite -> "WriteFile" - WFWriteForce -> "WriteFile'" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right ss -> do - mb <- runIO $ case fh of - FStdout -> fmap (left show) $ E.try @E.SomeException $ putStr ss - FStderr -> fmap (left show) $ E.try @E.SomeException $ putStr ss - FOther s w -> do - b <- doesFileExist s - if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists" - else do - let md = case w of - WFAppend -> AppendMode - _ -> WriteMode - fmap (left show) $ E.try @E.SomeException $ withFile s md (`hPutStr` ss) - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") [hh pp] - Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) [hh pp] - Just (Right ()) -> mkNode opts (PresentT ()) msg0 [hh pp] - --- | read in a value of a given type from stdin with a prompt: similar to 'System.IO.readIO' -type ReadIO (t :: Type) = ReadIO' t "Enter value" -type ReadIO' (t :: Type) s = Stdout (s <> ":") >> Stdin >> ReadP t Id --- eg pa @(ReadIO Int + ReadIO Int) () - --- | read a value from stdin -data Stdin - -instance P Stdin x where - type PP Stdin x = String - eval _ opts _x = do - let msg0 = "Stdin" - mb <- runIO $ do - lr <- E.try getLine - pure $ case lr of - Left (e :: E.SomeException) -> Left $ show e - Right ss -> Right ss - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") [] - Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) [] - Just (Right ss) -> mkNode opts (PresentT ss) (msg0 <> "[" <> showLit1 opts "" ss <> "]") [] - ---type Just' = JustFail "expected Just" Id ---type Nothing' = Guard "expected Nothing" IsNothing - --- | similar to 'isInfixOf' 'isPrefixOf' 'isSuffixOf' for strings only. --- --- The \'I\' suffixed versions work are case insensitive. --- --- >>> pz @(IsInfixI "abc" "axAbCd") () --- TrueT --- --- >>> pz @(IsPrefixI "abc" "aBcbCd") () --- TrueT --- --- >>> pz @(IsPrefix "abc" "aBcbCd") () --- FalseT --- --- >>> pz @(IsSuffix "bCd" "aBcbCd") () --- TrueT --- -data IsFixImpl (cmp :: Ordering) (ignore :: Bool) p q - -instance (GetBool ignore - , P p x - , P q x - , PP p x ~ String - , PP q x ~ String - , GetOrdering cmp - ) => P (IsFixImpl cmp ignore p q) x where - type PP (IsFixImpl cmp ignore p q) x = Bool - eval _ opts x = do - let cmp = getOrdering @cmp - ignore = getBool @ignore - lwr = if ignore then map toLower else id - (ff,msg0) = case cmp of - LT -> (isPrefixOf, "IsPrefix") - EQ -> (isInfixOf, "IsInfix") - GT -> (isSuffixOf, "IsSuffix") - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right s0 -> do - let msg1 = msg0 <> (if ignore then "I" else "") <> "(" <> s0 <> ")" - qq <- eval (Proxy @q) opts x - pure $ case getValueLR opts (msg1 <> " q failed") qq [hh pp] of - Left e -> e - Right s1 -> mkNodeB opts (on ff lwr s0 s1) (msg1 <> showLit0 opts " " s1) [hh pp, hh qq] - -data IsPrefix p q -type IsPrefixT p q = IsFixImpl 'LT 'False p q - -instance P (IsPrefixT p q) x => P (IsPrefix p q) x where - type PP (IsPrefix p q) x = PP (IsPrefixT p q) x - eval _ = evalBool (Proxy @(IsPrefixT p q)) - -data IsInfix p q -type IsInfixT p q = IsFixImpl 'EQ 'False p q - -instance P (IsInfixT p q) x => P (IsInfix p q) x where - type PP (IsInfix p q) x = PP (IsInfixT p q) x - eval _ = evalBool (Proxy @(IsInfixT p q)) - -data IsSuffix p q -type IsSuffixT p q = IsFixImpl 'GT 'False p q - -instance P (IsSuffixT p q) x => P (IsSuffix p q) x where - type PP (IsSuffix p q) x = PP (IsSuffixT p q) x - eval _ = evalBool (Proxy @(IsSuffixT p q)) - -data IsPrefixI p q -type IsPrefixIT p q = IsFixImpl 'LT 'True p q - -instance P (IsPrefixIT p q) x => P (IsPrefixI p q) x where - type PP (IsPrefixI p q) x = PP (IsPrefixIT p q) x - eval _ = evalBool (Proxy @(IsPrefixIT p q)) - -data IsInfixI p q -type IsInfixIT p q = IsFixImpl 'EQ 'True p q - -instance P (IsInfixIT p q) x => P (IsInfixI p q) x where - type PP (IsInfixI p q) x = PP (IsInfixIT p q) x - eval _ = evalBool (Proxy @(IsInfixIT p q)) - -data IsSuffixI p q -type IsSuffixIT p q = IsFixImpl 'GT 'True p q - -instance P (IsSuffixIT p q) x => P (IsSuffixI p q) x where - type PP (IsSuffixI p q) x = PP (IsSuffixIT p q) x - eval _ = evalBool (Proxy @(IsSuffixIT p q)) - --- | similar to 'SG.<>' --- --- >>> pz @(Fst Id <> Snd Id) ("abc","def") --- PresentT "abcdef" --- --- >>> pz @("abcd" <> "ef" <> Id) "ghi" --- PresentT "abcdefghi" --- --- >>> pz @("abcd" <> "ef" <> Id) "ghi" --- PresentT "abcdefghi" --- --- >>> pz @(Wrap (SG.Sum _) Id <> FromInteger _ 10) 13 --- PresentT (Sum {getSum = 23}) --- --- >>> pz @(Wrap (SG.Product _) Id <> FromInteger _ 10) 13 --- PresentT (Product {getProduct = 130}) --- --- >>> pz @('(FromInteger _ 10,"def") <> Id) (SG.Sum 12, "_XYZ") --- PresentT (Sum {getSum = 22},"def_XYZ") --- --- >>> pz @(SapA' (SG.Max _)) (10,12) --- PresentT (Max {getMax = 12}) --- --- >>> pz @(SapA' (SG.Sum _)) (10,12) --- PresentT (Sum {getSum = 22}) --- -data p <> q -infixr 6 <> - -instance (Semigroup (PP p x) - , PP p x ~ PP q x - , P p x - , Show (PP q x) - ,P q x - ) => P (p <> q) x where - type PP (p <> q) x = PP p x - eval _ opts x = do - let msg0 = "<>" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <> q - in mkNode opts (PresentT d) (show p <> " <> " <> show q <> " = " <> show d) [hh pp, hh qq] - -data SapA' (t :: Type) -type SapAT' (t :: Type) = Wrap t (Fst Id) <> Wrap t (Snd Id) - -instance P (SapAT' t) x => P (SapA' t) x where - type PP (SapA' t) x = PP (SapAT' t) x - eval _ = eval (Proxy @(SapAT' t)) - -data SapA -type SapAT = Fst Id <> Snd Id - -instance P SapAT x => P SapA x where - type PP SapA x = PP SapAT x - eval _ = eval (Proxy @SapAT) - --- | uses inductive tuples to replace variable arguments --- -class PrintC x where - prtC :: (PrintfArg a, PrintfType r) => String -> (a,x) -> r -instance PrintC () where - prtC s (a,()) = printf s a -instance (PrintfArg a, PrintC rs) => PrintC (a,rs) where - prtC s (a,rs) = prtC s rs a - --- | print for flat n-tuples of size two or larger --- --- >>> pl @(PrintT "%d %s %s %s" '(Fst Id, Snd Id, Snd Id,Snd Id)) (10,"Asdf") --- Present "10 Asdf Asdf Asdf" (PrintT [10 Asdf Asdf Asdf] | s=%d %s %s %s) --- PresentT "10 Asdf Asdf Asdf" --- --- >>> pl @(PrintT "%c %d %s" Id) ('x', 10,"Asdf") --- Present "x 10 Asdf" (PrintT [x 10 Asdf] | s=%c %d %s) --- PresentT "x 10 Asdf" --- --- >>> pz @(PrintT "fst=%s snd=%03d" Id) ("ab",123) --- PresentT "fst=ab snd=123" --- --- >>> pz @(PrintT "fst=%s snd=%03d thd=%s" Id) ("ab",123,"xx") --- PresentT "fst=ab snd=123 thd=xx" --- --- >>> pl @(PrintT "%s %d %c %s" '(W "xyz", Fst Id, Snd Id, Thd Id)) (123,'x',"ab") --- Present "xyz 123 x ab" (PrintT [xyz 123 x ab] | s=%s %d %c %s) --- PresentT "xyz 123 x ab" --- --- >>> pl @(PrintT "%d %c %s" Id) (123,'x') --- Error PrintT(IO e=printf: argument list ended prematurely) (PrintT s=%d %c %s) --- FailT "PrintT(IO e=printf: argument list ended prematurely)" --- --- >>> pl @(PrintT "%d %c %s" Id) (123,'x',"abc",11) --- Error PrintT(IO e=printf: formatting string ended prematurely) (PrintT s=%d %c %s) --- FailT "PrintT(IO e=printf: formatting string ended prematurely)" --- -data PrintT s p -instance (PrintC bs - , (b,bs) ~ InductTupleP y - , InductTupleC y - , PrintfArg b - , PP s x ~ String - , PP p x ~ y - , P s x - , P p x - , CheckT (PP p x) ~ 'True - ) => P (PrintT s p) x where - type PP (PrintT s p) x = String - eval _ opts x = do - let msg0 = "PrintT" - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] - case lrx of - Left e -> pure e - Right (s,y,ss,pp) -> do - let msg1 = msg0 - hhs = [hh ss, hh pp] - lr <- catchitNF @_ @E.SomeException (prtC @bs s (inductTupleC y)) - pure $ case lr of - Left e -> mkNode opts (FailT (msg1 <> "(" <> e <> ")")) (msg1 <> " s=" <> s) hhs - Right ret -> mkNode opts (PresentT ret) (msg1 <> " [" <> showLit0 opts "" ret <> "]" <> showLit0 opts " | s=" s) hhs - --- | print for lists -- use 'PrintT' as it is safer than 'PrintL' --- --- >>> pl @(PrintL 4 "%s %s %s %s" '[W "xyz", ShowP (Fst Id), ShowP (Snd Id), Thd Id]) (123,'x',"ab") --- Present "xyz 123 'x' ab" (PrintL(4) [xyz 123 'x' ab] | s=%s %s %s %s) --- PresentT "xyz 123 'x' ab" --- --- >>> pz @(PrintL 1 "%05d" '[Id]) 123 -- tick is required for a one element list (use 'PrintF') --- PresentT "00123" --- --- >>> pz @(PrintL 2 "%d %05d" [Fst Id,Snd Id]) (29,123) --- PresentT "29 00123" --- --- >>> pl @(PrintL 3 "first=%d second=%d third=%d" Id) [10,11,12] --- Present "first=10 second=11 third=12" (PrintL(3) [first=10 second=11 third=12] | s=first=%d second=%d third=%d) --- PresentT "first=10 second=11 third=12" --- --- >>> pl @(PrintL 2 "first=%d second=%d third=%d" Id) [10,11,12] --- Error PrintL(2) arg count=3 (PrintL(2) wrong length 3) --- FailT "PrintL(2) arg count=3" --- --- >>> pl @(PrintL 4 "first=%d second=%d third=%d" Id) [10,11,12] --- Error PrintL(4) arg count=3 (PrintL(4) wrong length 3) --- FailT "PrintL(4) arg count=3" --- -data PrintL (n :: Nat) s p - -instance (KnownNat n - , PrintC bs - , (b,bs) ~ InductListP n a - , InductListC n a - , PrintfArg b - , PP s x ~ String - , PP p x ~ [a] - , P s x - , P p x - ) => P (PrintL n s p) x where - type PP (PrintL n s p) x = String - eval _ opts x = do - let msg0 = "PrintL(" ++ show n ++ ")" - n = nat @n - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] - case lrx of - Left e -> pure e - Right (s,p,ss,pp) -> do - let hhs = [hh ss, hh pp] - if length p /= n then pure $ mkNode opts (FailT (msg0 <> " arg count=" ++ show (length p))) (msg0 <> " wrong length " ++ show (length p)) hhs - else do - lr <- catchitNF @_ @E.SomeException (prtC @bs s (inductListC @n @a p)) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> "(" <> e <> ")")) (msg0 <> " s=" <> s) hhs - Right ret -> mkNode opts (PresentT ret) (msg0 <> " [" <> showLit0 opts "" ret <> "]" <> showLit0 opts " | s=" s) hhs - -type family CheckT (tp :: Type) :: Bool where - CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") - CheckT o = 'True - -type family ApplyConstT (ta :: Type) (b :: Type) :: Type where ---type family ApplyConstT ta b where -- less restrictive so allows ('Just Int) Bool through! - ApplyConstT (t a) b = t b - ApplyConstT ta b = GL.TypeError ( - 'GL.Text "ApplyConstT: (t a) b but found something else" - ':$$: 'GL.Text "t a = " - ':<>: 'GL.ShowType ta - ':$$: 'GL.Text "b = " - ':<>: 'GL.ShowType b) - --- | similar to 'Control.Applicative.<$' --- --- >>> pz @(Fst Id <$ Snd Id) ("abc",Just 20) --- PresentT (Just "abc") --- -data p <$ q -infixl 4 <$ - -instance (P p x - , P q x - , Show (PP p x) - , Functor t - , PP q x ~ t c - , ApplyConstT (PP q x) (PP p x) ~ t (PP p x) - ) => P (p <$ q) x where - type PP (p <$ q) x = ApplyConstT (PP q x) (PP p x) - eval _ opts x = do - let msg0 = "(<$)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <$ q - in mkNode opts (PresentT d) (msg0 <> show0 opts " " p) [hh pp, hh qq] - -data p <* q -infixl 4 <* - --- | similar to 'Control.Applicative.<*' --- --- >>> pz @(Fst Id <* Snd Id) (Just "abc",Just 20) --- PresentT (Just "abc") --- -type ArrowRT p q = q <* p -data p *> q -infixl 4 *> - -instance P (ArrowRT p q) x => P (p *> q) x where - type PP (p *> q) x = PP (ArrowRT p q) x - eval _ = eval (Proxy @(ArrowRT p q)) - -instance (Show (t c) - , P p x - , P q x - , Show (t b) - , Applicative t - , t b ~ PP p x - , PP q x ~ t c - ) => P (p <* q) x where - type PP (p <* q) x = PP p x - eval _ opts x = do - let msg0 = "(<*)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <* q - in mkNode opts (PresentT d) (show01' opts msg0 p "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - --- | similar to 'Control.Applicative.<|>' --- --- >>> pz @(Fst Id <|> Snd Id) (Nothing,Just 20) --- PresentT (Just 20) --- --- >>> pz @(Fst Id <|> Snd Id) (Just 10,Just 20) --- PresentT (Just 10) --- --- >>> pz @(Fst Id <|> Snd Id) (Nothing,Nothing) --- PresentT Nothing --- -data p <|> q -infixl 3 <|> - -instance (P p x - , P q x - , Show (t b) - , Alternative t - , t b ~ PP p x - , PP q x ~ t b - ) => P (p <|> q) x where - type PP (p <|> q) x = PP p x - eval _ opts x = do - let msg0 = "(<|>)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <|> q - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> show1 opts " | q=" q) [hh pp, hh qq] - - --- | similar to 'Control.Comonad.extract' --- --- >>> pz @Extract (Nothing,Just 20) --- PresentT (Just 20) --- --- >>> pz @Extract (Identity 20) --- PresentT 20 --- -data Extract -instance (Show (t a) - , Show a - , Comonad t - ) => P Extract (t a) where - type PP Extract (t a) = a - eval _ opts ta = - let msg0 = "Extract" - d = extract ta - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d ta) [] - --- | similar to 'Control.Comonad.duplicate' --- --- >>> pz @Duplicate (20,"abc") --- PresentT (20,(20,"abc")) --- -data Duplicate - -instance (Show (t a) - , Show (t (t a)) - , Comonad t - ) => P Duplicate (t a) where - type PP Duplicate (t a) = t (t a) - eval _ opts ta = - let msg0 = "Duplicate" - d = duplicate ta - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d ta) [] - --- | similar to 'Control.Monad.join' --- --- >>> pz @Join (Just (Just 20)) --- PresentT (Just 20) --- --- >>> pz @Join ["ab","cd","","ef"] --- PresentT "abcdef" --- -data Join - -instance (Show (t (t a)) - , Show (t a) - , Monad t - ) => P Join (t (t a)) where - type PP Join (t (t a)) = t a - eval _ opts tta = - let msg0 = "Join" - d = join tta - in pure $ mkNode opts (PresentT d) (show01 opts msg0 d tta) [] - --- | function application for expressions: similar to 'GHC.Base.$' --- --- pz @(Fst Id $$ Snd Id) ((*16),4) --- PresentT 64 --- --- pz @(Id $$ "def") ("abc"<>) --- PresentT "abcdef" --- -data p $$ q -infixl 0 $$ - -instance (P p x - , P q x - , PP p x ~ (a -> b) - , FnT (PP p x) ~ b - , PP q x ~ a - , Show a - , Show b - ) => P (p $$ q) x where - type PP (p $$ q) x = FnT (PP p x) - eval _ opts x = do - let msg0 = "($$)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p q - in mkNode opts (PresentT d) (msg0 <> " " <> show q <> " = " <> show d) [hh pp, hh qq] - --- reify this so we can combine (type synonyms dont work as well) - --- | flipped function application for expressions: similar to 'Control.Lens.&' --- --- pz @(Snd Id $& Fst Id) ((*16),4) --- PresentT 64 --- --- pz @("def" $& Id) ("abc"<>) --- PresentT "abcdef" --- -data q $& p -- flips the args eg a & b & (,) = (b,a) -infixr 1 $& - -instance (P p x - , P q x - , PP p x ~ (a -> b) - , FnT (PP p x) ~ b - , PP q x ~ a - , Show a - , Show b - ) => P (q $& p) x where - type PP (q $& p) x = FnT (PP p x) - eval _ opts x = do - let msg0 = "($&)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p q - in mkNode opts (PresentT d) (msg0 <> " " <> show q <> " = " <> show d) [hh pp, hh qq] - -type family FnT ab :: Type where - FnT (a -> b) = b - FnT ab = GL.TypeError ( - 'GL.Text "FnT: expected Type -> Type but found a simple Type?" - ':$$: 'GL.Text "ab = " - ':<>: 'GL.ShowType ab) - --- | similar to 'T.strip' 'T.stripStart' 'T.stripEnd' --- --- >>> pz @(TrimBoth (Snd Id)) (20," abc " :: String) --- PresentT "abc" --- --- >>> pz @(TrimBoth (Snd Id)) (20,T.pack " abc ") --- PresentT "abc" --- --- >>> pz @(TrimL (Snd Id)) (20," abc ") --- PresentT "abc " --- --- >>> pz @(TrimR (Snd Id)) (20," abc ") --- PresentT " abc" --- --- >>> pz @(TrimR " abc ") () --- PresentT " abc" --- --- >>> pz @(TrimR "") () --- PresentT "" --- --- >>> pz @(TrimBoth " ") () --- PresentT "" --- --- >>> pz @(TrimBoth "") () --- PresentT "" --- -data TrimImpl (left :: Bool) (right :: Bool) p - -instance (FailUnlessT (OrT l r) - ('GL.Text "TrimImpl: left and right cannot both be False") - , GetBool l - , GetBool r - , DTL.IsText (PP p x) - , P p x - ) => P (TrimImpl l r p) x where - type PP (TrimImpl l r p) x = PP p x - eval _ opts x = do - let msg0 = "Trim" ++ (if l && r then "Both" else if l then "L" else "R") - l = getBool @l - r = getBool @r - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (view DTL.unpacked -> p) -> - let fl = if l then dropWhile isSpace else id - fr = if r then dropWhileEnd isSpace else id - b = (fl . fr) p - in mkNode opts (PresentT (b ^. DTL.packed)) (msg0 <> showLit0 opts "" b <> showLit1 opts " | " p) [hh pp] - -data TrimL p -type TrimLT p = TrimImpl 'True 'False p - -instance P (TrimLT p) x => P (TrimL p) x where - type PP (TrimL p) x = PP (TrimLT p) x - eval _ = eval (Proxy @(TrimLT p)) - -data TrimR p -type TrimRT p = TrimImpl 'False 'True p - -instance P (TrimRT p) x => P (TrimR p) x where - type PP (TrimR p) x = PP (TrimRT p) x - eval _ = eval (Proxy @(TrimRT p)) - -data TrimBoth p -type TrimBothT p = TrimImpl 'True 'True p - -instance P (TrimBothT p) x => P (TrimBoth p) x where - type PP (TrimBoth p) x = PP (TrimBothT p) x - eval _ = eval (Proxy @(TrimBothT p)) - --- | similar to 'T.stripLeft' 'T.stripRight' --- --- >>> pz @(StripL "xyz" Id) ("xyzHello" :: String) --- PresentT (Just "Hello") --- --- >>> pz @(StripL "xyz" Id) (T.pack "xyzHello") --- PresentT (Just "Hello") --- --- >>> pz @(StripL "xyz" Id) "xywHello" --- PresentT Nothing --- --- >>> pz @(StripR "xyz" Id) "Hello xyz" --- PresentT (Just "Hello ") --- --- >>> pz @(StripR "xyz" Id) "xyzHelloxyw" --- PresentT Nothing --- --- >>> pz @(StripR "xyz" Id) "" --- PresentT Nothing --- --- >>> pz @(StripR "xyz" "xyz") () --- PresentT (Just "") --- -data StripImpl(left :: Bool) p q - -instance (GetBool l - , PP p x ~ String - , P p x - , DTL.IsText (PP q x) - , P q x - ) => P (StripImpl l p q) x where - type PP (StripImpl l p q) x = Maybe (PP q x) - eval _ opts x = do - let msg0 = "Strip" ++ if l then "L" else "R" - l = getBool @l - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - pure $ case lr of - Left e -> e - Right (p,view DTL.unpacked -> q,pp,qq) -> - let b = if l then - let (before,after) = splitAt (length p) q - in if before == p then Just after else Nothing - else - let (before,after) = splitAt (length q - length p) q - in if after == p then Just before else Nothing - in mkNode opts (PresentT (fmap (view DTL.packed) b)) (msg0 <> show0 opts "" b <> showLit1 opts " | p=" p <> showLit1 opts " | q=" q) [hh pp, hh qq] - -data StripL p q -type StripLT p q = StripImpl 'True p q - -instance P (StripLT p q) x => P (StripL p q) x where - type PP (StripL p q) x = PP (StripLT p q) x - eval _ = eval (Proxy @(StripLT p q)) - -data StripR p q -type StripRT p q = StripImpl 'False p q - -instance P (StripRT p q) x => P (StripR p q) x where - type PP (StripR p q) x = PP (StripRT p q) x - eval _ = eval (Proxy @(StripRT p q)) - --- | creates a promoted list of predicates and then evaluates them into a list. see PP instance for '[k] --- --- >>> pz @(Repeat 4 (Succ Id)) 'c' --- PresentT "dddd" --- --- >>> pz @(Repeat 4 "abc") () --- PresentT ["abc","abc","abc","abc"] --- -data Repeat (n :: Nat) p -instance P (RepeatT n p) a => P (Repeat n p) a where - type PP (Repeat n p) a = PP (RepeatT n p) a - eval _ = eval (Proxy @(RepeatT n p)) - --- | leverages 'Do' for repeating predicates (passthrough method) --- same as @DoN n p == FoldN n p Id@ but more efficient --- --- >>> pz @(DoN 4 (Succ Id)) 'c' --- PresentT 'g' --- --- >>> pz @(DoN 4 (Id <> " | ")) "abc" --- PresentT "abc | | | | " --- --- >>> pz @(DoN 4 (Id <> "|" <> Id)) "abc" --- PresentT "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" --- -data DoN (n :: Nat) p -type DoNT (n :: Nat) p = Do (RepeatT n p) -instance P (DoNT n p) a => P (DoN n p) a where - type PP (DoN n p) a = PP (DoNT n p) a - eval _ = eval (Proxy @(DoNT n p)) - --- | extract the value from a 'Maybe' otherwise use the default value --- --- >>> pz @(JustDef (1 % 4) Id) (Just 20.4) --- PresentT (102 % 5) --- --- >>> pz @(JustDef (1 % 4) Id) Nothing --- PresentT (1 % 4) --- --- >>> pz @(JustDef (MEmptyT _) Id) (Just "xy") --- PresentT "xy" --- --- >>> pz @(JustDef (MEmptyT _) Id) Nothing --- PresentT () --- --- >>> pz @(JustDef (MEmptyT (SG.Sum _)) Id) Nothing --- PresentT (Sum {getSum = 0}) --- -data JustDef p q - -instance ( PP p x ~ a - , PP q x ~ Maybe a - , P p x - , P q x) - => P (JustDef p q) x where - type PP (JustDef p q) x = MaybeT (PP q x) - eval _ opts x = do - let msg0 = "JustDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] - Nothing -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right b -> mkNode opts (PresentT b) (msg0 <> " Nothing") [hh qq, hh pp] - - -type family MaybeT mb where - MaybeT (Maybe a) = a - MaybeT o = GL.TypeError ( - 'GL.Text "MaybeT: expected 'Maybe a' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - --- | extract the value from a 'Maybe' or fail --- --- >>> pz @(JustFail "nope" Id) (Just 99) --- PresentT 99 --- --- >>> pz @(JustFail "nope" Id) Nothing --- FailT "nope" --- --- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Nothing, 123) --- FailT "oops=123" --- --- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Just 'x', 123) --- PresentT 'x' --- -data JustFail p q - -instance ( PP p x ~ String - , PP q x ~ Maybe a - , P p x - , P q x) - => P (JustFail p q) x where - type PP (JustFail p q) x = MaybeT (PP q x) - eval _ opts x = do - let msg0 = "JustFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] - Nothing -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Nothing") [hh qq, hh pp] - --- | extract the Left value from an 'Either' otherwise use the default value --- --- if there is no Left value then \p\ is passed the Right value and the whole context --- --- >>> pz @(LeftDef (1 % 4) Id) (Left 20.4) --- PresentT (102 % 5) --- --- >>> pz @(LeftDef (1 % 4) Id) (Right "aa") --- PresentT (1 % 4) --- --- >>> pz @(LeftDef (PrintT "found right=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Right "xy") --- PresentT "found right=xy fst=123" --- --- >>> pz @(LeftDef (MEmptyT _) Id) (Right 222) --- PresentT () --- --- >>> pz @(LeftDef (MEmptyT (SG.Sum _)) Id) (Right 222) --- PresentT (Sum {getSum = 0}) --- -data LeftDef p q - -instance ( PP q x ~ Either a b - , PP p (b,x) ~ a - , P q x - , P p (b,x) - ) => P (LeftDef p q) x where - type PP (LeftDef p q) x = LeftT (PP q x) - eval _ opts x = do - let msg0 = "LeftDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Left a -> pure $ mkNode opts (PresentT a) (msg0 <> " Left") [hh qq] - Right b -> do - pp <- eval (Proxy @p) opts (b,x) - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " Right") [hh qq, hh pp] - -type family LeftT lr where - LeftT (Either a b) = a - LeftT o = GL.TypeError ( - 'GL.Text "LeftT: expected 'Either a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - -type family RightT lr where - RightT (Either a b) = b - RightT o = GL.TypeError ( - 'GL.Text "RightT: expected 'Either a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - --- | extract the Right value from an 'Either' --- --- if there is no Right value then \p\ is passed the Left value and the whole context --- --- >>> pz @(RightDef (1 % 4) Id) (Right 20.4) --- PresentT (102 % 5) --- --- >>> pz @(RightDef (1 % 4) Id) (Left "aa") --- PresentT (1 % 4) --- --- >>> pz @(RightDef (PrintT "found left=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Left "xy") --- PresentT "found left=xy fst=123" --- --- >>> pz @(RightDef (MEmptyT _) Id) (Left 222) --- PresentT () --- --- >>> pz @(RightDef (MEmptyT (SG.Sum _)) Id) (Left 222) --- PresentT (Sum {getSum = 0}) --- -data RightDef p q - -instance ( PP q x ~ Either a b - , PP p (a,x) ~ b - , P q x - , P p (a,x) - ) => P (RightDef p q) x where - type PP (RightDef p q) x = RightT (PP q x) - eval _ opts x = do - let msg0 = "RightDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Right b -> pure $ mkNode opts (PresentT b) (msg0 <> " Right") [hh qq] - Left a -> do - pp <- eval (Proxy @p) opts (a,x) - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " Left") [hh qq, hh pp] - - --- | extract the Left value from an 'Either' otherwise fail with a message --- --- if there is no Left value then \p\ is passed the Right value and the whole context --- --- >>> pz @(LeftFail "oops" Id) (Left 20.4) --- PresentT 20.4 --- --- >>> pz @(LeftFail "oops" Id) (Right "aa") --- FailT "oops" --- --- >>> pz @(LeftFail (PrintT "found right=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Right "xy") --- FailT "found right=xy fst=123" --- --- >>> pz @(LeftFail (MEmptyT _) Id) (Right 222) --- FailT "" --- -data LeftFail p q - -instance ( PP p (b,x) ~ String - , PP q x ~ Either a b - , P p (b,x) - , P q x) - => P (LeftFail p q) x where - type PP (LeftFail p q) x = LeftT (PP q x) - eval _ opts x = do - let msg0 = "LeftFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Left a -> pure $ mkNode opts (PresentT a) (msg0 <> " Left") [hh qq] - Right b -> do - pp <- eval (Proxy @p) opts (b,x) - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Right") [hh qq, hh pp] - - --- | extract the Right value from an 'Either' otherwise fail with a message --- --- if there is no Right value then \p\ is passed the Left value and the whole context --- --- >>> pz @(RightFail "oops" Id) (Right 20.4) --- PresentT 20.4 --- --- >>> pz @(RightFail "oops" Id) (Left "aa") --- FailT "oops" --- --- >>> pz @(RightFail (PrintT "found left=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Left "xy") --- FailT "found left=xy fst=123" --- --- >>> pz @(RightFail (MEmptyT _) Id) (Left 222) --- FailT "" --- -data RightFail p q - -instance ( PP p (a,x) ~ String - , PP q x ~ Either a b - , P p (a,x) - , P q x) - => P (RightFail p q) x where - type PP (RightFail p q) x = RightT (PP q x) - eval _ opts x = do - let msg0 = "RightFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - Right b -> pure $ mkNode opts (PresentT b) (msg0 <> " Right") [hh qq] - Left a -> do - pp <- eval (Proxy @p) opts (a,x) - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Left") [hh qq, hh pp] - - - --- | extract the This value from an 'These' otherwise use the default value --- --- if there is no This value then \p\ is passed the whole context only --- --- >>> pz @(ThisDef (1 % 4) Id) (This 20.4) --- PresentT (102 % 5) --- --- >>> pz @(ThisDef (1 % 4) Id) (That "aa") --- PresentT (1 % 4) --- --- >>> pz @(ThisDef (1 % 4) Id) (These 2.3 "aa") --- PresentT (1 % 4) --- --- >>> pz @(ThisDef (PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id)) (Snd Id)) (123,That "xy") --- PresentT "found That \"xy\" fst=123" --- --- >>> pz @(ThisDef (MEmptyT _) Id) (That 222) --- PresentT () --- --- >>> pz @(ThisDef (MEmptyT (SG.Sum _)) Id) (These 222 'x') --- PresentT (Sum {getSum = 0}) --- -data ThisDef p q - -instance ( PP q x ~ These a b - , PP p x ~ a - , P q x - , P p x - ) => P (ThisDef p q) x where - type PP (ThisDef p q) x = ThisT (PP q x) - eval _ opts x = do - let msg0 = "ThisDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - This a -> pure $ mkNode opts (PresentT a) (msg0 <> " This") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - -type family ThisT lr where - ThisT (These a b) = a - ThisT o = GL.TypeError ( - 'GL.Text "ThisT: expected 'These a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - -type family ThatT lr where - ThatT (These a b) = b - ThatT o = GL.TypeError ( - 'GL.Text "ThatT: expected 'These a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - -type family TheseT lr where - TheseT (These a b) = (a,b) - TheseT o = GL.TypeError ( - 'GL.Text "TheseT: expected 'These a b' " - ':$$: 'GL.Text "o = " - ':<>: 'GL.ShowType o) - - --- | extract the That value from an 'These' otherwise use the default value --- --- if there is no That value then \p\ is passed the whole context only --- --- >>> pz @(ThatDef (1 % 4) Id) (That 20.4) --- PresentT (102 % 5) --- --- >>> pz @(ThatDef (1 % 4) Id) (This "aa") --- PresentT (1 % 4) --- --- >>> pz @(ThatDef (1 % 4) Id) (These "aa" 2.3) --- PresentT (1 % 4) --- --- >>> pz @(ThatDef (PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id)) (Snd Id)) (123,This "xy") --- PresentT "found This \"xy\" fst=123" --- --- >>> pz @(ThatDef (MEmptyT _) Id) (This 222) --- PresentT () --- --- >>> pz @(ThatDef (MEmptyT (SG.Sum _)) Id) (These 'x' 1120) --- PresentT (Sum {getSum = 0}) --- -data ThatDef p q - -instance ( PP q x ~ These a b - , PP p x ~ b - , P q x - , P p x - ) => P (ThatDef p q) x where - type PP (ThatDef p q) x = ThatT (PP q x) - eval _ opts x = do - let msg0 = "ThatDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - That a -> pure $ mkNode opts (PresentT a) (msg0 <> " That") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - --- | extract the These value from an 'These' otherwise use the default value --- --- if there is no These value then \p\ is passed the whole context only --- --- >>> pz @(TheseDef '(1 % 4,"zz") Id) (These 20.4 "x") --- PresentT (102 % 5,"x") --- --- >>> pz @(TheseDef '(1 % 4,"zz") Id) (This 20.4) --- PresentT (1 % 4,"zz") --- --- >>> pz @(TheseDef '(1 % 4,"zz") Id) (That "x") --- PresentT (1 % 4,"zz") --- --- >>> pz @(TheseDef '(PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id),999) (Snd Id)) (123,This "xy") --- PresentT ("found This \"xy\" fst=123",999) --- --- >>> pz @(TheseDef (MEmptyT (SG.Sum _, String)) Id) (This 222) --- PresentT (Sum {getSum = 0},"") --- --- >>> pz @(TheseDef (MEmptyT _) Id) (These (222 :: SG.Sum Int) "aa") --- PresentT (Sum {getSum = 222},"aa") --- -data TheseDef p q - -instance ( PP q x ~ These a b - , PP p x ~ (a,b) - , P q x - , P p x - ) => P (TheseDef p q) x where - type PP (TheseDef p q) x = TheseT (PP q x) - eval _ opts x = do - let msg0 = "TheseDef" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - These a b -> pure $ mkNode opts (PresentT (a,b)) (msg0 <> " These") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - - --- | extract the This value from a 'These' otherwise fail with a message --- --- if there is no This value then \p\ is passed the whole context only --- --- >>> pz @(ThisFail "oops" Id) (This 20.4) --- PresentT 20.4 --- --- >>> pz @(ThisFail "oops" Id) (That "aa") --- FailT "oops" --- --- >>> pz @(ThisFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,That "xy") --- FailT "found That \"xy\" fst=123" --- --- >>> pz @(ThisFail (MEmptyT _) Id) (That 222) --- FailT "" --- -data ThisFail p q - -instance ( PP p x ~ String - , PP q x ~ These a b - , P p x - , P q x) - => P (ThisFail p q) x where - type PP (ThisFail p q) x = ThisT (PP q x) - eval _ opts x = do - let msg0 = "ThisFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - This a -> pure $ mkNode opts (PresentT a) (msg0 <> " This") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - - --- | extract the That value from a 'These' otherwise fail with a message --- --- if there is no That value then \p\ is passed the whole context only --- --- >>> pz @(ThatFail "oops" Id) (That 20.4) --- PresentT 20.4 --- --- >>> pz @(ThatFail "oops" Id) (This "aa") --- FailT "oops" --- --- >>> pz @(ThatFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,This "xy") --- FailT "found This \"xy\" fst=123" --- --- >>> pz @(ThatFail (MEmptyT _) Id) (This 222) --- FailT "" --- -data ThatFail p q - -instance ( PP p x ~ String - , PP q x ~ These a b - , P p x - , P q x) - => P (ThatFail p q) x where - type PP (ThatFail p q) x = ThatT (PP q x) - eval _ opts x = do - let msg0 = "ThatFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - That a -> pure $ mkNode opts (PresentT a) (msg0 <> " That") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - - - - --- | extract the These value from a 'These' otherwise fail with a message --- --- if there is no These value then \p\ is passed the whole context only --- --- >>> pz @(TheseFail "oops" Id) (These "abc" 20.4) --- PresentT ("abc",20.4) --- --- >>> pz @(TheseFail "oops" Id) (That "aa") --- FailT "oops" --- --- >>> pz @(TheseFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,That "xy") --- FailT "found That \"xy\" fst=123" --- --- >>> pz @(TheseFail (MEmptyT _) Id) (That 222) --- FailT "" --- -data TheseFail p q - -instance ( PP p x ~ String - , PP q x ~ These a b - , P p x - , P q x) - => P (TheseFail p q) x where - type PP (TheseFail p q) x = TheseT (PP q x) - eval _ opts x = do - let msg0 = "TheseFail" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> - case q of - These a b -> pure $ mkNode opts (PresentT (a,b)) (msg0 <> " These") [hh qq] - _ -> do - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of - Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] - --- | takes the head of a list like container --- --- >>> pz @(Head Id) "abcd" --- PresentT 'a' --- --- >>> pz @(Head Id) [] --- FailT "Head(empty)" --- -data Head p - -instance (Show (ConsT s) - , Show s - , Cons s s (ConsT s) (ConsT s) - , PP p x ~ s - , P p x - ) => P (Head p) x where - type PP (Head p) x = ConsT (PP p x) - eval _ opts x = do - let msg0 = "Head" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p ^? _Cons of - Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) (msg0 <> " no data") [hh pp] - Just (a,_) -> mkNode opts (PresentT a) (show01 opts msg0 a p) [hh pp] - --- | takes the tail of a list like container --- --- >>> pz @(Tail Id) "abcd" --- PresentT "bcd" --- --- >>> pz @(Tail Id) [] --- FailT "Tail(empty)" --- -data Tail p - -instance (Show s - , Cons s s (ConsT s) (ConsT s) - , PP p x ~ s - , P p x - ) => P (Tail p) x where - type PP (Tail p) x = PP p x - eval _ opts x = do - let msg0 = "Tail" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p ^? _Cons of - Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) (msg0 <> " no data") [hh pp] - Just (_,as) -> mkNode opts (PresentT as) (show01 opts msg0 as p) [hh pp] - - --- | takes the last of a list like container --- --- >>> pz @(Last Id) "abcd" --- PresentT 'd' --- --- >>> pz @(Last Id) [] --- FailT "Last(empty)" --- - -data Last p - -instance (Show (ConsT s) - , Show s - , Snoc s s (ConsT s) (ConsT s) - , PP p x ~ s - , P p x - ) => P (Last p) x where - type PP (Last p) x = ConsT (PP p x) - eval _ opts x = do - let msg0 = "Last" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p ^? _Snoc of - Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) (msg0 <> " no data") [hh pp] - Just (_,a) -> mkNode opts (PresentT a) (show01 opts msg0 a p) [hh pp] - --- | takes the init of a list like container --- --- >>> pz @(Init Id) "abcd" --- PresentT "abc" --- --- >>> pz @(Init Id) (T.pack "abcd") --- PresentT "abc" --- --- >>> pz @(Init Id) [] --- FailT "Init(empty)" --- - -data Init p - -instance (Show s - , Snoc s s (ConsT s) (ConsT s) - , PP p x ~ s - , P p x - ) => P (Init p) x where - type PP (Init p) x = PP p x - eval _ opts x = do - let msg0 = "Init" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p ^? _Snoc of - Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) (msg0 <> " no data") [hh pp] - Just (as,_) -> mkNode opts (PresentT as) (show01 opts msg0 as p) [hh pp] - - --- | tries to extract @a@ from @Maybe a@ otherwise it fails --- --- >>> pz @(Just Id) (Just "abc") --- PresentT "abc" --- --- >>> pz @(Just Id) Nothing --- FailT "Just(empty)" --- -data Just p - -instance (Show a - , PP p x ~ Maybe a - , P p x - ) => P (Just p) x where - type PP (Just p) x = MaybeT (PP p x) - eval _ opts x = do - let msg0 = "Just" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p of - Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) (msg0 <> " found Nothing") [hh pp] - Just d -> mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - - --- | compose simple functions --- --- >>> pl @(Dot '[Thd,Snd,Fst] Id) ((1,(2,9,10)),(3,4)) --- Present 10 (Thd 10 | (2,9,10)) --- PresentT 10 --- -data Dot (ps :: [Type -> Type]) (q :: Type) -instance (P (DotExpandT ps q) a) => P (Dot ps q) a where - type PP (Dot ps q) a = PP (DotExpandT ps q) a - eval _ = eval (Proxy @(DotExpandT ps q)) - -type family DotExpandT (ps :: [Type -> Type]) (q :: Type) :: Type where - DotExpandT '[] _ = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") - DotExpandT '[p] q = p $ q - DotExpandT (p ': p1 ': ps) q = p $ DotExpandT (p1 ': ps) q - --- | reversed dot --- --- >>> pl @(RDot '[Fst,Snd,Thd] Id) ((1,(2,9,10)),(3,4)) --- Present 10 (Thd 10 | (2,9,10)) --- PresentT 10 --- --- >>> pl @(RDot '[Fst,Snd] Id) (('a',2),(True,"zy")) --- Present 2 (Snd 2 | ('a',2)) --- PresentT 2 --- -data RDot (ps :: [Type -> Type]) (q :: Type) -instance P (RDotExpandT ps q) a => P (RDot ps q) a where - type PP (RDot ps q) a = PP (RDotExpandT ps q) a - eval _ = eval (Proxy @(RDotExpandT ps q)) - -type family RDotExpandT (ps :: [Type -> Type]) (q :: Type) :: Type where - RDotExpandT '[] _ = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") - RDotExpandT '[p] q = p $ q - RDotExpandT (p ': p1 ': ps) q = RDotExpandT (p1 ': ps) (p $ q) - --- | like 'GHC.Base.$' for expressions --- --- >>> pl @(Fst $ Snd $ Id) ((1,2),(3,4)) --- Present 3 (Fst 3 | (3,4)) --- PresentT 3 --- --- >>> pl @((<=) 4 $ Fst $ Snd $ Id) ((1,2),(3,4)) --- False (4 <= 3) --- FalseT --- -data (p :: k -> k1) $ (q :: k) -infixr 0 $ - -instance P (p q) a => P (p $ q) a where - type PP (p $ q) a = PP (p q) a - eval _ = eval (Proxy @(p q)) - --- | similar to 'Control.Lens.&' --- --- >>> pl @(Id & Fst & Singleton & Length) (13,"xyzw") --- Present 1 (Length 1 | [13]) --- PresentT 1 --- --- >>> pl @(2 & (&&&) "abc") () --- Present ("abc",2) (W'(,)) --- PresentT ("abc",2) --- --- >>> pl @(2 & '(,) "abc") () --- Present ("abc",2) ('(,)) --- PresentT ("abc",2) --- --- >>> pl @('(,) 4 $ '(,) 7 $ "aa") () --- Present (4,(7,"aa")) ('(,)) --- PresentT (4,(7,"aa")) --- --- >>> pl @(Thd $ Snd $ Fst Id) ((1,("W",9,'a')),(3,4)) --- Present 'a' (Thd 'a' | ("W",9,'a')) --- PresentT 'a' --- -data (q :: k) & (p :: k -> k1) -infixl 1 & - -instance P (p q) a => P (q & p) a where - type PP (q & p) a = PP (p q) a - eval _ = eval (Proxy @(p q)) - --- | creates a constant expression ignoring the second argument --- --- >>> pl @(RDot '[Fst,Snd,Thd,K "xxx"] Id) ((1,(2,9,10)),(3,4)) --- Present "xxx" (K'xxx) --- PresentT "xxx" --- --- >>> pl @(RDot '[Fst,Snd,Thd,K '("abc",Id)] Id) ((1,(2,9,10)),(3,4)) --- Present ("abc",((1,(2,9,10)),(3,4))) (K'(,)) --- PresentT ("abc",((1,(2,9,10)),(3,4))) --- --- >>> pl @(Thd $ Snd $ Fst $ K Id "dud") ((1,("W",9,'a')),(3,4)) --- Present 'a' (Thd 'a' | ("W",9,'a')) --- PresentT 'a' --- --- >>> pl @((Thd $ Snd $ Fst $ K Id "dud") >> Pred Id) ((1,("W",9,'a')),(3,4)) --- Present '`' ((>>) '`' | {Pred '`' | 'a'}) --- PresentT '`' --- -data K (p :: k) (q :: k1) -instance P p a => P (K p q) a where - type PP (K p q) a = PP p a - eval _ = eval (Proxy @(Msg "K" p)) - --- | applies \'p\' to the first and second slot of an n-tuple --- --- >>> pl @(Both Len (Fst Id)) (("abc",[10..17],1,2,3),True) --- Present (3,8) (Both) --- PresentT (3,8) --- --- >>> pl @(Both (Pred Id) $ Fst Id) ((12,'z',[10..17]),True) --- Present (11,'y') (Both) --- PresentT (11,'y') --- --- >>> pl @(Both (Succ Id) Id) (4,'a') --- Present (5,'b') (Both) --- PresentT (5,'b') --- --- >>> pl @(Both Len (Fst Id)) (("abc",[10..17]),True) --- Present (3,8) (Both) --- PresentT (3,8) --- --- >>> pl @(Both (ReadP Day Id) Id) ("1999-01-01","2001-02-12") --- Present (1999-01-01,2001-02-12) (Both) --- PresentT (1999-01-01,2001-02-12) --- -data Both p q -instance ( ExtractL1C (PP q x) - , ExtractL2C (PP q x) - , P p (ExtractL1T (PP q x)) - , P p (ExtractL2T (PP q x)) - , P q x - ) => P (Both p q) x where - type PP (Both p q) x = (PP p (ExtractL1T (PP q x)), PP p (ExtractL2T (PP q x))) - eval _ opts x = do - let msg0 = "Both" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - let (a,a') = (extractL1C q, extractL2C q) - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [hh qq] of - Left e -> pure e - Right b -> do - pp' <- eval (Proxy @p) opts a' - pure $ case getValueLR opts msg0 pp' [hh qq, hh pp] of - Left e -> e - Right b' -> - mkNode opts (PresentT (b,b')) msg0 [hh qq, hh pp, hh pp'] - --- | gets the singleton value from a foldable --- --- >>> pl @(OneP Id) [10..15] --- Error OneP 6 elements (OneP expected one element) --- FailT "OneP 6 elements" --- --- >>> pl @(OneP Id) [10] --- Present 10 (OneP) --- PresentT 10 --- --- >>> pl @(OneP Id) [] --- Error OneP empty (OneP expected one element) --- FailT "OneP empty" --- --- >>> pl @(OneP Id) (Just 10) --- Present 10 (OneP) --- PresentT 10 --- --- >>> pl @(OneP Id) Nothing --- Error OneP empty (OneP expected one element) --- FailT "OneP empty" --- -data OneP p -instance (Foldable t - , PP p x ~ t a - , P p x - ) => P (OneP p) x where - type PP (OneP p) x = ExtractAFromTA (PP p x) - eval _ opts x = do - let msg0 = "OneP" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> case toList p of - [] -> mkNode opts (FailT (msg0 <> " empty")) (msg0 <> " expected one element") [hh pp] - [a] -> mkNode opts (PresentT a) msg0 [hh pp] - as -> let n = length as - in mkNode opts (FailT (msg0 <> " " <> show n <> " elements")) (msg0 <> " expected one element") [hh pp] - --- | parse json data --- --- >>> pl @(ParseJson (Int,String) Id) "[10,\"abc\"]" --- Present (10,"abc") (ParseJson (Int,[Char]) (10,"abc")) --- PresentT (10,"abc") --- --- >>> pl @(ParseJson (Int,String) Id) "[10,\"abc\",99]" --- Error ParseJson (Int,[Char])([10,"abc",...) Error in $ (ParseJson (Int,[Char]) failed Error in $: cannot unpack array of length 3 into a tuple of length 2 | [10,"abc",99]) --- FailT "ParseJson (Int,[Char])([10,\"abc\",...) Error in $" --- --- >>> pl @(ParseJson (Int,Bool) (FromString _ Id)) ("[1,true]" :: String) --- Present (1,True) (ParseJson (Int,Bool) (1,True)) --- PresentT (1,True) --- --- >>> pl @(ParseJson (Int,Bool) Id) (A.encode (1,True)) --- Present (1,True) (ParseJson (Int,Bool) (1,True)) --- PresentT (1,True) --- --- >>> pl @(ParseJson () Id) "[1,true]" --- Error ParseJson ()([1,true]) Error in $ (ParseJson () failed Error in $: parsing () failed, expected an empty array | [1,true]) --- FailT "ParseJson ()([1,true]) Error in $" --- -data ParseJson' t p - -instance (P p x - , PP p x ~ BL8.ByteString - , Typeable (PP t x) - , Show (PP t x) - , A.FromJSON (PP t x) - ) => P (ParseJson' t p) x where - type PP (ParseJson' t p) x = PP t x - eval _ opts x = do - let msg0 = "ParseJson " <> t - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> - let hhs = [hh pp] - msg1 = msg0 <> "(" ++ litBL 10 s ++ ")" - in case A.eitherDecode' s of - Right b -> mkNode opts (PresentT b) (msg0 <> " " ++ showL 30 b) hhs - Left e -> mkNode opts (FailT (msg1 <> " " <> takeWhile (/=':') e) ) (msg0 <> " failed " <> e <> " | " <> litBL (oWidth opts) s) hhs - -data ParseJson (t :: Type) p -type ParseJsonT (t :: Type) p = ParseJson' (Hole t) p - -instance P (ParseJsonT t p) x => P (ParseJson t p) x where - type PP (ParseJson t p) x = PP (ParseJsonT t p) x - eval _ = eval (Proxy @(ParseJsonT t p)) - --- | parse a json file --- --- >>> pz @(ParseJsonFile [A.Value] "test1.json" >> Id !! 2) () --- PresentT (Object (fromList [("lastName",String "Doe"),("age",Number 45.0),("firstName",String "John"),("likesPizza",Bool False)])) --- -data ParseJsonFile' t p - -instance (P p x - , PP p x ~ String - , Typeable (PP t x) - , Show (PP t x) - , A.FromJSON (PP t x) - ) => P (ParseJsonFile' t p) x where - type PP (ParseJsonFile' t p) x = PP t x - eval _ opts x = do - let msg0 = "ParseJsonFile " <> t - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let hhs = [hh pp] - msg1 = msg0 <> "(" <> p <> ")" - mb <- runIO $ do - b <- doesFileExist p - if b then Just <$> BS8.readFile p - else pure Nothing - pure $ case mb of - Nothing -> mkNode opts (FailT msg1) msg1 hhs - Just Nothing -> mkNode opts (FailT (msg1 <> " file does not exist")) msg1 hhs - Just (Just s) -> - case A.eitherDecodeStrict' s of - Right b -> mkNode opts (PresentT b) (msg1 <> " " ++ showL (if isVerbose opts then oWidth opts else min (oWidth opts) 80) b) hhs - Left e -> mkNode opts (FailT (msg1 <> " " <> takeWhile (/=':') e)) (msg0 <> " failed " <> e <> " | " <> litBS (oWidth opts) s) hhs - -data ParseJsonFile (t :: Type) p -type ParseJsonFileT (t :: Type) p = ParseJsonFile' (Hole t) p - -instance P (ParseJsonFileT t p) x => P (ParseJsonFile t p) x where - type PP (ParseJsonFile t p) x = PP (ParseJsonFileT t p) x - eval _ = eval (Proxy @(ParseJsonFileT t p)) - --- | encode json --- --- >>> pl @(EncodeJson Id) (10,"def") --- Present "[10,\"def\"]" (EncodeJson [10,"def"]) --- PresentT "[10,\"def\"]" --- --- >>> pl @(EncodeJson Id >> ParseJson (Int,Bool) Id) (1,True) --- Present (1,True) ((>>) (1,True) | {ParseJson (Int,Bool) (1,True)}) --- PresentT (1,True) --- -data EncodeJson p - -instance (A.ToJSON (PP p x), P p x) => P (EncodeJson p) x where - type PP (EncodeJson p) x = BL8.ByteString - eval _ opts x = do - let msg0 = "EncodeJson" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = A.encode p - in mkNode opts (PresentT d) (msg0 <> showLit0 opts " " (litBL (oWidth opts) d)) [hh pp] - --- | encode a json file -data EncodeJsonFile p q - -instance (PP p x ~ String - , P p x - , A.ToJSON (PP q x) - , P q x - ) => P (EncodeJsonFile p q) x where - type PP (EncodeJsonFile p q) x = () - eval _ opts x = do - let msg0 = "EncodeJsonFile" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let d = A.encode q - hhs = [hh pp, hh qq] - mb <- runIO $ BL8.writeFile p d - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) (msg0 <> " must run in IO") hhs - Just () -> mkNode opts (PresentT ()) (msg0 <> showLit0 opts " " (litBL (oWidth opts) d)) hhs - --- | uncurry experiment --- --- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2019-10-12" --- False (Uncurry (2019-10-12 <= 2018-12-30)) --- FalseT --- --- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2017-10-12" --- True (Uncurry (2017-04-11 <= 2017-10-12 <= 2018-12-30)) --- TrueT --- --- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2016-10-12" --- False (Uncurry (2017-04-11 <= 2016-10-12)) --- FalseT --- -data Uncurry (p :: Type -> Type -> Type -> Type) q r - -instance (PP q x ~ (a,b) - , PP (p a b (PP r x)) x ~ PP (p (Fst Id) (Snd Id) (Thd Id)) (a, b, PP r x) - , P q x - , P r x - , P (p (Fst Id) (Snd Id) (Thd Id)) (a,b,PP r x) - ) => P (Uncurry p q r) x where - type PP (Uncurry p q r) x = PP (p (ExtractL1T (PP q x)) (ExtractL2T (PP q x)) (PP r x)) x - eval _ opts x = do - let msg0 = "Uncurry" - lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts x [] - case lr of - Left e -> pure e - Right ((q1,q2),r,qq,rr) -> do - let hhs0 = [hh qq, hh rr] - pp <- eval (Proxy @(p (Fst Id) (Snd Id) (Thd Id))) opts (q1,q2,r) - pure $ case getValueLR opts msg0 pp hhs0 of - Left e -> e - Right _ -> - let hhs = hhs0 ++ [hh pp] - in mkNode opts (_tBool pp) (msg0 <> " " <> topMessage pp) hhs - --- | like 'Predicate.Prelude.&&' but for a tuple --- --- >>> pl @(SplitAt 4 "abcdefg" >> Len > 4 &* Len < 5) () --- False ((>>) False | {False (&*) True | (4 > 4)}) --- FalseT --- -data AndA p q r -instance (PP r x ~ (a,b) - , PP p a ~ Bool - , PP q b ~ Bool - , P p a - , P q b - , P r x - ) => P (AndA p q r) x where - type PP (AndA p q r) x = Bool - eval _ opts x = do - let msg0 = "(&*)" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right (r1,r2) -> do - pp <- evalBool (Proxy @p) opts r1 - case getValueLR opts msg0 pp [hh rr] of - Left e -> pure e - Right p -> do - qq <- evalBool (Proxy @q) opts r2 - pure $ case getValueLR opts msg0 qq [hh rr, hh pp] of - Left e -> e - Right q -> - let zz = case (p,q) of - (True, True) -> "" - (False, True) -> topMessage pp - (True, False) -> topMessage qq - (False, False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - in mkNodeB opts (p&&q) (show p <> " " <> msg0 <> " " <> show q <> (if null zz then zz else " | " <> zz)) [hh rr, hh pp, hh qq] - -data p &* q -type AndAT p q = AndA p q Id -infixr 3 &* - -instance P (AndAT p q) x => P (p &* q) x where - type PP (p &* q) x = PP (AndAT p q) x - eval _ = evalBool (Proxy @(AndAT p q)) - -{- -data p &&! q -type AndAT' p q = (Fst Id >> p) && (Snd Id >> q) -infixr 3 &&! - -instance (P (AndAT' p q) x - ) => P (p &&! q) x where - type PP (p &&! q) x = PP (AndAT' p q) x - eval _ = evalBool (Proxy @(AndAT' p q)) --} - --- | like 'Predicate.Prelude.||' but for a tuple --- --- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,8,14,44],9) --- True (True (|+) False) --- TrueT --- --- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],9) --- False (False (|+) False | (32 > 44) (|+) (9 < 2)) --- FalseT --- --- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],1) --- True (False (|+) True) --- TrueT --- -data OrA p q r -instance (PP r x ~ (a,b) - , PP p a ~ Bool - , PP q b ~ Bool - , P p a - , P q b - , P r x - ) => P (OrA p q r) x where - type PP (OrA p q r) x = Bool - eval _ opts x = do - let msg0 = "(|+)" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right (r1,r2) -> do - pp <- evalBool (Proxy @p) opts r1 - case getValueLR opts msg0 pp [hh rr] of - Left e -> pure e - Right p -> do - qq <- evalBool (Proxy @q) opts r2 - pure $ case getValueLR opts msg0 qq [hh rr, hh pp] of - Left e -> e - Right q -> - let zz = case (p,q) of - (False,False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq - _ -> "" - in mkNodeB opts (p||q) (show p <> " " <> msg0 <> " " <> show q <> (if null zz then zz else " | " <> zz)) [hh rr, hh pp, hh qq] - -data p |+ q -type OrAT p q = OrA p q Id -infixr 3 |+ - -instance P (OrAT p q) x => P (p |+ q) x where - type PP (p |+ q) x = PP (OrAT p q) x - eval _ = evalBool (Proxy @(OrAT p q)) - --- | very simple conversion to a string -data ToString p -instance (ToStringC (PP p x), P p x) => P (ToString p) x where - type PP (ToString p) x = String - eval _ opts x = do - let msg0 = "ToString" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = toStringC p - in mkNode opts (PresentT d) msg0 [hh pp] - -class ToStringC a where - toStringC :: a -> String -instance ToStringC String where - toStringC = id -instance ToStringC T.Text where - toStringC = T.unpack -instance ToStringC TL.Text where - toStringC = TL.unpack -instance ToStringC BL8.ByteString where - toStringC = BL8.unpack -instance ToStringC BS8.ByteString where - toStringC = BS8.unpack - --- | splits a list pointed to by \'p\' into lists of size \'n\' --- --- >>> pz @(ChunksOf 2 Id) "abcdef" --- PresentT ["ab","cd","ef"] --- --- >>> pz @(ChunksOf 2 Id) "abcdefg" --- PresentT ["ab","cd","ef","g"] --- --- >>> pz @(ChunksOf 2 Id) "" --- PresentT [] --- --- >>> pz @(ChunksOf 2 Id) "a" --- PresentT ["a"] --- -data ChunksOf n p - -instance (PP p a ~ [b] - , P n a - , P p a - , Show b - , Integral (PP n a) - ) => P (ChunksOf n p) a where - type PP (ChunksOf n p) a = [PP p a] - eval _ opts a = do - let msg0 = "ChunksOf" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] - pure $ case lr of - Left e -> e - Right (fromIntegral -> n,p,pp,qq) -> - let hhs = [hh pp, hh qq] - msg1 = msg0 <> show0 opts " " n <> show0 opts " " p - in if n <= 0 then mkNode opts (FailT (msg0 <> " n<1")) msg1 hhs - else let ret = unfoldr (\s -> if null s then Nothing else Just $ splitAt n s) p - in mkNode opts (PresentT ret) (show01' opts msg1 ret "n=" n <> show1 opts " | " p) hhs + + -- ** boolean expressions + type (&&) + , type (&&~) + , type (||) + , type (||~) + , type (~>) + , Not + , Ands + , Ors + , Asc + , Asc' + , Desc + , Desc' + , Between + , BetweenA + , type (<..>) + , All + , Any + , AllPositive + , Positive + , AllNegative + , Negative + , AndA + , type (&*) + , OrA + , type (|+) + , IdBool + + -- ** regex expressions + , Re + , Re' + , Rescan + , Rescan' + , RescanRanges + , RescanRanges' + , Resplit + , Resplit' + , ReplaceAll + , ReplaceAll' + , ReplaceOne + , ReplaceOne' + , ReplaceAllString + , ReplaceAllString' + , ReplaceOneString + , ReplaceOneString' + , ReplaceFn + , ReplaceFn1 + , ReplaceFn2 + , ReplaceFn3 + + -- ** tuple expressions + , Fst + , Snd + , Thd + , L1 + , L2 + , L3 + , L4 + , L5 + , L6 + , Dup + , Swap + , SwapC(..) + , Assoc + , Unassoc + , Pairs + + -- ** character predicates + , IsLower + , IsUpper + , IsDigit + , IsSpace + , IsPunctuation + , IsControl + , IsHexDigit + , IsOctDigit + , IsSeparator + , IsLatin1 + + , IsLowerAll + , IsUpperAll + , IsDigitAll + , IsSpaceAll + , IsPunctuationAll + , IsControlAll + , IsHexDigitAll + , IsOctDigitAll + , IsSeparatorAll + , IsLatin1All + + -- ** datetime expressions + , FormatTimeP + , ParseTimeP + , ParseTimeP' + , ParseTimes + , ParseTimes' + , MkDay + , MkDay' + , UnMkDay + , MkDayExtra + , MkDayExtra' + , ToWeekDate + , ToWeekYear + , ToDay + , ToTime + , MkTime + , MkTime' + , UnMkTime + , PosixToUTCTime + , UTCTimeToPosix + + -- ** numeric expressions + , type (+) + , type (-) + , type (*) + , type (/) + , Negate + , Abs + , Signum + , FromInteger + , FromInteger' + , FromIntegral + , FromIntegral' + , Truncate + , Truncate' + , Ceiling + , Ceiling' + , Floor + , Floor' + , Even + , Odd + , Div + , Mod + , DivMod + , QuotRem + , Quot + , Rem + , LogBase + , type (^) + , type (**) + + -- *** rational numbers + , type (%) + , type (-%) + , ToRational + , FromRational + , FromRational' + + -- ** proxy expressions + , MkProxy + , ProxyT + , ProxyT' + , Unproxy + + -- ** read / show expressions + , ShowP + , ReadP + , ReadP' + , ReadQ + , ReadQ' + , ReadMaybe + , ReadMaybe' + , ReadBase + , ReadBase' + , ShowBase + + -- ** aeson expressions + , ParseJson' + , ParseJson + , EncodeJson + , EncodeJsonFile + , ParseJsonFile' + , ParseJsonFile + + -- ** arrow expressions + , type (&&&) + , type (***) + , First + , Second + , type (|||) + , type (+++) + + -- ** compare expressions + , type (>) + , type (>=) + , type (==) + , type (/=) + , type (<=) + , type (<) + , type (>~) + , type (>=~) + , type (==~) + , type (/=~) + , type (<=~) + , type (<~) + , Gt + , Ge + , Same + , Le + , Lt + , Ne + , type (==!) + , OrdP + , OrdA' + , OrdA + , OrdI + , type (===~) + , Cmp + , CmpI + + -- ** enum expressions + , Succ + , Pred + , FromEnum + , ToEnum + , ToEnum' + , EnumFromTo + , type (...) + , EnumFromThenTo + -- *** bounded enum expressions + , SuccB + , SuccB' + , PredB + , PredB' + , ToEnumBDef + , ToEnumBDef' + , ToEnumBFail + + -- ** wrap / unwrap expressions + , Unwrap + , Wrap + , Wrap' + , Coerce + , Coerce2 + + -- ** list / foldable expressions + , Map + , Concat + , ConcatMap + , Partition + , PartitionBy + , GroupBy + , Filter + , Break + , Span + , Intercalate + , Elem + , Inits + , Tails + , Ones + , OneP + , Len + , Length + , PadL + , PadR + , Cycle + , SplitAts + , SplitAt + , ChunksOf + , Rotate + , Take + , Drop + , Min + , Max + , Sum + , Product + , IsEmpty + , Null + , Null' + , ToList + , ToList' + , IToList + , IToList' + , FromList + , ToNEList + , EmptyList + , EmptyList' + , Singleton + , Reverse + , ReverseL + , SortBy + , SortOn + , SortOnDesc + , Remove + , Keep + -- *** overloaded list expressions + , ToListExt + , FromListExt + + -- ** maybe expressions + , MkNothing + , MkNothing' + , MkJust + , IsNothing + , IsJust + , MapMaybe + , CatMaybes + , Just + , JustDef + , JustFail + , MaybeIn + , MaybeBool + + -- ** either expressions + , PartitionEithers + , IsLeft + , IsRight + , MkLeft + , MkLeft' + , MkRight + , MkRight' + , Left' + , Right' + , LeftDef + , LeftFail + , RightDef + , RightFail + , EitherBool + , EitherIn + + -- ** semigroup / monoid expressions + , type (<>) + , MConcat + , SConcat + , STimes + , SapA + , SapA' + , MEmptyT + , MEmptyT' + , MEmptyP + , MEmpty2 + , MEmpty2' + + -- ** indexing expressions + , Ix + , Ix' + , IxL + , type (!!) + , type (!!?) + , Lookup + , LookupDef + , LookupDef' + , LookupFail + , LookupFail' + + -- ** cons / uncons expressions + , type (:+) + , type (+:) + , type (++) + , Uncons + , Unsnoc + , Head + , Tail + , Init + , Last + , HeadDef + , HeadFail + , TailDef + , TailFail + , LastDef + , LastFail + , InitDef + , InitFail + + -- ** these expressions + , PartitionThese + , Thiss + , Thats + , Theses + , This' + , That' + , These' + , IsThis + , IsThat + , IsThese + , MkThis + , MkThis' + , MkThat + , MkThat' + , MkThese + , ThisDef + , ThisFail + , ThatDef + , ThatFail + , TheseDef + , TheseFail + , TheseIn + , TheseId + , TheseX + + -- ** fold / unfold expressions + , Scanl + , ScanN + , ScanNA + , FoldN + , FoldL + , Unfoldr + , IterateN + , IterateUntil + , IterateWhile + , IterateNWhile + , IterateNUntil + + -- ** failure expressions + , Fail + , Failp + , Failt + , FailS + , Catch + , Catch' + + -- ** zip expressions + , ZipThese + , ZipL + , ZipR + , Zip + , Unzip + , Unzip3 + + -- ** conditional expressions + , If + , Case + , Case' + , Case'' + , Guards + , GuardsQuick + , Guard + , ExitWhen + , GuardSimple + , GuardsN + , GuardsDetail + + , Bools + , BoolsQuick + , BoolsN + + -- ** IO expressions + , ReadFile + , FileExists + , ReadDir + , DirExists + , ReadEnv + , ReadEnvAll + , TimeUtc + , TimeZt + , AppendFile + , WriteFile + , WriteFile' + , Stdout + , Stderr + , Stdin + , ReadIO + , ReadIO' + + -- ** string expressions + , ToLower + , ToUpper + , ToTitle + , TrimBoth + , TrimL + , TrimR + , StripR + , StripL + , IsPrefix + , IsInfix + , IsSuffix + , IsPrefixI + , IsInfixI + , IsSuffixI + , ToString + , FromString + , FromString' + + -- ** print expressions + , PrintF + , PrintL + , PrintT + + -- ** higher order expressions + , Pure + , Pure2 + , FoldMap + , type (<$) + , type (<*) + , type (*>) + , FMapFst + , FMapSnd + , Sequence + , Traverse + , Join + , EmptyT + , type (<|>) + , Extract + , Duplicate + + -- ** expression combinators + , type ($) + , type (&) + , Do + , Dot + , RDot + , type (>>) + , type (<<) + , type (>>>) + , DoN + , type ($$) + , type ($&) + , K + , Hole + , Skip + , type (|>) + , type (>|) + , type (>|>) + , Uncurry + + -- *** parallel expressions + , Para + , ParaN + , Repeat + + -- ** miscellaneous + , Both + , Prime + , PrimeNext + , Luhn + , Char1 + + -- ** tuples + , Tuple2 + , Tuple3 + , Tuple4 + , Tuple5 + , Tuple6 + ) where +import Predicate.Core +import Predicate.Util +import Safe (succMay, predMay, toEnumMay) +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) +import qualified GHC.TypeLits as GL +import Control.Lens hiding (iall) +import Data.List +import qualified Data.Text.Lens as DTL +import Data.Proxy +import Control.Applicative +import Data.Typeable +import Control.Monad.Except +import qualified Control.Exception as E +import Data.Kind (Type) +import qualified Text.Regex.PCRE.Heavy as RH +import Data.String +import Data.Foldable +import Data.Maybe +import Control.Arrow +import qualified Data.Semigroup as SG +import qualified Data.List.NonEmpty as N +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Numeric +import Data.Char +import Data.Function +import Data.These (These(..)) +import Data.Ratio +import Data.Time +import Data.Coerce +import Data.Void +import qualified Data.Sequence as Seq +import Text.Printf +import System.Directory +import Control.Comonad +import System.IO +import System.Environment +import qualified GHC.Exts as GE +import Data.Bool +import Data.Either +import qualified Data.Type.Equality as DE +import Data.Time.Calendar.WeekDate +import qualified Data.Time.Clock.System as CP +import qualified Data.Time.Clock.POSIX as P +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Map.Strict as M + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XOverloadedStrings +-- >>> :set -XNoOverloadedLists +-- >>> import qualified Data.Map.Strict as M +-- >>> import qualified Data.Text as T +-- >>> import Safe (readNote) + +-- | a type level predicate for a monotonic increasing list +-- +-- >>> pl @Asc "aaacdef" +-- True (All(6)) +-- TrueT +-- +-- >>> pz @Asc [1,2,3,4,5,5,7] +-- TrueT +-- +-- >>> pz @Asc' [1,2,3,4,5,5,7] +-- FalseT +-- +-- >>> pz @Asc "axacdef" +-- FalseT +-- + + +-- | a type level predicate for a monotonic increasing list +data Asc +type AscT = All (Fst Id <= Snd Id) Pairs + +instance P AscT x => P Asc x where + type PP Asc x = PP AscT x + eval _ = evalBool (Proxy @AscT) + +-- | a type level predicate for a strictly increasing list +data Asc' +type AscT' = All (Fst Id < Snd Id) Pairs + +instance P AscT' x => P Asc' x where + type PP Asc' x = PP AscT' x + eval _ = evalBool (Proxy @AscT') + +-- | a type level predicate for a monotonic decreasing list +data Desc +type DescT = All (Fst Id >= Snd Id) Pairs + +instance P DescT x => P Desc x where + type PP Desc x = PP DescT x + eval _ = evalBool (Proxy @DescT) +-- | a type level predicate for a strictly decreasing list +data Desc' +type DescT' = All (Fst Id > Snd Id) Pairs + +instance P DescT' x => P Desc' x where + type PP Desc' x = PP DescT' x + eval _ = evalBool (Proxy @DescT') + + +--type AscAlt = SortOn Id Id == Id +--type DescAlt = SortOnDesc Id Id == Id + +-- | A predicate that determines if the value is between \'p\' and \'q\' +-- +-- >>> pz @(Between 5 8 Len) [1,2,3,4,5,5,7] +-- TrueT +-- +-- >>> pz @(5 <..> 8) 6 +-- TrueT +-- +-- >>> pl @(Between 5 8 Id) 9 +-- False (9 <= 8) +-- FalseT +-- +-- >>> pz @(10 % 4 <..> 40 % 5) 4 +-- TrueT +-- +-- >>> pz @(10 % 4 <..> 40 % 5) 33 +-- FalseT +-- +data Between p q r -- reify as it is used a lot! nicer specific messages at the top level! + +instance (Ord (PP p x) + , Show (PP p x) + , PP r x ~ PP p x + , PP r x ~ PP q x + , P p x + , P q x + , P r x + ) => P (Between p q r) x where + type PP (Between p q r) x = Bool + eval _ opts x = do + let msg0 = "Between" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right r -> do + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [hh rr] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh rr, hh pp, hh qq] + in if p <= r && r <= q then mkNodeB opts True (showL opts p <> " <= " <> showL opts r <> " <= " <> showL opts q) hhs + else if p > r then mkNodeB opts False (showL opts p <> " <= " <> showL opts r) hhs + else mkNodeB opts False (showL opts r <> " <= " <> showL opts q) hhs + + +data p <..> q +infix 4 <..> + +type BetweenT p q = Between p q Id + +instance P (BetweenT p q) x => P (p <..> q) x where + type PP (p <..> q) x = PP (BetweenT p q) x + eval _ = evalBool (Proxy @(BetweenT p q)) + +-- | between for tuples +-- +-- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),8) +-- False (8 <= 4) +-- FalseT +-- +-- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),0) +-- False (1 <= 0) +-- FalseT +-- +-- >>> pl @(BetweenA (Fst Id) (Snd Id)) ((1,4),3) +-- True (1 <= 3 <= 4) +-- TrueT +-- +-- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2018-10-12" +-- True (2017-04-11 <= 2018-10-12 <= 2018-12-30) +-- TrueT +-- +-- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2019-10-12" +-- False (2019-10-12 <= 2018-12-30) +-- FalseT +-- +-- >>> pl @(BetweenA (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2016-10-12" +-- False (2017-04-11 <= 2016-10-12) +-- FalseT +-- + +{- too much data mitigated somewhat by Hide +type BetweenAT p q = '(p,q) >> Between (Fst (Fst Id)) (Snd (Fst Id)) (Snd Id) + +instance P (BetweenAT p q) x => P (BetweenA p q) x where + type PP (BetweenA p q) x = PP (BetweenAT p q) x + eval _ = evalBool (Proxy @(BetweenAT p q)) +-} +data BetweenA p q + +instance (PP p x ~ (a,a') + , P q x + , PP q x ~ a + , Ord a + , a ~ a' + , Show a + , P p x + ) => P (BetweenA p q) x where + type PP (BetweenA p q) x = Bool + eval _ opts x = do + let msg0 = "BetweenA" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right ((p1,p2),q,pp,qq) -> + [hh pp, hh qq] & if p1 <= q && q <= p2 then mkNodeB opts True (showL opts p1 <> " <= " <> showL opts q <> " <= " <> showL opts p2) + else if p1 > q then mkNodeB opts False (showL opts p1 <> " <= " <> showL opts q) + else mkNodeB opts False (showL opts q <> " <= " <> showL opts p2) + +-- | similar to 'all' +-- +-- >>> pl @(All (Between 1 8 Id) Id) [7,3,4,1,2,9,0,1] +-- False (All(8) i=5 (9 <= 8)) +-- FalseT +-- +-- >>> pz @(All Odd Id) [1,5,11,5,3] +-- TrueT +-- +-- >>> pz @(All Odd Id) [] +-- TrueT +-- +-- >>> run @'OANV @(All Even Id) [1,5,11,5,3] +-- False All(5) i=0 (1 == 0) +-- | +-- +- P Id [1,5,11,5,3] +-- | +-- +- False i=0:1 == 0 +-- | | +-- | +- P 1 `mod` 2 = 1 +-- | | | +-- | | +- P I +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=1:1 == 0 +-- | | +-- | +- P 5 `mod` 2 = 1 +-- | | | +-- | | +- P I +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=2:1 == 0 +-- | | +-- | +- P 11 `mod` 2 = 1 +-- | | | +-- | | +- P I +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=3:1 == 0 +-- | | +-- | +- P 5 `mod` 2 = 1 +-- | | | +-- | | +- P I +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- `- False i=4:1 == 0 +-- | +-- +- P 3 `mod` 2 = 1 +-- | | +-- | +- P I +-- | | +-- | `- P '2 +-- | +-- `- P '0 +-- FalseT +-- +data All p q + +instance (P p a + , PP p a ~ Bool + , PP q x ~ f a + , P q x + , Show a + , Foldable f + ) => P (All p q) x where + type PP (All p q) x = Bool + eval _ opts x = do + let msg0 = "All" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBoolHide (Proxy @p) opts a) [0::Int ..] (toList q) + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let hhs = hh qq : map (hh . fixit) ts + msg1 = msg0 ++ "(" ++ show (length q) ++ ")" + in case find (not . view _1) abcs of + Nothing -> mkNodeB opts True msg1 hhs + Just (_,(i,_),tt) -> + mkNodeB opts False (msg1 <> " i=" ++ showIndex i ++ " " <> topMessage tt) hhs + +showIndex :: (Show i, Num i) => i -> String +showIndex i = show (i+0) +-- | similar to 'any' +-- +-- >>> pl @(Any Even Id) [1,5,11,5,3] +-- False (Any(5)) +-- FalseT +-- +-- >>> pl @(Any Even Id) [1,5,112,5,3] +-- True (Any(5) i=2 (0 == 0)) +-- TrueT +-- +-- >>> pz @(Any Even Id) [] +-- FalseT +-- +data Any p q + +instance (P p a + , PP p a ~ Bool + , PP q x ~ f a + , P q x + , Show a + , Foldable f + ) => P (Any p q) x where + type PP (Any p q) x = Bool + eval _ opts x = do + let msg0 = "Any" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBoolHide (Proxy @p) opts a) [0::Int ..] (toList q) + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let hhs = hh qq : map (hh . fixit) ts + msg1 = msg0 ++ "(" ++ show (length q) ++ ")" + in case find (view _1) abcs of + Nothing -> mkNodeB opts False msg1 hhs + Just (_,(i,_),tt) -> + mkNodeB opts True (msg1 <> " i=" ++ showIndex i ++ " " <> topMessage tt) hhs + + +-- | a type level predicate for all positive elements in a list +-- +-- >>> pz @AllPositive [1,5,10,2,3] +-- TrueT +-- +-- >>> pz @AllPositive [0,1,5,10,2,3] +-- FalseT +-- +-- >>> pz @AllPositive [3,1,-5,10,2,3] +-- FalseT +-- +-- >>> pz @AllNegative [-1,-5,-10,-2,-3] +-- TrueT +-- +data AllPositive +type AllPositiveT = All Positive Id + +instance P AllPositiveT x => P AllPositive x where + type PP AllPositive x = PP AllPositiveT x + eval _ = evalBool (Proxy @AllPositiveT) + +-- | a type level predicate for all negative elements in a list +data AllNegative +type AllNegativeT = All Negative Id + +instance P AllNegativeT x => P AllNegative x where + type PP AllNegative x = PP AllNegativeT x + eval _ = evalBool (Proxy @AllNegativeT) + + +type Positive = Gt 0 + +type Negative = Lt 0 + +-- | 'unzip' equivalent +-- +-- >>> pz @Unzip (zip [1..5] "abcd") +-- PresentT ([1,2,3,4],"abcd") +-- +data Unzip +type UnzipT = '(Map (Fst Id) Id, Map (Snd Id) Id) + +instance P UnzipT x => P Unzip x where + type PP Unzip x = PP UnzipT x + eval _ = eval (Proxy @UnzipT) + + +-- | 'unzip3' equivalent +-- +-- >>> pz @Unzip3 (zip3 [1..5] "abcd" (cycle [True,False])) +-- PresentT ([1,2,3,4],"abcd",[True,False,True,False]) +-- +data Unzip3 +type Unzip3T = '(Map (Fst Id) Id, Map (Snd Id) Id, Map (Thd Id) Id) + +instance P Unzip3T x => P Unzip3 x where + type PP Unzip3 x = PP Unzip3T x + eval _ = eval (Proxy @Unzip3T) + + +-- | represents a predicate using a 'Symbol' as a regular expression +-- evaluates 'Re' and returns True if there is a match +-- +-- >>> pz @(Re "^\\d{2}:\\d{2}:\\d{2}$" Id) "13:05:25" +-- TrueT +-- +data Re' (rs :: [ROpt]) p q +data Re p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Re' rs p q) x where + type PP (Re' rs p q) x = Bool + eval _ opts x = do + let msg0 = "Re" <> unlessNull rs ("' " <> displayROpts fs) + (fs,rs) = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + let b = q RH.=~ regex + in mkNodeB opts b (msg1 <> litVerbose opts " | " q) hhs + +type ReT p q = Re' '[] p q + +instance P (ReT p q) x => P (Re p q) x where + type PP (Re p q) x = PP (ReT p q) x + eval _ = evalBool (Proxy @(ReT p q)) + +-- only way with rescan is to be explicit: no repeats! and useanchors but not (?m) +-- or just use Re' but then we only get a bool ie doesnt capture groups +-- rescan returns Right [] as an failure! +-- [] is failure! + + +-- | runs a regex matcher returning the original values and optionally any groups +-- +-- >>> pz @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" +-- PresentT [("13:05:25",["13","05","25"])] +-- +-- >>> pz @(Rescan (Snd Id) "13:05:25") ('a',"^(\\d{2}):(\\d{2}):(\\d{2})$") +-- PresentT [("13:05:25",["13","05","25"])] +-- +-- >>> pz @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) "13:05:25" +-- PresentT [13,5,25] +-- +-- >>> pl @(Rescan "(\\d+)\\D?" Id >> Map (Second (ReadP Int (OneP Id))) Id) "123-444-987" +-- Present [("123-",123),("444-",444),("987",987)] ((>>) [("123-",123),("444-",444),("987",987)] | {Map [("123-",123),("444-",444),("987",987)] | [("123-",["123"]),("444-",["444"]),("987",["987"])]}) +-- PresentT [("123-",123),("444-",444),("987",987)] +-- +data Rescan' (rs :: [ROpt]) p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Rescan' rs p q) x where + type PP (Rescan' rs p q) x = [(String, [String])] + eval _ opts x = do + let msg0 = "Rescan" <> unlessNull rs ("' " <> displayROpts fs) + (fs,rs) = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt (oRecursion opts) $ RH.scan regex q of + (b, _:_) -> mkNode opts (FailT ("Regex looping(" ++ show (oRecursion opts) ++ ")")) (msg1 <> " " <> show (take 10 b) <> "..." <> showVerbose opts " | " q) hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") (msg1 <> showVerbose opts " | " q) [hh pp, hh qq] + (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b "" q) [hh pp, hh qq] + +data Rescan p q +type RescanT p q = Rescan' '[] p q + +instance P (RescanT p q) x => P (Rescan p q) x where + type PP (Rescan p q) x = PP (RescanT p q) x + eval _ = eval (Proxy @(RescanT p q)) + + +-- | similar to 'Rescan' but gives the column start and ending positions instead of values +-- +-- >>> pz @(RescanRanges "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" +-- PresentT [((0,8),[(0,2),(3,5),(6,8)])] +-- +data RescanRanges' (rs :: [ROpt]) p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (RescanRanges' rs p q) x where + type PP (RescanRanges' rs p q) x = [((Int,Int), [(Int,Int)])] + eval _ opts x = do + let msg0 = "RescanRanges" <> unlessNull rs ("' " <> displayROpts fs) + (fs,rs) = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt (oRecursion opts) $ RH.scanRanges regex q of + (b, _:_) -> mkNode opts (FailT ("Regex looping(" ++ show (oRecursion opts) ++ ")")) (msg1 <> " " <> show (take 10 b) <> "..." <> showVerbose opts " | " q) hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") (msg1 <> showVerbose opts " | " q) hhs + (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b "" q) hhs + +data RescanRanges p q +type RescanRangesT p q = RescanRanges' '[] p q + +instance P (RescanRangesT p q) x => P (RescanRanges p q) x where + type PP (RescanRanges p q) x = PP (RescanRangesT p q) x + eval _ = eval (Proxy @(RescanRangesT p q)) + +-- | splits a string on a regex delimiter +-- +-- >>> pz @(Resplit "\\." Id) "141.201.1.22" +-- PresentT ["141","201","1","22"] +-- +-- >>> pz @(Resplit (Singleton (Fst Id)) (Snd Id)) (':', "12:13:1") +-- PresentT ["12","13","1"] +-- +-- >>> pl @(Resplit' '[ 'Caseless ] "aBc" Id) "123AbC456abc" +-- Present ["123","456",""] (Resplit' ['Caseless] (aBc) ["123","456",""] | 123AbC456abc) +-- PresentT ["123","456",""] +-- +data Resplit' (rs :: [ROpt]) p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Resplit' rs p q) x where + type PP (Resplit' rs p q) x = [String] + eval _ opts x = do + let msg0 = "Resplit" <> unlessNull rs ("' " <> displayROpts fs) + (fs,rs) = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt (oRecursion opts) $ RH.split regex q of + (b, _:_) -> mkNode opts (FailT ("Regex looping(" ++ show (oRecursion opts) ++ ")")) (msg1 <> " " <> show (take 10 b) <> "..." <> showVerbose opts " | " q) hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") (msg1 <> showVerbose opts " | " q) hhs + (b, _) -> mkNode opts (PresentT b) (lit01 opts msg1 b "" q) hhs + +data Resplit p q +type ResplitT p q = Resplit' '[] p q + +instance P (ResplitT p q) x => P (Resplit p q) x where + type PP (Resplit p q) x = PP (ResplitT p q) x + eval _ = eval (Proxy @(ResplitT p q)) + +-- | replaces regex \'s\' with a string \'s1\' inside the value +-- +-- >>> pz @(ReplaceAllString 'ROverWrite "\\." ":" Id) "141.201.1.22" +-- PresentT "141:201:1:22" +-- +data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r + +instance (GetBool b + , GetROpts rs + , PP p x ~ String + , PP q x ~ RReplace + , PP r x ~ String + , P p x + , P q x + , P r x + ) => P (ReplaceImpl b rs p q r) x where + type PP (ReplaceImpl b rs p q r) x = String + eval _ opts x = do + let msg0 = "Replace" <> (if alle then "All" else "One") <> unlessNull rs ("' " <> displayROpts fs) + (fs,rs) = getROpts @rs + alle = getBool @b + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> pure tta + Right regex -> do + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let ret :: String + ret = case q of + RReplace o s -> + let g fn = (if alle then RH.gsub else RH.sub) regex fn r + in g (case o of + RPrepend -> (s <>) + ROverWrite -> const s + RAppend -> (<> s)) + RReplace1 s -> (if alle then RH.gsub else RH.sub) regex s r + RReplace2 s -> (if alle then RH.gsub else RH.sub) regex s r + RReplace3 s -> (if alle then RH.gsub else RH.sub) regex s r + in mkNode opts (PresentT ret) (msg1 <> " " <> litL opts r <> litVerbose opts " | " ret) (hhs <> [hh rr]) + +data ReplaceAll' (rs :: [ROpt]) p q r +type ReplaceAllT' (rs :: [ROpt]) p q r = ReplaceImpl 'True rs p q r + +instance P (ReplaceAllT' rs p q r) x => P (ReplaceAll' rs p q r) x where + type PP (ReplaceAll' rs p q r) x = PP (ReplaceAllT' rs p q r) x + eval _ = eval (Proxy @(ReplaceAllT' rs p q r)) + +data ReplaceAll p q r +type ReplaceAllT p q r = ReplaceAll' '[] p q r + +instance P (ReplaceAllT p q r) x => P (ReplaceAll p q r) x where + type PP (ReplaceAll p q r) x = PP (ReplaceAllT p q r) x + eval _ = eval (Proxy @(ReplaceAllT p q r)) + +data ReplaceOne' (rs :: [ROpt]) p q r +type ReplaceOneT' (rs :: [ROpt]) p q r = ReplaceImpl 'False rs p q r + +instance P (ReplaceOneT' rs p q r) x => P (ReplaceOne' rs p q r) x where + type PP (ReplaceOne' rs p q r) x = PP (ReplaceOneT' rs p q r) x + eval _ = eval (Proxy @(ReplaceOneT' rs p q r)) + +-- | replace first occurrence of string \'p\' with '\q'\ in \'r\' +-- +-- >>> pl @(ReplaceOneString 'ROverWrite "abc" "def" Id) "123abc456abc" +-- Present "123def456abc" (ReplaceOne (abc) 123abc456abc | 123def456abc) +-- PresentT "123def456abc" +-- +-- >>> pz @(Rescan "^Date\\((\\d+[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1530144000123+0530)" +-- PresentT 2018-06-28 05:30:00.123 +0530 +-- +-- >>> pz @(Rescan "^Date\\((\\d+[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1593460089052+0800)" +-- PresentT 2020-06-30 03:48:09.052 +0800 +-- +-- >>> pz @(Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> (Id !! 0 <> "." <> Id !! 1) >> ParseTimeP ZonedTime "%s%Q%z" Id) "Date(1593460089052+0800)" +-- PresentT 2020-06-30 03:48:09.052 +0800 +-- +data ReplaceOne p q r +type ReplaceOneT p q r = ReplaceOne' '[] p q r + +instance P (ReplaceOneT p q r) x => P (ReplaceOne p q r) x where + type PP (ReplaceOne p q r) x = PP (ReplaceOneT p q r) x + eval _ = eval (Proxy @(ReplaceOneT p q r)) + +-- | replace all occurrences of string \'p\' with '\q'\ in \'r\' +-- +-- >>> pl @(ReplaceAllString 'ROverWrite "abc" "def" Id) "123abc456abc" +-- Present "123def456def" (ReplaceAll (abc) 123abc456abc | 123def456def) +-- PresentT "123def456def" +-- +-- >>> pl @(ReplaceAllString' '[] 'ROverWrite "abc" "def" Id) "123AbC456abc" +-- Present "123AbC456def" (ReplaceAll (abc) 123AbC456abc | 123AbC456def) +-- PresentT "123AbC456def" +-- +-- >>> pl @(ReplaceAllString' '[ 'Caseless ] 'ROverWrite "abc" "def" Id) "123AbC456abc" +-- Present "123def456def" (ReplaceAll' ['Caseless] (abc) 123AbC456abc | 123def456def) +-- PresentT "123def456def" +-- +-- >>> pl @(ReplaceAllString 'RPrepend "abc" "def" Id) "123AbC456abc" +-- Present "123AbC456defabc" (ReplaceAll (abc) 123AbC456abc | 123AbC456defabc) +-- PresentT "123AbC456defabc" +-- +-- >>> pl @(ReplaceAllString 'ROverWrite "abc" "def" Id) "123AbC456abc" +-- Present "123AbC456def" (ReplaceAll (abc) 123AbC456abc | 123AbC456def) +-- PresentT "123AbC456def" +-- +-- >>> pl @(ReplaceAllString 'RAppend "abc" "def" Id) "123AbC456abc" +-- Present "123AbC456abcdef" (ReplaceAll (abc) 123AbC456abc | 123AbC456abcdef) +-- PresentT "123AbC456abcdef" +-- +data ReplaceAllString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r +type ReplaceAllStringT' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r = ReplaceAll' rs p (ReplaceFn o q) r + +instance P (ReplaceAllStringT' rs o p q r) x => P (ReplaceAllString' rs o p q r) x where + type PP (ReplaceAllString' rs o p q r) x = PP (ReplaceAllStringT' rs o p q r) x + eval _ = eval (Proxy @(ReplaceAllStringT' rs o p q r)) + +data ReplaceAllString o p q r +type ReplaceAllStringT o p q r = ReplaceAllString' '[] o p q r + +instance P (ReplaceAllStringT o p q r) x => P (ReplaceAllString o p q r) x where + type PP (ReplaceAllString o p q r) x = PP (ReplaceAllStringT o p q r) x + eval _ = eval (Proxy @(ReplaceAllStringT o p q r)) + +data ReplaceOneString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r +type ReplaceOneStringT' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r = ReplaceOne' rs p (ReplaceFn o q) r + +instance P (ReplaceOneStringT' rs o p q r) x => P (ReplaceOneString' rs o p q r) x where + type PP (ReplaceOneString' rs o p q r) x = PP (ReplaceOneStringT' rs o p q r) x + eval _ = eval (Proxy @(ReplaceOneStringT' rs o p q r)) + +data ReplaceOneString (o :: ReplaceFnSub) p q r +type ReplaceOneStringT (o :: ReplaceFnSub) p q r = ReplaceOneString' '[] o p q r + +instance P (ReplaceOneStringT o p q r) x => P (ReplaceOneString o p q r) x where + type PP (ReplaceOneString o p q r) x = PP (ReplaceOneStringT o p q r) x + eval _ = eval (Proxy @(ReplaceOneStringT o p q r)) + +-- | Simple replacement string: see 'ReplaceAllString' and 'ReplaceOneString' +-- +data ReplaceFn (o :: ReplaceFnSub) p + +instance (GetReplaceFnSub r + , PP p x ~ String + , P p x) => P (ReplaceFn r p) x where + type PP (ReplaceFn r p) x = RReplace + eval _ opts x = do + let msg0 = "ReplaceFn" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = RReplace (getReplaceFnSub @r) p + in mkNode opts (PresentT b) (msg0 <> showVerbose opts " | " p) [hh pp] + +-- | A replacement function @(String -> [String] -> String)@ which returns the whole match and the groups +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +data ReplaceFn1 p + +instance (PP p x ~ (String -> [String] -> String) + , P p x) => P (ReplaceFn1 p) x where + type PP (ReplaceFn1 p) x = RReplace + eval _ opts x = do + let msg0 = "ReplaceFn1 (String -> [String] -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RReplace1 f)) msg0 [hh pp] + +-- | A replacement function @(String -> String)@ that yields the whole match +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +-- >>> :m + Text.Show.Functions +-- >>> pz @(ReplaceAll "\\." (ReplaceFn2 (Fst Id)) (Snd Id)) (\x -> x <> ":" <> x, "141.201.1.22") +-- PresentT "141.:.201.:.1.:.22" +-- +data ReplaceFn2 p + +instance (PP p x ~ (String -> String) + , P p x) => P (ReplaceFn2 p) x where + type PP (ReplaceFn2 p) x = RReplace + eval _ opts x = do + let msg0 = "ReplaceFn2 (String -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RReplace2 f)) msg0 [hh pp] + +-- | A replacement function @([String] -> String)@ which yields the groups +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +-- >>> :m + Text.Show.Functions +-- >>> pz @(ReplaceAll "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" (ReplaceFn3 (Fst Id)) (Snd Id)) (\ys -> intercalate " | " $ map (show . succ . readNote @Int "invalid int") ys, "141.201.1.22") +-- PresentT "142 | 202 | 2 | 23" +-- +data ReplaceFn3 p + +instance (PP p x ~ ([String] -> String) + , P p x) => P (ReplaceFn3 p) x where + type PP (ReplaceFn3 p) x = RReplace + eval _ opts x = do + let msg0 = "ReplaceFn3 ([String] -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RReplace3 f)) msg0 [hh pp] + + +-- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set +-- +-- >>> pz @IsSpace '\t' +-- TrueT +-- +-- >>> pz @IsSpace ' ' +-- TrueT +-- +-- >>> pz @IsSpace 'x' +-- FalseT +-- +-- >>> pz @IsLower 'a' +-- TrueT +-- +-- >>> pz @IsLower 'X' +-- FalseT +-- +-- >>> pz @IsHexDigit 'A' +-- TrueT +-- +-- >>> pz @IsHexDigit 'g' +-- FalseT +-- +data IsCharSet (cs :: CharSet) + +instance ( x ~ Char + , GetCharSet cs + ) => P (IsCharSet cs) x where + type PP (IsCharSet cs) x = Bool + eval _ opts c = + let msg0 = "Is" ++ drop 1 (show cs) + (cs,f) = getCharSet @cs + b = f c + in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " [c]) [] + +-- | predicate for determining if a character is lowercase +-- +-- >>> pz @IsLower '1' +-- FalseT +-- +-- >>> pz @IsLower 'a' +-- TrueT +-- +-- >>> pz @(Map '(IsControl, IsLatin1, IsHexDigit, IsOctDigit, IsDigit, IsPunctuation, IsSeparator, IsSpace) Id) "abc134" +-- PresentT [(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False)] +-- +data IsLower +type IsLowerT = IsCharSet 'CLower + +instance P IsLowerT x => P IsLower x where + type PP IsLower x = PP IsLowerT x + eval _ = evalBool (Proxy @IsLowerT) + +data IsUpper +type IsUpperT = IsCharSet 'CUpper + +instance P IsUpperT x => P IsUpper x where + type PP IsUpper x = PP IsUpperT x + eval _ = evalBool (Proxy @IsUpperT) + +-- | predicate for determining if the character is a digit +-- +-- >>> pz @IsDigit 'g' +-- FalseT +-- +-- >>> pz @IsDigit '9' +-- TrueT +-- +data IsDigit +type IsDigitT = IsCharSet 'CNumber +instance P IsDigitT x => P IsDigit x where + type PP IsDigit x = Bool + eval _ = evalBool (Proxy @IsDigitT) + +data IsSpace +type IsSpaceT = IsCharSet 'CSpace +instance P IsSpaceT x => P IsSpace x where + type PP IsSpace x = Bool + eval _ = evalBool (Proxy @IsSpaceT) + +data IsPunctuation +type IsPunctuationT = IsCharSet 'CPunctuation +instance P IsPunctuationT x => P IsPunctuation x where + type PP IsPunctuation x = Bool + eval _ = evalBool (Proxy @IsPunctuationT) + +data IsControl +type IsControlT = IsCharSet 'CControl +instance P IsControlT x => P IsControl x where + type PP IsControl x = Bool + eval _ = evalBool (Proxy @IsControlT) + +data IsHexDigit +type IsHexDigitT = IsCharSet 'CHexDigit +instance P IsHexDigitT x => P IsHexDigit x where + type PP IsHexDigit x = Bool + eval _ = evalBool (Proxy @IsHexDigitT) + +data IsOctDigit +type IsOctDigitT = IsCharSet 'COctDigit +instance P IsOctDigitT x => P IsOctDigit x where + type PP IsOctDigit x = Bool + eval _ = evalBool (Proxy @IsOctDigitT) + +data IsSeparator +type IsSeparatorT = IsCharSet 'CSeparator +instance P IsSeparatorT x => P IsSeparator x where + type PP IsSeparator x = Bool + eval _ = evalBool (Proxy @IsSeparatorT) + +data IsLatin1 +type IsLatin1T = IsCharSet 'CLatin1 +instance P IsLatin1T x => P IsLatin1 x where + type PP IsLatin1 x = Bool + eval _ = evalBool (Proxy @IsLatin1T) + + + +-- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set +-- +-- >>> pz @IsLowerAll "abc" +-- TrueT +-- +-- >>> pz @IsLowerAll "abcX" +-- FalseT +-- +-- >>> pz @IsLowerAll (T.pack "abcX") +-- FalseT +-- +-- >>> pz @IsHexDigitAll "01efA" +-- TrueT +-- +-- >>> pz @IsHexDigitAll "01egfA" +-- FalseT +-- +-- | predicate for determining if a string is all lowercase +-- +-- >>> pz @IsLowerAll "abcdef213" +-- FalseT +-- +-- >>> pz @IsLowerAll "abcdef" +-- TrueT +-- +-- >>> pz @IsLowerAll "" +-- TrueT +-- +-- >>> pz @IsLowerAll "abcdefG" +-- FalseT +-- +-- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "AbcdE" +-- False ((>>) False | {True (&*) False | (IsLowerAll | "bcdE")}) +-- FalseT +-- +-- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "Abcde" +-- True ((>>) True | {True (&*) True}) +-- TrueT +-- +-- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "xbcde" +-- False ((>>) False | {False (&*) True | (IsUpper | "x")}) +-- FalseT +-- +-- >>> pl @(Just Uncons >> IsUpper &* IsLowerAll) "X" +-- True ((>>) True | {True (&*) True}) +-- TrueT +-- +-- >>> pz @( '(IsControlAll, IsLatin1All , IsHexDigitAll , IsOctDigitAll , IsDigitAll , IsPunctuationAll , IsSeparatorAll , IsSpaceAll ) ) "abc134" +-- PresentT (False,True,True,False,False,False,False,False) +-- +-- >>> pl @(SplitAts [1,2,10] Id >> Para '[IsLowerAll, IsDigitAll, IsUpperAll ]) "abdefghi" +-- Present [True,False,False] ((>>) [True,False,False] | {Para(0) [True,False,False] | ["a","bd","efghi"]}) +-- PresentT [True,False,False] +-- +-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll ]) "a98efghi" +-- False ((>>) False | {Bool(2) [] (IsUpperAll | "efghi")}) +-- FalseT +-- +-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll ]) "a98efghi" +-- True ((>>) True | {Bools}) +-- TrueT +-- +-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll ]) "a98efgHi" +-- False ((>>) False | {Bool(2) [] (False || False | (IsUpperAll | "efgHi") || (IsLowerAll | "efgHi"))}) +-- FalseT +-- +data IsCharSetAll (cs :: CharSet) + +instance (GetCharSet cs + , Show a + , DTL.IsText a + ) => P (IsCharSetAll cs) a where + type PP (IsCharSetAll cs) a = Bool + eval _ opts as = + let b = allOf DTL.text f as + msg0 = "Is" ++ drop 1 (show cs) ++ "All" + (cs,f) = getCharSet @cs + in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " as) [] + +data CharSet = CLower + | CUpper + | CNumber + | CSpace + | CPunctuation + | CControl + | CHexDigit + | COctDigit + | CSeparator + | CLatin1 + deriving Show + +class GetCharSet (cs :: CharSet) where + getCharSet :: (CharSet, Char -> Bool) +instance GetCharSet 'CLower where + getCharSet = (CLower, isLower) +instance GetCharSet 'CUpper where + getCharSet = (CUpper, isUpper) +instance GetCharSet 'CNumber where + getCharSet = (CNumber, isNumber) +instance GetCharSet 'CSpace where + getCharSet = (CSpace, isSpace) +instance GetCharSet 'CPunctuation where + getCharSet = (CPunctuation, isPunctuation) +instance GetCharSet 'CControl where + getCharSet = (CControl, isControl) +instance GetCharSet 'CHexDigit where + getCharSet = (CHexDigit, isHexDigit) +instance GetCharSet 'COctDigit where + getCharSet = (COctDigit, isOctDigit) +instance GetCharSet 'CSeparator where + getCharSet = (CSeparator, isSeparator) +instance GetCharSet 'CLatin1 where + getCharSet = (CLatin1, isLatin1) + +data IsLowerAll +type IsLowerAllT = IsCharSetAll 'CLower + +instance P IsLowerAllT x => P IsLowerAll x where + type PP IsLowerAll x = PP IsLowerAllT x + eval _ = evalBool (Proxy @IsLowerAllT) + +data IsUpperAll +type IsUpperAllT = IsCharSetAll 'CUpper + +instance P IsUpperAllT x => P IsUpperAll x where + type PP IsUpperAll x = PP IsUpperAllT x + eval _ = evalBool (Proxy @IsUpperAllT) + +-- | predicate for determining if the string is all digits +-- +-- >>> pz @IsDigitAll "213G" +-- FalseT +-- +-- >>> pz @IsDigitAll "929" +-- TrueT +-- +data IsDigitAll +type IsDigitAllT = IsCharSetAll 'CNumber +instance P IsDigitAllT x => P IsDigitAll x where + type PP IsDigitAll x = Bool + eval _ = evalBool (Proxy @IsDigitAllT) + +-- | predicate for determining if the string is all spaces +-- +-- >>> pz @IsSpaceAll "213G" +-- FalseT +-- +-- >>> pz @IsSpaceAll " " +-- TrueT +-- +-- >>> pz @IsSpaceAll "" +-- TrueT +-- +data IsSpaceAll +type IsSpaceAllT = IsCharSetAll 'CSpace +instance P IsSpaceAllT x => P IsSpaceAll x where + type PP IsSpaceAll x = Bool + eval _ = evalBool (Proxy @IsSpaceAllT) + +data IsPunctuationAll +type IsPunctuationAllT = IsCharSetAll 'CPunctuation +instance P IsPunctuationAllT x => P IsPunctuationAll x where + type PP IsPunctuationAll x = Bool + eval _ = evalBool (Proxy @IsPunctuationAllT) + +data IsControlAll +type IsControlAllT = IsCharSetAll 'CControl +instance P IsControlAllT x => P IsControlAll x where + type PP IsControlAll x = Bool + eval _ = evalBool (Proxy @IsControlAllT) + +data IsHexDigitAll +type IsHexDigitAllT = IsCharSetAll 'CHexDigit +instance P IsHexDigitAllT x => P IsHexDigitAll x where + type PP IsHexDigitAll x = Bool + eval _ = evalBool (Proxy @IsHexDigitAllT) + +data IsOctDigitAll +type IsOctDigitAllT = IsCharSetAll 'COctDigit +instance P IsOctDigitAllT x => P IsOctDigitAll x where + type PP IsOctDigitAll x = Bool + eval _ = evalBool (Proxy @IsOctDigitAllT) + +data IsSeparatorAll +type IsSeparatorAllT = IsCharSetAll 'CSeparator +instance P IsSeparatorAllT x => P IsSeparatorAll x where + type PP IsSeparatorAll x = Bool + eval _ = evalBool (Proxy @IsSeparatorAllT) + +data IsLatin1All +type IsLatin1AllT = IsCharSetAll 'CLatin1 +instance P IsLatin1AllT x => P IsLatin1All x where + type PP IsLatin1All x = Bool + eval _ = evalBool (Proxy @IsLatin1AllT) + + +-- | converts a string 'Data.Text.Lens.IsText' value to lower case +-- +-- >>> pz @ToLower "HeLlO wOrld!" +-- PresentT "hello world!" +-- +data ToLower + +instance ( Show a + , DTL.IsText a + ) => P ToLower a where + type PP ToLower a = a + eval _ opts as = + let msg0 = "ToLower" + xs = as & DTL.text %~ toLower + in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + +-- | converts a string 'Data.Text.Lens.IsText' value to upper case +-- +-- >>> pz @ToUpper "HeLlO wOrld!" +-- PresentT "HELLO WORLD!" +-- +data ToUpper + +instance ( Show a + , DTL.IsText a + ) => P ToUpper a where + type PP ToUpper a = a + eval _ opts as = + let msg0 = "ToUpper" + xs = as & DTL.text %~ toUpper + in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + + +-- | converts a string 'Data.Text.Lens.IsText' value to title case +-- +-- >>> pz @ToTitle "HeLlO wOrld!" +-- PresentT "Hello world!" +-- +-- >>> data Color = Red | White | Blue | Green | Black deriving (Show,Eq,Enum,Bounded,Read) +-- >>> pz @(ToTitle >> ReadP Color Id) "red" +-- PresentT Red +-- +data ToTitle + +instance ( Show a + , DTL.IsText a + ) => P ToTitle a where + type PP ToTitle a = a + eval _ opts as = + let msg0 = "ToTitle" + xs = toTitleAll (as ^. DTL.unpacked) ^. DTL.packed + in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + + +toTitleAll :: String -> String +toTitleAll (x:xs) = toUpper x : map toLower xs +toTitleAll [] = [] + + +-- | similar to 'Data.List.inits' +-- +-- >>> pz @Inits [4,8,3,9] +-- PresentT [[],[4],[4,8],[4,8,3],[4,8,3,9]] +-- +-- >>> pz @Inits [] +-- PresentT [[]] +-- +data Inits + +instance ( [a] ~ x + , Show a + ) => P Inits x where + type PP Inits x = [x] + eval _ opts as = + let msg0 = "Inits" + xs = inits as + in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + +-- | similar to 'Data.List.tails' +-- +-- >>> pz @Tails [4,8,3,9] +-- PresentT [[4,8,3,9],[8,3,9],[3,9],[9],[]] +-- +-- >>> pz @Tails [] +-- PresentT [[]] +-- +data Tails + +instance ( [a] ~ x + , Show a + ) => P Tails x where + type PP Tails x = [x] + eval _ opts as = + let msg0 = "Tails" + xs = tails as + in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + +-- | split a list into single values +-- +-- >>> pz @(Ones Id) [4,8,3,9] +-- PresentT [[4],[8],[3],[9]] +-- +-- >>> pz @(Ones Id) [] +-- PresentT [] +-- +data Ones p + +instance ( PP p x ~ [a] + , P p x + , Show a + ) => P (Ones p) x where + type PP (Ones p) x = [PP p x] + eval _ opts x = do + let msg0 = "Ones" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case chkSize opts msg0 p [hh pp] of + Left e -> e + Right () -> + let d = map pure p + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +-- | similar to 'show' +-- +-- >>> pz @(ShowP Id) [4,8,3,9] +-- PresentT "[4,8,3,9]" +-- +-- >>> pz @(ShowP Id) 'x' +-- PresentT "'x'" +-- +-- >>> pz @(ShowP (42 -% 10)) 'x' +-- PresentT "(-21) % 5" +-- +data ShowP p + +instance ( Show (PP p x) + , P p x + ) => P (ShowP p) x where + type PP (ShowP p) x = String + eval _ opts x = do + let msg0 = "ShowP" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = show p + in mkNode opts (PresentT d) (msg0 <> " " <> litL opts d <> showVerbose opts " | " p) [hh pp] + +-- | type level expression representing a formatted time +-- similar to 'Data.Time.formatTime' using a type level 'Symbol' to get the formatting string +-- +-- >>> pz @(FormatTimeP "%F %T" Id) (readNote @LocalTime "invalid localtime" "2019-05-24 05:19:59") +-- PresentT "2019-05-24 05:19:59" +-- +-- >>> pz @(FormatTimeP (Fst Id) (Snd Id)) ("the date is %d/%m/%Y", readNote @Day "invalid day" "2019-05-24") +-- PresentT "the date is 24/05/2019" +-- +data FormatTimeP p q + +instance (PP p x ~ String + , FormatTime (PP q x) + , P p x + , Show (PP q x) + , P q x + ) => P (FormatTimeP p q) x where + type PP (FormatTimeP p q) x = String + eval _ opts x = do + let msg0 = "FormatTimeP" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + b = formatTime defaultTimeLocale p q + in mkNode opts (PresentT b) (msg1 <> " " <> litL opts b <> showVerbose opts " | " q) [hh pp, hh qq] + +-- | similar to 'Data.Time.parseTimeM' where \'t\' is the 'Data.Time.ParseTime' type, \'p\' is the datetime format and \'q\' points to the content to parse +-- +-- >>> pz @(ParseTimeP LocalTime "%F %T" Id) "2019-05-24 05:19:59" +-- PresentT 2019-05-24 05:19:59 +-- +-- >>> pz @(ParseTimeP LocalTime "%F %T" "2019-05-24 05:19:59") (Right "never used") +-- PresentT 2019-05-24 05:19:59 +-- +-- keeping \'q\' as we might want to extract from a tuple +data ParseTimeP' t p q + +instance (ParseTime (PP t a) + , Typeable (PP t a) + , Show (PP t a) + , P p a + , P q a + , PP p a ~ String + , PP q a ~ String + ) => P (ParseTimeP' t p q) a where + type PP (ParseTimeP' t p q) a = PP t a + eval _ opts a = do + let msg0 = "ParseTimeP " <> t + t = showT @(PP t a) + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case parseTimeM @Maybe @(PP t a) True defaultTimeLocale p q of + Just b -> mkNode opts (PresentT b) (lit01 opts msg1 b "fmt=" p <> showVerbose opts " | " q) hhs + Nothing -> mkNode opts (FailT (msg1 <> " failed to parse")) "" hhs + +data ParseTimeP (t :: Type) p q +type ParseTimePT (t :: Type) p q = ParseTimeP' (Hole t) p q + +instance P (ParseTimePT t p q) x => P (ParseTimeP t p q) x where + type PP (ParseTimeP t p q) x = PP (ParseTimePT t p q) x + eval _ = eval (Proxy @(ParseTimePT t p q)) + +-- | A convenience method to match against many different datetime formats to find a match +-- +-- >>> pz @(ParseTimes LocalTime '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] "03/11/19 01:22:33") () +-- PresentT 2019-03-11 01:22:33 +-- +-- >>> pz @(ParseTimes LocalTime (Fst Id) (Snd Id)) (["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"], "03/11/19 01:22:33") +-- PresentT 2019-03-11 01:22:33 +-- +data ParseTimes' t p q + +instance (ParseTime (PP t a) + , Typeable (PP t a) + , Show (PP t a) + , P p a + , P q a + , PP p a ~ [String] + , PP q a ~ String + ) => P (ParseTimes' t p q) a where + type PP (ParseTimes' t p q) a = PP t a + eval _ opts a = do + let msg0 = "ParseTimes " <> t + t = showT @(PP t a) + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + zs = map (\d -> (d,) <$> parseTimeM @Maybe @(PP t a) True defaultTimeLocale d q) p + in case catMaybes zs of + [] -> mkNode opts (FailT ("no match on (" ++ q ++ ")")) msg0 hhs + (d,b):_ -> mkNode opts (PresentT b) (lit01 opts msg0 b "fmt=" d <> showVerbose opts " | " q) hhs + +data ParseTimes (t :: Type) p q +type ParseTimesT (t :: Type) p q = ParseTimes' (Hole t) p q + +instance P (ParseTimesT t p q) x => P (ParseTimes t p q) x where + type PP (ParseTimes t p q) x = PP (ParseTimesT t p q) x + eval _ = eval (Proxy @(ParseTimesT t p q)) + +-- | create a 'Day' from three int values passed in as year month and day +-- +-- >>> pz @(MkDay '(1,2,3) >> Just Id) () +-- PresentT 0001-02-03 +-- +-- >>> pz @(Just (MkDay '(1,2,3))) 1 +-- PresentT 0001-02-03 +-- +-- >>> pz @(MkDay Id) (2019,12,30) +-- PresentT (Just 2019-12-30) +-- +-- >>> pz @(MkDay' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) +-- PresentT Nothing +-- +-- >>> pz @(MkDay Id) (1999,3,13) +-- PresentT (Just 1999-03-13) +-- +data MkDay' p q r + +instance (P p x + , P q x + , P r x + , PP p x ~ Int + , PP q x ~ Int + , PP r x ~ Int + ) => P (MkDay' p q r) x where + type PP (MkDay' p q r) x = Maybe Day + eval _ opts x = do + let msg0 = "MkDay" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let mday = fromGregorianValid (fromIntegral p) q r + in mkNode opts (PresentT mday) (show01' opts msg0 mday "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) + +data MkDay p +type MkDayT p = MkDay' (Fst p) (Snd p) (Thd p) + +instance P (MkDayT p) x => P (MkDay p) x where + type PP (MkDay p) x = PP (MkDayT p) x + eval _ = eval (Proxy @(MkDayT p)) + +-- | uncreate a 'Day' returning year month and day +-- +-- >>> pz @(UnMkDay Id) (readNote "invalid day" "2019-12-30") +-- PresentT (2019,12,30) +-- +data UnMkDay p + +instance ( PP p x ~ Day + , P p x + ) => P (UnMkDay p) x where + type PP (UnMkDay p) x = (Int, Int, Int) + eval _ opts x = do + let msg0 = "UnMkDay" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (fromIntegral -> y, m, d) = toGregorian p + b = (y, m, d) + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + + +-- | create a 'Day' + Week + Day of Week from three int values passed in as year month and day +-- +-- >>> pz @(MkDayExtra '(1,2,3) >> Just Id >> Fst Id) () +-- PresentT 0001-02-03 +-- +-- >>> pz @(Fst (Just (MkDayExtra '(1,2,3)))) 1 +-- PresentT 0001-02-03 +-- +-- >>> pz @(MkDayExtra Id) (2019,12,30) +-- PresentT (Just (2019-12-30,1,1)) +-- +-- >>> pz @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) +-- PresentT Nothing +-- +-- >>> pz @(MkDayExtra Id) (1999,3,13) +-- PresentT (Just (1999-03-13,10,6)) +-- +data MkDayExtra' p q r + +instance (P p x + , P q x + , P r x + , PP p x ~ Int + , PP q x ~ Int + , PP r x ~ Int + ) => P (MkDayExtra' p q r) x where + type PP (MkDayExtra' p q r) x = Maybe (Day, Int, Int) + eval _ opts x = do + let msg0 = "MkDayExtra" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let mday = fromGregorianValid (fromIntegral p) q r + b = mday <&> \day -> + let (_, week, dow) = toWeekDate day + in (day, week, dow) + in mkNode opts (PresentT b) (show01' opts msg0 b "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) + +data MkDayExtra p +type MkDayExtraT p = MkDayExtra' (Fst p) (Snd p) (Thd p) + +instance P (MkDayExtraT p) x => P (MkDayExtra p) x where + type PP (MkDayExtra p) x = PP (MkDayExtraT p) x + eval _ = eval (Proxy @(MkDayExtraT p)) + +-- | get day of week +-- +-- >>> pz @(Just (MkDay '(2020,7,11)) >> '(UnMkDay Id, ToWeekYear Id,ToWeekDate Id)) () +-- PresentT ((2020,7,11),28,(6,"Saturday")) +-- +data ToWeekDate p + +instance ( P p x + , PP p x ~ Day + ) => P (ToWeekDate p) x where + type PP (ToWeekDate p) x = (Int, String) + eval _ opts x = do + let msg0 = "ToWeekDate" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (_, _week, dow) = toWeekDate p + dowString = + case dow of + 1 -> "Monday" + 2 -> "Tuesday" + 3 -> "Wednesday" + 4 -> "Thursday" + 5 -> "Friday" + 6 -> "Saturday" + 7 -> "Sunday" + _ -> error $ "oops: ToWeekDate invalid " ++ show dow + in mkNode opts (PresentT (dow,dowString)) (show01 opts msg0 dow p) [hh pp] + +-- | get week number of the year +-- +-- >>> pz @(Just (MkDay '(2020,7,11)) >> ToWeekYear Id) () +-- PresentT 28 +-- +data ToWeekYear p + +instance ( P p x + , PP p x ~ Day + ) => P (ToWeekYear p) x where + type PP (ToWeekYear p) x = Int + eval _ opts x = do + let msg0 = "ToWeekYear" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (_, week, _dow) = toWeekDate p + in mkNode opts (PresentT week) (show01 opts msg0 week p) [hh pp] + +class ToDayC a where + getDay :: a -> Day +instance ToDayC UTCTime where + getDay = utctDay +instance ToDayC ZonedTime where + getDay = getDay . zonedTimeToLocalTime +instance ToDayC LocalTime where + getDay = localDay +instance ToDayC Day where + getDay = id +instance ToDayC Rational where + getDay = getDay . P.posixSecondsToUTCTime . fromRational +instance ToDayC CP.SystemTime where + getDay = getDay . CP.systemToUTCTime + +class ToTimeC a where + getTime :: a -> TimeOfDay +instance ToTimeC UTCTime where + getTime = getTime . utctDayTime +instance ToTimeC ZonedTime where + getTime = getTime . zonedTimeToLocalTime +instance ToTimeC LocalTime where + getTime = localTimeOfDay +instance ToTimeC TimeOfDay where + getTime = id +instance ToTimeC DiffTime where + getTime = timeToTimeOfDay +instance ToTimeC Rational where + getTime = getTime . P.posixSecondsToUTCTime . fromRational +instance ToTimeC CP.SystemTime where + getTime = getTime . CP.systemToUTCTime + +-- | extract 'Day' from a DateTime +-- +-- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" +-- PresentT 2020-07-06 +-- +data ToDay p + +instance ( P p x + , Show (PP p x) + , ToDayC (PP p x) + ) => P (ToDay p) x where + type PP (ToDay p) x = Day + eval _ opts x = do + let msg0 = "ToDay" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let ret = getDay p + in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp] + +-- | extract 'TimeOfDay' from DateTime +-- +-- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" +-- PresentT 2020-07-06 +-- +data ToTime p + +instance ( P p x + , Show (PP p x) + , ToTimeC (PP p x) + ) => P (ToTime p) x where + type PP (ToTime p) x = TimeOfDay + eval _ opts x = do + let msg0 = "ToTime" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let ret = getTime p + in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp] + + +-- | create a 'TimeOfDay' from three int values passed in as year month and day +-- +-- >>> pz @(MkTime' (Fst Id) (Snd Id) (Thd Id)) (13,99,99999) +-- PresentT 13:99:99999 +-- +data MkTime' p q r + +instance (P p x + , P q x + , P r x + , PP p x ~ Int + , PP q x ~ Int + , PP r x ~ Rational + ) => P (MkTime' p q r) x where + type PP (MkTime' p q r) x = TimeOfDay + eval _ opts x = do + let msg0 = "MkTime" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let mtime = TimeOfDay p q (fromRational r) + in mkNode opts (PresentT mtime) (show01' opts msg0 mtime "(h,m,s)=" (p,q,r)) (hhs <> [hh rr]) + +-- | create a 'TimeOfDay' from a three-tuple of year month and day +-- +-- >>> pz @(MkTime '(1,2,3 % 12345)) () +-- PresentT 01:02:00.000243013365 +-- +-- >>> pz @(MkTime Id) (12,13,65) +-- PresentT 12:13:65 +-- +-- >>> pz @(MkTime Id) (17,3,13) +-- PresentT 17:03:13 +-- +data MkTime p +type MkTimeT p = MkTime' (Fst p) (Snd p) (Thd p) + +instance P (MkTimeT p) x => P (MkTime p) x where + type PP (MkTime p) x = PP (MkTimeT p) x + eval _ = eval (Proxy @(MkTimeT p)) + + +-- | uncreate a 'TimeOfDay' returning hour minute seconds picoseconds +-- +-- >>> pz @(ReadP UTCTime "2019-01-01 12:13:14.1234Z" >> ToTime Id >> UnMkTime Id) () +-- PresentT (12,13,70617 % 5000) +-- +-- >>> pz @(ReadP UTCTime Id >> ToTime Id >> UnMkTime Id) "2020-07-22 08:01:14.127Z" +-- PresentT (8,1,14127 % 1000) +-- +-- >>> pz @(ReadP ZonedTime Id >> '(UnMkDay (ToDay Id), UnMkTime (ToTime Id))) "2020-07-11 11:41:12.333 CET" +-- PresentT ((2020,7,11),(11,41,12333 % 1000)) +-- +data UnMkTime p + +instance ( PP p x ~ TimeOfDay + , P p x + ) => P (UnMkTime p) x where + type PP (UnMkTime p) x = (Int, Int, Rational) + eval _ opts x = do + let msg0 = "UnMkTime" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let TimeOfDay h m s = p + b = (h, m, toRational s) + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + + +-- microsoft json date is x*1000 ie milliseconds + +-- | convert posix time (seconds since 01-01-1970) to 'UTCTime' +-- +-- >>> pl @(PosixToUTCTime Id) 1593384312 +-- Present 2020-06-28 22:45:12 UTC (PosixToUTCTime 2020-06-28 22:45:12 UTC | 1593384312 % 1) +-- PresentT 2020-06-28 22:45:12 UTC +-- +-- >>> pl @(PosixToUTCTime Id >> UTCTimeToPosix Id) 1593384312 +-- Present 1593384312 % 1 ((>>) 1593384312 % 1 | {UTCTimeToPosix 1593384312 % 1 | 2020-06-28 22:45:12 UTC}) +-- PresentT (1593384312 % 1) +-- +-- >>> pl @(PosixToUTCTime (Id % 1000)) 1593384312000 +-- Present 2020-06-28 22:45:12 UTC (PosixToUTCTime 2020-06-28 22:45:12 UTC | 1593384312 % 1) +-- PresentT 2020-06-28 22:45:12 UTC +-- +-- >>> pl @(PosixToUTCTime Id) (3600*4+60*7+12) +-- Present 1970-01-01 04:07:12 UTC (PosixToUTCTime 1970-01-01 04:07:12 UTC | 14832 % 1) +-- PresentT 1970-01-01 04:07:12 UTC +-- +-- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" Id >> Head Id >> Snd Id >> ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) "Date(1530144000000+0530)" +-- PresentT 2018-06-28 00:00:00 UTC +-- +data PosixToUTCTime p + +instance ( PP p x ~ Rational + , P p x + ) => P (PosixToUTCTime p) x where + type PP (PosixToUTCTime p) x = UTCTime + eval _ opts x = do + let msg0 = "PosixToUTCTime" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = P.posixSecondsToUTCTime (fromRational p) + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +-- | convert 'UTCTime' to posix time (seconds since 01-01-1970) +-- +-- >>> pl @(ReadP UTCTime Id >> UTCTimeToPosix Id) "2020-06-28 22:45:12 UTC" +-- Present 1593384312 % 1 ((>>) 1593384312 % 1 | {UTCTimeToPosix 1593384312 % 1 | 2020-06-28 22:45:12 UTC}) +-- PresentT (1593384312 % 1) +-- +-- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" Id >> Head Id >> Snd Id >> ((ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) &&& ReadP TimeZone (Id !! 1))) "Date(1530144000000+0530)" +-- PresentT (2018-06-28 00:00:00 UTC,+0530) +-- +-- not so useful: instead use ParseTimeP FormatTimeP with %s %q %z etc +-- +-- >>> pz @(ParseTimeP ZonedTime "%s%Q%z" Id) "153014400.000+0530" +-- PresentT 1974-11-07 05:30:00 +0530 +-- +data UTCTimeToPosix p + +instance ( PP p x ~ UTCTime + , P p x + ) => P (UTCTimeToPosix p) x where + type PP (UTCTimeToPosix p) x = Rational + eval _ opts x = do + let msg0 = "UTCTimeToPosix" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = toRational $ P.utcTimeToPOSIXSeconds p + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +-- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read +-- +-- >>> pz @(ReadP Rational Id) "4 % 5" +-- PresentT (4 % 5) +-- +-- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2018-10-12" +-- TrueT +-- +-- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2016-10-12" +-- FalseT +-- +data ReadP' t p + +instance (P p x + , PP p x ~ String + , Typeable (PP t x) + , Show (PP t x) + , Read (PP t x) + ) => P (ReadP' t p) x where + type PP (ReadP' t p) x = PP t x + eval _ opts x = do + let msg0 = "ReadP " <> t + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> + let hhs = [hh pp] + in case reads @(PP t x) s of + [(b,"")] -> mkNode opts (PresentT b) (msg0 <> " " ++ showL opts b) hhs + o -> mkNode opts (FailT (msg0 <> " (" ++ s ++ ")")) (showVerbose opts "" o) hhs + +data ReadP (t :: Type) p +type ReadPT (t :: Type) p = ReadP' (Hole t) p + +instance P (ReadPT t p) x => P (ReadP t p) x where + type PP (ReadP t p) x = PP (ReadPT t p) x + eval _ = eval (Proxy @(ReadPT t p)) + + +-- [] (a,s) (a,[]) + +-- | Read but returns the Maybe of the value and any remaining unparsed string +-- +-- >>> pz @(ReadMaybe Int Id) "123x" +-- PresentT (Just (123,"x")) +-- +-- >>> pz @(ReadMaybe Int Id) "123" +-- PresentT (Just (123,"")) +-- +-- >>> pz @(ReadMaybe Int Id) "x123" +-- PresentT Nothing +-- +data ReadMaybe' t p + +-- not as good as ReadQ +-- type ReadZ' t p = ReadMaybe' t p >> JustFail "read failed" Id >> (Guard "oops" (Snd Id >> Null) >> Fst Id) + +instance (P p x + , PP p x ~ String + , Typeable (PP t x) + , Show (PP t x) + , Read (PP t x) + ) => P (ReadMaybe' t p) x where + type PP (ReadMaybe' t p) x = Maybe (PP t x, String) + eval _ opts x = do + let msg0 = "ReadMaybe " <> t + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> + let msg1 = msg0 <> " (" <> s <> ")" + hhs = [hh pp] + in case reads @(PP t x) s of + [(b,rest)] -> mkNode opts (PresentT (Just (b,rest))) (lit01 opts msg1 b "" s) hhs + o -> mkNode opts (PresentT Nothing) (msg1 <> " failed" <> showVerbose opts " " o) hhs + +data ReadMaybe (t :: Type) p +type ReadMaybeT (t :: Type) p = ReadMaybe' (Hole t) p + +instance P (ReadMaybeT t p) x => P (ReadMaybe t p) x where + type PP (ReadMaybe t p) x = PP (ReadMaybeT t p) x + eval _ = eval (Proxy @(ReadMaybeT t p)) + +-- | emulates ReadP +data ReadQ' t p +type ReadQT' t p = ReadMaybe' t p >> MaybeIn (Failp "read failed") (Guard "oops" (Snd Id >> Null) >> Fst Id) + +instance P (ReadQT' t p) x => P (ReadQ' t p) x where + type PP (ReadQ' t p) x = PP (ReadQT' t p) x + eval _ = eval (Proxy @(ReadQT' t p)) + +data ReadQ (t :: Type) p +type ReadQT (t :: Type) p = ReadQ' (Hole t) p + +instance P (ReadQT t p) x => P (ReadQ t p) x where + type PP (ReadQ t p) x = PP (ReadQT t p) x + eval _ = eval (Proxy @(ReadQT t p)) + +-- | similar to 'sum' +-- +-- >>> pz @Sum [10,4,5,12,3,4] +-- PresentT 38 +-- +-- >>> pz @Sum [] +-- PresentT 0 +-- +data Sum + +instance ( Num a + , Show a + ) => P Sum [a] where + type PP Sum [a] = a + eval _ opts as = + let msg0 = "Sum" + v = sum as + in pure $ mkNode opts (PresentT v) (show01 opts msg0 v as) [] + +-- | similar to 'product' +-- +-- >>> pz @Product [10,4,5,12,3,4] +-- PresentT 28800 +-- +-- >>> pz @Product [] +-- PresentT 1 +-- +data Product + +instance ( Num a + , Show a + ) => P Product [a] where + type PP Product [a] = a + eval _ opts as = + let msg0 = "Product" + v = product as + in pure $ mkNode opts (PresentT v) (show01 opts msg0 v as) [] + +-- | similar to 'minimum' +-- +-- >>> pz @Min [10,4,5,12,3,4] +-- PresentT 3 +-- +-- >>> pz @Min [] +-- FailT "empty list" +-- +data Min + +instance ( Ord a + , Show a + ) => P Min [a] where + type PP Min [a] = a + eval _ opts as' = do + let msg0 = "Min" + pure $ case as' of + [] -> mkNode opts (FailT "empty list") msg0 [] + as@(_:_) -> + let v = minimum as + in mkNode opts (PresentT v) (show01 opts msg0 v as) [] + +-- | similar to 'maximum' +-- +-- >>> pz @Max [10,4,5,12,3,4] +-- PresentT 12 +-- +-- >>> pz @Max [] +-- FailT "empty list" +-- + +data Max + +instance ( Ord a + , Show a + ) => P Max [a] where + type PP Max [a] = a + eval _ opts as' = do + let msg0 = "Max" + pure $ case as' of + [] -> mkNode opts (FailT "empty list") msg0 [] + as@(_:_) -> + let v = maximum as + in mkNode opts (PresentT v) (show01 opts msg0 v as) [] + +-- | sort a list +-- +-- >>> pz @(SortOn (Fst Id) Id) [(10,"abc"), (3,"def"), (4,"gg"), (10,"xyz"), (1,"z")] +-- PresentT [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] +-- +-- >>> pz @(SortBy (OrdP (Snd Id) (Fst Id)) Id) [(10,"ab"),(4,"x"),(20,"bbb")] +-- PresentT [(20,"bbb"),(10,"ab"),(4,"x")] +-- +-- >>> pz @(SortBy 'LT Id) [1,5,2,4,7,0] +-- PresentT [1,5,2,4,7,0] +-- +-- >>> pz @(SortBy 'GT Id) [1,5,2,4,7,0] +-- PresentT [0,7,4,2,5,1] +-- +-- >>> pz @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Fst Id) ==! Snd (Snd Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- PresentT [(4,"a"),(4,"x"),(4,"y"),(10,"ab"),(20,"bbb")] +-- +-- >>> pz @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Snd Id) ==! Snd (Fst Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- PresentT [(4,"y"),(4,"x"),(4,"a"),(10,"ab"),(20,"bbb")] +-- +data SortBy p q + +type SortByHelperT p = Partition (p == 'GT) Id + +instance (P p (a,a) + , P q x + , Show a + , PP q x ~ [a] + , PP p (a,a) ~ Ordering + ) => P (SortBy p q) x where + type PP (SortBy p q) x = PP q x + eval _ opts x = do + let msg0 = "SortBy" + qq <- eval (Proxy @q) opts x + case getValueLR opts (msg0 <> " q failed") qq [] of + Left e -> pure e + Right as -> do + let ff :: MonadEval m => [a] -> m (TT [a]) + ff = \case + [] -> pure $ mkNode opts (PresentT mempty) (msg0 <> " empty") [hh qq] + [w] -> pure $ mkNode opts (PresentT [w]) (msg0 <> " one element " <> showL opts w) [hh qq] + w:ys@(_:_) -> do + pp <- evalHide (Proxy @(SortByHelperT p)) opts (map (w,) ys) + case getValueLR opts msg0 pp [hh qq] of + Left e -> pure e + Right (ll', rr') -> do + lhs <- ff (map snd ll') + case getValueLR opts msg0 lhs [hh qq, hh pp] of + Left _ -> pure lhs -- dont rewrap + Right ll -> do + rhs <- ff (map snd rr') + case getValueLR opts msg0 rhs [hh qq, hh pp, hh lhs] of + Left _ -> pure rhs + Right rr -> + pure $ mkNode opts (PresentT (ll ++ w : rr)) + (msg0 <> " lhs=" <> showL opts ll <> " pivot " <> show w <> " rhs=" <> showL opts rr) + (hh pp : [hh lhs | length ll > 1] ++ [hh rhs | length rr > 1]) + ret <- ff as + pure $ case getValueLR opts msg0 ret [hh qq] of + Left _e -> ret -- dont rewrap else will double up messages: already handled + Right xs -> mkNode opts (_tBool ret) (msg0 <> " " <> showL opts xs) [hh qq, hh ret] + +data SortOn p q +type SortOnT p q = SortBy (OrdA p) q + +instance P (SortOnT p q) x => P (SortOn p q) x where + type PP (SortOn p q) x = PP (SortOnT p q) x + eval _ = eval (Proxy @(SortOnT p q)) + +data SortOnDesc p q +type SortOnDescT p q = SortBy (Swap >> OrdA p) q + +instance P (SortOnDescT p q) x => P (SortOnDesc p q) x where + type PP (SortOnDesc p q) x = PP (SortOnDescT p q) x + eval _ = eval (Proxy @(SortOnDescT p q)) + +-- | similar to 'length' +-- +-- >>> pz @Len [10,4,5,12,3,4] +-- PresentT 6 +-- +-- >>> pz @Len [] +-- PresentT 0 +-- +data Len +instance ( Show a + , as ~ [a] + ) => P Len as where + type PP Len as = Int + eval _ opts as = + let msg0 = "Len" + n = length as + in pure $ mkNode opts (PresentT n) (show01 opts msg0 n as) [] + +-- | similar to 'length' for 'Foldable' instances +-- +-- >>> pz @(Length Id) (Left "aa") +-- PresentT 0 +-- +-- >>> pz @(Length Id) (Right "aa") +-- PresentT 1 +-- +-- >>> pz @(Length (Right' Id)) (Right "abcd") +-- PresentT 4 +-- +-- >>> pz @(Length (Thd (Snd Id))) (True,(23,'x',[10,9,1,3,4,2])) +-- PresentT 6 +-- +data Length p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t) => P (Length p) x where + type PP (Length p) x = Int + eval _ opts x = do + let msg0 = "Length" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let n = length p + in mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] + +-- | similar to 'fst' +-- +-- >>> pz @(Fst Id) (10,"Abc") +-- PresentT 10 +-- +-- >>> pz @(Fst Id) (10,"Abc",'x') +-- PresentT 10 +-- +-- >>> pz @(Fst Id) (10,"Abc",'x',False) +-- PresentT 10 +-- +data Fst p + +instance (Show (ExtractL1T (PP p x)) + , ExtractL1C (PP p x) + , P p x + , Show (PP p x) + ) => P (Fst p) x where + type PP (Fst p) x = ExtractL1T (PP p x) + eval _ opts x = do + let msg0 = "Fst" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL1C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data L1 p +type L1T p = Fst p + +instance P (L1T p) x => P (L1 p) x where + type PP (L1 p) x = PP (L1T p) x + eval _ = eval (Proxy @(L1T p)) + +class ExtractL1C tp where + type ExtractL1T tp + extractL1C :: tp -> ExtractL1T tp +instance ExtractL1C (a,b) where + type ExtractL1T (a,b) = a + extractL1C (a,_) = a +instance ExtractL1C (a,b,c) where + type ExtractL1T (a,b,c) = a + extractL1C (a,_,_) = a +instance ExtractL1C (a,b,c,d) where + type ExtractL1T (a,b,c,d) = a + extractL1C (a,_,_,_) = a +instance ExtractL1C (a,b,c,d,e) where + type ExtractL1T (a,b,c,d,e) = a + extractL1C (a,_,_,_,_) = a +instance ExtractL1C (a,b,c,d,e,f) where + type ExtractL1T (a,b,c,d,e,f) = a + extractL1C (a,_,_,_,_,_) = a + +-- | similar to 'snd' +-- +-- >>> pz @(Snd Id) (10,"Abc") +-- PresentT "Abc" +-- +-- >>> pz @(Snd Id) (10,"Abc",True) +-- PresentT "Abc" +-- +data Snd p + +instance (Show (ExtractL2T (PP p x)) + , ExtractL2C (PP p x) + , P p x + , Show (PP p x) + ) => P (Snd p) x where + type PP (Snd p) x = ExtractL2T (PP p x) + eval _ opts x = do + let msg0 = "Snd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL2C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data L2 p +type L2T p = Snd p + +instance P (L2T p) x => P (L2 p) x where + type PP (L2 p) x = PP (L2T p) x + eval _ = eval (Proxy @(L2T p)) + +class ExtractL2C tp where + type ExtractL2T tp + extractL2C :: tp -> ExtractL2T tp +instance ExtractL2C (a,b) where + type ExtractL2T (a,b) = b + extractL2C (_,b) = b +instance ExtractL2C (a,b,c) where + type ExtractL2T (a,b,c) = b + extractL2C (_,b,_) = b +instance ExtractL2C (a,b,c,d) where + type ExtractL2T (a,b,c,d) = b + extractL2C (_,b,_,_) = b +instance ExtractL2C (a,b,c,d,e) where + type ExtractL2T (a,b,c,d,e) = b + extractL2C (_,b,_,_,_) = b +instance ExtractL2C (a,b,c,d,e,f) where + type ExtractL2T (a,b,c,d,e,f) = b + extractL2C (_,b,_,_,_,_) = b + +-- | similar to 3rd element in a n-tuple +-- +-- >>> pz @(Thd Id) (10,"Abc",133) +-- PresentT 133 +-- +-- >>> pz @(Thd Id) (10,"Abc",133,True) +-- PresentT 133 +-- +data Thd p + +instance (Show (ExtractL3T (PP p x)) + , ExtractL3C (PP p x) + , P p x + , Show (PP p x) + ) => P (Thd p) x where + type PP (Thd p) x = ExtractL3T (PP p x) + eval _ opts x = do + let msg0 = "Thd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL3C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data L3 p +type L3T p = Thd p + +instance P (L3T p) x => P (L3 p) x where + type PP (L3 p) x = PP (L3T p) x + eval _ = eval (Proxy @(L3T p)) + +class ExtractL3C tp where + type ExtractL3T tp + extractL3C :: tp -> ExtractL3T tp +instance ExtractL3C (a,b) where + type ExtractL3T (a,b) = GL.TypeError ('GL.Text "Thd doesn't work for 2-tuples") + extractL3C _ = errorInProgram "Thd doesn't work for 2-tuples" +instance ExtractL3C (a,b,c) where + type ExtractL3T (a,b,c) = c + extractL3C (_,_,c) = c +instance ExtractL3C (a,b,c,d) where + type ExtractL3T (a,b,c,d) = c + extractL3C (_,_,c,_) = c +instance ExtractL3C (a,b,c,d,e) where + type ExtractL3T (a,b,c,d,e) = c + extractL3C (_,_,c,_,_) = c +instance ExtractL3C (a,b,c,d,e,f) where + type ExtractL3T (a,b,c,d,e,f) = c + extractL3C (_,_,c,_,_,_) = c + +-- | similar to 4th element in a n-tuple +-- +-- >>> pz @(L4 Id) (10,"Abc",'x',True) +-- PresentT True +-- +-- >>> pz @(L4 (Fst (Snd Id))) ('x',((10,"Abc",'x',999),"aa",1),9) +-- PresentT 999 +-- +data L4 p + +instance (Show (ExtractL4T (PP p x)) + , ExtractL4C (PP p x) + , P p x + , Show (PP p x) + ) => P (L4 p) x where + type PP (L4 p) x = ExtractL4T (PP p x) + eval _ opts x = do + let msg0 = "L4" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL4C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +class ExtractL4C tp where + type ExtractL4T tp + extractL4C :: tp -> ExtractL4T tp +instance ExtractL4C (a,b) where + type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 doesn't work for 2-tuples") + extractL4C _ = errorInProgram "L4 doesn't work for 2-tuples" +instance ExtractL4C (a,b,c) where + type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 doesn't work for 3-tuples") + extractL4C _ = errorInProgram "L4 doesn't work for 3-tuples" +instance ExtractL4C (a,b,c,d) where + type ExtractL4T (a,b,c,d) = d + extractL4C (_,_,_,d) = d +instance ExtractL4C (a,b,c,d,e) where + type ExtractL4T (a,b,c,d,e) = d + extractL4C (_,_,_,d,_) = d +instance ExtractL4C (a,b,c,d,e,f) where + type ExtractL4T (a,b,c,d,e,f) = d + extractL4C (_,_,_,d,_,_) = d + +-- | similar to 5th element in a n-tuple +-- +-- >>> pz @(L5 Id) (10,"Abc",'x',True,1) +-- PresentT 1 +-- +data L5 p + +instance (Show (ExtractL5T (PP p x)) + , ExtractL5C (PP p x) + , P p x + , Show (PP p x) + ) => P (L5 p) x where + type PP (L5 p) x = ExtractL5T (PP p x) + eval _ opts x = do + let msg0 = "L5" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL5C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +class ExtractL5C tp where + type ExtractL5T tp + extractL5C :: tp -> ExtractL5T tp +instance ExtractL5C (a,b) where + type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 doesn't work for 2-tuples") + extractL5C _ = errorInProgram "L5 doesn't work for 2-tuples" +instance ExtractL5C (a,b,c) where + type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 doesn't work for 3-tuples") + extractL5C _ = errorInProgram "L5 doesn't work for 3-tuples" +instance ExtractL5C (a,b,c,d) where + type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 doesn't work for 4-tuples") + extractL5C _ = errorInProgram "L5 doesn't work for 4-tuples" +instance ExtractL5C (a,b,c,d,e) where + type ExtractL5T (a,b,c,d,e) = e + extractL5C (_,_,_,_,e) = e +instance ExtractL5C (a,b,c,d,e,f) where + type ExtractL5T (a,b,c,d,e,f) = e + extractL5C (_,_,_,_,e,_) = e + + +-- | similar to 6th element in a n-tuple +-- +-- >>> pz @(L6 Id) (10,"Abc",'x',True,1,99) +-- PresentT 99 +-- +data L6 p + +instance (Show (ExtractL6T (PP p x)) + , ExtractL6C (PP p x) + , P p x + , Show (PP p x) + ) => P (L6 p) x where + type PP (L6 p) x = ExtractL6T (PP p x) + eval _ opts x = do + let msg0 = "L6" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL6C p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +class ExtractL6C tp where + type ExtractL6T tp + extractL6C :: tp -> ExtractL6T tp +instance ExtractL6C (a,b) where + type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 doesn't work for 2-tuples") + extractL6C _ = errorInProgram "L6 doesn't work for 2-tuples" +instance ExtractL6C (a,b,c) where + type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 doesn't work for 3-tuples") + extractL6C _ = errorInProgram "L6 doesn't work for 3-tuples" +instance ExtractL6C (a,b,c,d) where + type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 doesn't work for 4-tuples") + extractL6C _ = errorInProgram "L6 doesn't work for 4-tuples" +instance ExtractL6C (a,b,c,d,e) where + type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 doesn't work for 5-tuples") + extractL6C _ = errorInProgram "L6 doesn't work for 5-tuples" +instance ExtractL6C (a,b,c,d,e,f) where + type ExtractL6T (a,b,c,d,e,f) = f + extractL6C (_,_,_,_,_,f) = f + + +-- | 'fromString' function where you need to provide the type \'t\' of the result +-- +-- >>> :set -XFlexibleContexts +-- >>> pz @(FromString (Identity _) Id) "abc" +-- PresentT (Identity "abc") +-- +-- >>> pz @(FromString (Seq.Seq Char) Id) "abc" +-- PresentT (fromList "abc") +data FromString' t s + +instance (P s a + , PP s a ~ String + , Show (PP t a) + , IsString (PP t a) + ) => P (FromString' t s) a where + type PP (FromString' t s) a = PP t a + eval _ opts a = do + let msg0 = "FromString" + ss <- eval (Proxy @s) opts a + pure $ case getValueLR opts msg0 ss [] of + Left e -> e + Right s -> + let b = fromString @(PP t a) s + in mkNode opts (PresentT b) (msg0 <> " " <> showL opts b) [hh ss] + +data FromString (t :: Type) p +type FromStringPT (t :: Type) p = FromString' (Hole t) p + +instance P (FromStringPT t p) x => P (FromString t p) x where + type PP (FromString t p) x = PP (FromStringPT t p) x + eval _ = eval (Proxy @(FromStringPT t p)) + + +-- | 'fromInteger' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(FromInteger (SG.Sum _) Id) 23 +-- PresentT (Sum {getSum = 23}) +-- +-- >>> pz @(FromInteger Rational 44) 12 +-- PresentT (44 % 1) +-- +-- >>> pz @(FromInteger Rational Id) 12 +-- PresentT (12 % 1) +-- +data FromInteger' t n + +instance (Num (PP t a) + , Integral (PP n a) + , P n a + , Show (PP t a) + ) => P (FromInteger' t n) a where + type PP (FromInteger' t n) a = PP t a + eval _ opts a = do + let msg0 = "FromInteger" + nn <- eval (Proxy @n) opts a + pure $ case getValueLR opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromInteger (fromIntegral n) + in mkNode opts (PresentT b) (msg0 <> " " <> showL opts b) [hh nn] + +data FromInteger (t :: Type) p +type FromIntegerT (t :: Type) p = FromInteger' (Hole t) p +--type FromIntegerP n = FromInteger' Unproxy n + +instance P (FromIntegerT t p) x => P (FromInteger t p) x where + type PP (FromInteger t p) x = PP (FromIntegerT t p) x + eval _ = eval (Proxy @(FromIntegerT t p)) + +-- | 'fromIntegral' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(FromIntegral (SG.Sum _) Id) 23 +-- PresentT (Sum {getSum = 23}) +data FromIntegral' t n + +instance (Num (PP t a) + , Integral (PP n a) + , P n a + , Show (PP t a) + , Show (PP n a) + ) => P (FromIntegral' t n) a where + type PP (FromIntegral' t n) a = PP t a + eval _ opts a = do + let msg0 = "FromIntegral" + nn <- eval (Proxy @n) opts a + pure $ case getValueLR opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromIntegral n + in mkNode opts (PresentT b) (show01 opts msg0 b n) [hh nn] + +data FromIntegral (t :: Type) p +type FromIntegralT (t :: Type) p = FromIntegral' (Hole t) p + +instance P (FromIntegralT t p) x => P (FromIntegral t p) x where + type PP (FromIntegral t p) x = PP (FromIntegralT t p) x + eval _ = eval (Proxy @(FromIntegralT t p)) + +-- | 'toRational' function +-- +-- >>> pz @(ToRational Id) 23.5 +-- PresentT (47 % 2) + +data ToRational p + +instance (a ~ PP p x + , Show a + , Real a + , P p x) + => P (ToRational p) x where + type PP (ToRational p) x = Rational + eval _ opts x = do + let msg0 = "ToRational" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a -> + let r = toRational a + in mkNode opts (PresentT r) (show01 opts msg0 r a) [hh pp] + +-- | 'fromRational' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(FromRational Rational Id) 23.5 +-- PresentT (47 % 2) +data FromRational' t r + +instance (P r a + , PP r a ~ Rational + , Show (PP t a) + , Fractional (PP t a) + ) => P (FromRational' t r) a where + type PP (FromRational' t r) a = PP t a + eval _ opts a = do + let msg0 = "FromRational" + rr <- eval (Proxy @r) opts a + pure $ case getValueLR opts msg0 rr [] of + Left e -> e + Right r -> + let b = fromRational @(PP t a) r + in mkNode opts (PresentT b) (show01 opts msg0 b r) [hh rr] + +data FromRational (t :: Type) p +type FromRationalT (t :: Type) p = FromRational' (Hole t) p + +instance P (FromRationalT t p) x => P (FromRational t p) x where + type PP (FromRational t p) x = PP (FromRationalT t p) x + eval _ = eval (Proxy @(FromRationalT t p)) + +-- | 'truncate' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(Truncate Int Id) (23 % 5) +-- PresentT 4 +data Truncate' t p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Truncate' t p) x where + type PP (Truncate' t p) x = PP t x + eval _ opts x = do + let msg0 = "Truncate" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = truncate p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data Truncate (t :: Type) p +type TruncateT (t :: Type) p = Truncate' (Hole t) p + +instance P (TruncateT t p) x => P (Truncate t p) x where + type PP (Truncate t p) x = PP (TruncateT t p) x + eval _ = eval (Proxy @(TruncateT t p)) + +-- | 'ceiling' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(Ceiling Int Id) (23 % 5) +-- PresentT 5 +data Ceiling' t p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Ceiling' t p) x where + type PP (Ceiling' t p) x = PP t x + eval _ opts x = do + let msg0 = "Ceiling" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = ceiling p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data Ceiling (t :: Type) p +type CeilingT (t :: Type) p = Ceiling' (Hole t) p + +instance P (CeilingT t p) x => P (Ceiling t p) x where + type PP (Ceiling t p) x = PP (CeilingT t p) x + eval _ = eval (Proxy @(CeilingT t p)) + +-- | 'floor' function where you need to provide the type \'t\' of the result +-- +-- >>> pz @(Floor Int Id) (23 % 5) +-- PresentT 4 +data Floor' t p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Floor' t p) x where + type PP (Floor' t p) x = PP t x + eval _ opts x = do + let msg0 = "Floor" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = floor p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data Floor (t :: Type) p +type FloorT (t :: Type) p = Floor' (Hole t) p + +instance P (FloorT t p) x => P (Floor t p) x where + type PP (Floor t p) x = PP (FloorT t p) x + eval _ = eval (Proxy @(FloorT t p)) +-- | converts a value to a 'Proxy': the same as '\'Proxy' +-- +-- >>> pz @MkProxy 'x' +-- PresentT Proxy +-- +data MkProxy + +instance Show a => P MkProxy a where + type PP MkProxy a = Proxy a + eval _ opts a = + let msg0 = "MkProxy" + b = Proxy @a + in pure $ mkNode opts (PresentT b) (msg0 <> showVerbose opts " | " a) [] + +-- | processes a type level list predicates running each in sequence: see 'Predicate.>>' +-- +-- >>> pz @(Do [Pred Id, ShowP Id, Id &&& Len]) 9876543 +-- PresentT ("9876542",7) +-- +-- >>> pz @(Do '[W 123, W "xyz", Len &&& Id, Pred Id *** Id<>Id]) () +-- PresentT (2,"xyzxyz") +-- +data Do (ps :: [k]) + +instance (P (DoExpandT ps) a) => P (Do ps) a where + type PP (Do ps) a = PP (DoExpandT ps) a + eval _ = eval (Proxy @(DoExpandT ps)) + +type family DoExpandT (ps :: [k]) :: Type where + DoExpandT '[] = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") + DoExpandT '[p] = Id >> p -- need this else fails cos 1 is nat and would mean that the result is nat not Type! + -- if p >> Id then turns TrueT to PresentT True + DoExpandT (p ': p1 ': ps) = p >> DoExpandT (p1 ': ps) + +-- | Convenient method to convert a value \'p\' to a 'Maybe' based on a predicate '\b\' +-- if '\b\' then Just \'p'\ else Nothing +-- +-- >>> pz @(MaybeBool (Id > 4) Id) 24 +-- PresentT (Just 24) +-- +-- >>> pz @(MaybeBool (Id > 4) Id) (-5) +-- PresentT Nothing +-- +data MaybeBool b p + +instance (Show (PP p a) + , P b a + , P p a + , PP b a ~ Bool + ) => P (MaybeBool b p) a where + type PP (MaybeBool b p) a = Maybe (PP p a) + eval _ opts z = do + let msg0 = "MaybeBool" + bb <- evalBool (Proxy @b) opts z + case getValueLR opts (msg0 <> " b failed") bb [] of + Left e -> pure e + Right True -> do + pp <- eval (Proxy @p) opts z + pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of + Left e -> e + Right p -> mkNode opts (PresentT (Just p)) (msg0 <> "(False)" <> " Just " <> showL opts p) [hh bb, hh pp] + Right False -> pure $ mkNode opts (PresentT Nothing) (msg0 <> "(True)") [hh bb] + +-- | Convenient method to convert a \'p\' or '\q'\ to a 'Either' based on a predicate '\b\' +-- if \'b\' then Right \'p\' else Left '\q\' +-- +-- >>> pz @(EitherBool (Fst Id > 4) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (24,(-1,999)) +-- PresentT (Right 999) +-- +-- >>> pz @(EitherBool (Fst Id > 4) (Fst (Snd Id)) (Snd (Snd Id))) (1,(-1,999)) +-- PresentT (Left (-1)) +-- +data EitherBool b p q + +instance (Show (PP p a) + , P p a + , Show (PP q a) + , P q a + , P b a + , PP b a ~ Bool + ) => P (EitherBool b p q) a where + type PP (EitherBool b p q) a = Either (PP p a) (PP q a) + eval _ opts z = do + let msg0 = "EitherBool" + bb <- evalBool (Proxy @b) opts z + case getValueLR opts (msg0 <> " b failed") bb [] of + Left e -> pure e + Right False -> do + pp <- eval (Proxy @p) opts z + pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of + Left e -> e + Right p -> mkNode opts (PresentT (Left p)) (msg0 <> "(False)" <> " Left " <> showL opts p) [hh bb, hh pp] + Right True -> do + qq <- eval (Proxy @q) opts z + pure $ case getValueLR opts (msg0 <> " q failed") qq [hh bb] of + Left e -> e + Right q -> mkNode opts (PresentT (Right q)) (msg0 <> "(True)" <> " Right " <> showL opts q) [hh bb, hh qq] + +-- | pad \'q\' with '\n'\ values from '\p'\ +-- +-- >>> pz @(PadL 5 999 Id) [12,13] +-- PresentT [999,999,999,12,13] +-- +-- >>> pz @(PadR 5 (Fst Id) '[12,13]) (999,'x') +-- PresentT [12,13,999,999,999] +-- +-- >>> pz @(PadR 2 (Fst Id) '[12,13,14]) (999,'x') +-- PresentT [12,13,14] +-- +data PadImpl (left :: Bool) n p q + +instance (P n a + , GetBool left + , Integral (PP n a) + , [PP p a] ~ PP q a + , P p a + , P q a + , Show (PP p a) + ) => P (PadImpl left n p q) a where + type PP (PadImpl left n p q) a = PP q a + eval _ opts a = do + let msg0 = "Pad" <> (if lft then "L" else "R") + lft = getBool @left + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] + case lr of + Left e -> pure e + Right (fromIntegral -> n,p,nn,pp) -> do + let msg1 = msg0 <> " " <> showL opts n <> " pad=" <> show p + hhs = [hh nn, hh pp] + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts (msg1 <> " q failed") qq hhs of + Left e -> e + Right q -> + let l = length q + diff = if n<=l then 0 else n-l + bs = if lft + then replicate diff p <> q + else q <> replicate diff p + in mkNode opts (PresentT bs) (show01 opts msg1 bs q) (hhs <> [hh qq]) + +data PadL n p q +type PadLT n p q = PadImpl 'True n p q + +instance P (PadLT n p q) x => P (PadL n p q) x where + type PP (PadL n p q) x = PP (PadLT n p q) x + eval _ = eval (Proxy @(PadLT n p q)) + +data PadR n p q +type PadRT n p q = PadImpl 'False n p q + +instance P (PadRT n p q) x => P (PadR n p q) x where + type PP (PadR n p q) x = PP (PadRT n p q) x + eval _ = eval (Proxy @(PadRT n p q)) + +-- | split a list \'p\' into parts using the lengths in the type level list \'ns\' +-- +-- >>> pz @(SplitAts '[2,3,1,1] Id) "hello world" +-- PresentT ["he","llo"," ","w","orld"] +-- +-- >>> pz @(SplitAts '[2] Id) "hello world" +-- PresentT ["he","llo world"] +-- +-- >>> pz @(SplitAts '[10,1,1,5] Id) "hello world" +-- PresentT ["hello worl","d","",""] +-- +data SplitAts ns p + +instance (P ns x + , P p x + , PP p x ~ [a] + , Show n + , Show a + , PP ns x ~ [n] + , Integral n + ) => P (SplitAts ns p) x where + type PP (SplitAts ns p) x = [PP p x] + eval _ opts x = do + let msg0 = "SplitAts" + lr <- runPQ msg0 (Proxy @ns) (Proxy @p) opts x [] + pure $ case lr of + Left e -> e + Right (ns,p,nn,pp) -> + let zs = foldr (\n k s -> let (a,b) = splitAtNeg (fromIntegral n) s + in a:k b + ) (\as -> if null as then [] else [as]) ns p + in mkNode opts (PresentT zs) (show01' opts msg0 zs "ns=" ns <> showVerbose opts " | " p) [hh nn, hh pp] + +-- | similar to 'splitAt' +-- +-- >>> pz @(SplitAt 4 Id) "hello world" +-- PresentT ("hell","o world") +-- +-- >>> pz @(SplitAt 20 Id) "hello world" +-- PresentT ("hello world","") +-- +-- >>> pz @(SplitAt 0 Id) "hello world" +-- PresentT ("","hello world") +-- +-- >>> pz @(SplitAt (Snd Id) (Fst Id)) ("hello world",4) +-- PresentT ("hell","o world") +-- +-- >>> pz @(SplitAt (Negate 2) Id) "hello world" +-- PresentT ("hello wor","ld") +-- +data SplitAt n p + +instance (PP p a ~ [b] + , P n a + , P p a + , Show b + , Integral (PP n a) + ) => P (SplitAt n p) a where + type PP (SplitAt n p) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "SplitAt" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] + pure $ case lr of + Left e -> e -- (Left e, tt') + Right (fromIntegral -> n,p,pp,qq) -> + let msg1 = msg0 <> " " <> showL opts n <> " " <> showL opts p + ret = splitAtNeg n p + in mkNode opts (PresentT ret) (show01' opts msg1 ret "n=" n <> showVerbose opts " | " p) [hh pp, hh qq] + +splitAtNeg :: Int -> [a] -> ([a], [a]) +splitAtNeg n as = splitAt (if n<0 then length as + n else n) as + + +data Take n p +type TakeT n p = Fst (SplitAt n p) + +instance P (TakeT n p) x => P (Take n p) x where + type PP (Take n p) x = PP (TakeT n p) x + eval _ = eval (Proxy @(TakeT n p)) + +data Drop n p +type DropT n p = Snd (SplitAt n p) + +instance P (DropT n p) x => P (Drop n p) x where + type PP (Drop n p) x = PP (DropT n p) x + eval _ = eval (Proxy @(DropT n p)) + +--type Tail = Uncons >> 'Just (Snd Id) +--type Head = Uncons >> 'Just (Fst Id) +--type Init = Unsnoc >> 'Just (Fst Id) +--type Last = Unsnoc >> 'Just (Snd Id) + +-- | similar to 'Control.Arrow.&&&' +data p &&& q +infixr 3 &&& +type WAmpT p q = W '(p, q) + +instance P (WAmpT p q) x => P (p &&& q) x where + type PP (p &&& q) x = PP (WAmpT p q) x + eval _ = eval (Proxy @(WAmpT p q)) + +-- | similar to 'Control.Arrow.***' +-- +-- >>> pz @(Pred Id *** ShowP Id) (13, True) +-- PresentT (12,"True") +-- +-- >>> pl @(FlipT (***) Len (Id * 12)) (99,"cdef") +-- Present (1188,4) ((***) (1188,4) | (99,"cdef")) +-- PresentT (1188,4) +-- +data p *** q +infixr 3 *** + +instance (Show (PP p a) + , Show (PP q b) + , P p a + , P q b + , Show a + , Show b + ) => P (p *** q) (a,b) where + type PP (p *** q) (a,b) = (PP p a, PP q b) + eval _ opts (a,b) = do + let msg0 = "(***)" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right a1 -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right b1 -> mkNode opts (PresentT (a1,b1)) (msg0 <> " " <> showL opts (a1,b1) <> showVerbose opts " | " (a,b)) [hh pp, hh qq] + +data First p +type FirstT p = p *** I + +instance P (FirstT p) x => P (First p) x where + type PP (First p) x = PP (FirstT p) x + eval _ = eval (Proxy @(FirstT p)) + +data Second q +type SecondT q = I *** q + +instance P (SecondT q) x => P (Second q) x where + type PP (Second q) x = PP (SecondT q) x + eval _ = eval (Proxy @(SecondT q)) + +-- | similar 'Control.Arrow.|||' +-- +-- >>> pz @(Pred Id ||| Id) (Left 13) +-- PresentT 12 +-- +-- >>> pz @(ShowP Id ||| Id) (Right "hello") +-- PresentT "hello" +-- +data p ||| q +infixr 2 ||| +type EitherIn p q = p ||| q + +instance (Show (PP p a) + , P p a + , P q b + , PP p a ~ PP q b + , Show a + , Show b + ) => P (p ||| q) (Either a b) where + type PP (p ||| q) (Either a b) = PP p a + eval _ opts lr = do + let msg0 = "(|||)" + case lr of + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a1 -> let msg1 = msg0 ++ " Left" + in mkNode opts (_tBool pp) (show01 opts msg1 a1 a) [hh pp] + Right a -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Right" + in mkNode opts (_tBool qq) (show01 opts msg1 a1 a) [hh qq] + +-- | similar to 'isLeft' +-- +-- >>> pz @(IsLeft Id) (Right 123) +-- FalseT +-- +-- >>> pz @(IsLeft Id) (Left 'a') +-- TrueT +-- +data IsLeft p + +instance ( P p x + , PP p x ~ Either a b + ) => P (IsLeft p) x where + type PP (IsLeft p) x = Bool + eval _ opts x = do + let msg0 = "IsLeft" + pp <- eval (Proxy @p) opts x + let hhs = [hh pp] + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (Left _) -> mkNodeB opts True msg0 hhs + Right (Right _) -> mkNodeB opts False msg0 hhs + +-- | similar to 'isRight' +-- +-- >>> pz @(IsRight Id) (Right 123) +-- TrueT +-- +-- >>> pz @(IsRight Id) (Left "aa") +-- FalseT +-- + +data IsRight p + +instance ( P p x + , PP p x ~ Either a b + ) => P (IsRight p) x where + type PP (IsRight p) x = Bool + eval _ opts x = do + let msg0 = "IsRight" + pp <- eval (Proxy @p) opts x + let hhs = [hh pp] + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (Left _) -> mkNodeB opts False msg0 hhs + Right (Right _) -> mkNodeB opts True msg0 hhs + + +-- | similar 'Control.Arrow.+++' +-- +-- >>> pz @(Pred Id +++ Id) (Left 13) +-- PresentT (Left 12) +-- +-- >>> pz @(ShowP Id +++ Reverse) (Right "hello") +-- PresentT (Right "olleh") +-- +data p +++ q +infixr 2 +++ + +instance (Show (PP p a) + , Show (PP q b) + , P p a + , P q b + , Show a + , Show b + ) => P (p +++ q) (Either a b) where + type PP (p +++ q) (Either a b) = Either (PP p a) (PP q b) + eval _ opts lr = do + let msg0 = "(+++)" + case lr of + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Left" + in mkNode opts (PresentT (Left a1)) (msg1 <> " " <> showL opts a1 <> showVerbose opts " | " a) [hh pp] + Right a -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Right" + in mkNode opts (PresentT (Right a1)) (msg1 <> " " <> showL opts a1 <> showVerbose opts " | " a) [hh qq] + +data Dup +type DupT = W '(Id, Id) + +instance Show x => P Dup x where + type PP Dup x = PP DupT x + eval _ = eval (Proxy @DupT) + +data BinOp = BMult | BSub | BAdd deriving (Show,Eq) + +data p + q +infixl 6 + + +type AddT p q = Bin 'BAdd p q + +instance P (AddT p q) x => P (p + q) x where + type PP (p + q) x = PP (AddT p q) x + eval _ = eval (Proxy @(AddT p q)) + +data p - q +infixl 6 - + +type SubT p q = Bin 'BSub p q + +instance P (SubT p q) x => P (p - q) x where + type PP (p - q) x = PP (SubT p q) x + eval _ = eval (Proxy @(SubT p q)) + +data p * q +infixl 7 * + +type MultT p q = Bin 'BMult p q + +instance P (MultT p q) x => P (p * q) x where + type PP (p * q) x = PP (MultT p q) x + eval _ = eval (Proxy @(MultT p q)) + +-- | similar to 'GHC.Real.(^)' +-- +-- >>> pz @(Fst Id ^ Snd Id) (10,4) +-- PresentT 10000 +-- +data p ^ q +infixr 8 ^ + +instance (P p a + , P q a + , Show (PP p a) + , Show (PP q a) + , Num (PP p a) + , Integral (PP q a) + ) => P (p ^ q) a where + type PP (p ^ q) a = PP p a + eval _ opts a = do + let msg0 = "Pow" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right q -> + let hhs = [hh pp, hh qq] + in if q < 0 then mkNode opts (FailT (msg0 <> " negative exponent")) "" hhs + else let d = p ^ q + in mkNode opts (PresentT d) (showL opts p <> " ^ " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'GHC.Float.(**)' +-- +-- >>> pz @(Fst Id ** Snd Id) (10,4) +-- PresentT 10000.0 +-- +-- >>> pz @'(Prime Id,Id ^ 3,(FromIntegral _ Id) ** (FromRational _ (1 % 2))) 4 +-- PresentT (False,64,2.0) +-- +data p ** q +infixr 8 ** + +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Floating (PP p a) + , Ord (PP q a) + ) => P (p ** q) a where + type PP (p ** q) a = PP p a + eval _ opts a = do + let msg0 = "Exp" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in if q < 0 then mkNode opts (FailT (msg0 <> " negative exponent")) "" hhs + else if p == 0 && q == 0 then mkNode opts (FailT (msg0 <> " zero/zero")) "" hhs + else let d = p ** q + in mkNode opts (PresentT d) (showL opts p <> " ** " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'logBase' +-- +-- >>> pz @(Fst Id `LogBase` Snd Id >> Truncate Int Id) (10,12345) +-- PresentT 4 +-- +data LogBase p q +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP q a) + , Floating (PP q a) + , Ord (PP p a) + ) => P (LogBase p q) a where + type PP (LogBase p q) a = PP p a + eval _ opts a = do + let msg0 = "LogBase" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in if p <= 0 then mkNode opts (FailT (msg0 <> " non-positive base")) "" hhs + else let d = logBase p q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts p <> " " <> showL opts q <> " = " <> showL opts d) hhs + +data p > q +infix 4 > + +instance P (Cmp 'CGt p q) x => P (p > q) x where + type PP (p > q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CGt p q)) + +data p >= q +infix 4 >= + +instance P (Cmp 'CGe p q) x => P (p >= q) x where + type PP (p >= q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CGe p q)) + +data p == q +infix 4 == + +instance P (Cmp 'CEq p q) x => P (p == q) x where + type PP (p == q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CEq p q)) + +data p <= q +infix 4 <= + +instance P (Cmp 'CLe p q) x => P (p <= q) x where + type PP (p <= q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CLe p q)) + +data p < q +infix 4 < + +instance P (Cmp 'CLt p q) x => P (p < q) x where + type PP (p < q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CLt p q)) + +data p /= q +infix 4 /= + +instance P (Cmp 'CNe p q) x => P (p /= q) x where + type PP (p /= q) x = Bool + eval _ = evalBool (Proxy @(Cmp 'CNe p q)) + +--type p + q = Bin 'BAdd p q +--type p - q = Bin 'BSub p q +--type p * q = Bin 'BMult p q + +--type p > q = Cmp 'CGt p q +--type p >= q = Cmp 'CGe p q +--type p == q = Cmp 'CEq p q +--type p /= q = Cmp 'CNe p q +--type p <= q = Cmp 'CLe p q +--type p < q = Cmp 'CLt p q + +type Gt n = I > n +type Ge n = I >= n +type Same n = I == n +type Le n = I <= n +type Lt n = I < n +type Ne n = I /= n + +--type p >~ q = CmpI 'CGt p q +--type p >=~ q = CmpI 'CGe p q +--type p ==~ q = CmpI 'CEq p q +--type p <=~ q = CmpI 'CLe p q +--type p <~ q = CmpI 'CLt p q +--type p /=~ q = CmpI 'CNe p q + +data p >~ q +infix 4 >~ + +instance P (CmpI 'CGt p q) x => P (p >~ q) x where + type PP (p >~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CGt p q)) + +data p >=~ q +infix 4 >=~ + +instance P (CmpI 'CGe p q) x => P (p >=~ q) x where + type PP (p >=~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CGe p q)) + +data p ==~ q +infix 4 ==~ + +instance P (CmpI 'CEq p q) x => P (p ==~ q) x where + type PP (p ==~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CEq p q)) + +data p <=~ q +infix 4 <=~ + +instance P (CmpI 'CLe p q) x => P (p <=~ q) x where + type PP (p <=~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CLe p q)) + +data p <~ q +infix 4 <~ + +instance P (CmpI 'CLt p q) x => P (p <~ q) x where + type PP (p <~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CLt p q)) + +data p /=~ q +infix 4 /=~ + +instance P (CmpI 'CNe p q) x => P (p /=~ q) x where + type PP (p /=~ q) x = Bool + eval _ = evalBool (Proxy @(CmpI 'CNe p q)) + + +class GetBinOp (k :: BinOp) where + getBinOp :: (Num a, a ~ b) => (String, a -> b -> a) + +instance GetBinOp 'BMult where + getBinOp = ("*",(*)) +instance GetBinOp 'BSub where + getBinOp = ("-",(-)) +instance GetBinOp 'BAdd where + getBinOp = ("+",(+)) + +-- | addition, multiplication and subtraction +-- +-- >>> pz @(Fst Id * Snd Id) (13,5) +-- PresentT 65 +-- +-- >>> pz @(Fst Id + 4 * Length (Snd Id) - 4) (3,"hello") +-- PresentT 19 +-- +data Bin (op :: BinOp) p q + +instance (GetBinOp op + , PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Num (PP p a) + ) => P (Bin op p q) a where + type PP (Bin op p q) a = PP p a + eval _ opts a = do + let (s,f) = getBinOp @op + lr <- runPQ s (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p `f` q + in mkNode opts (PresentT d) (showL opts p <> " " <> s <> " " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- | fractional division +-- +-- >>> pz @(Fst Id / Snd Id) (13,2) +-- PresentT 6.5 +-- +-- >>> pz @(ToRational 13 / Id) 0 +-- FailT "(/) zero denominator" +-- +-- >>> pz @(12 % 7 / 14 % 5 + Id) 12.4 +-- PresentT (3188 % 245) +-- +data p / q +infixl 7 / + +instance (PP p a ~ PP q a + , Eq (PP q a) + , P p a + , P q a + , Show (PP p a) + , Fractional (PP p a) + ) => P (p / q) a where + type PP (p / q) a = PP p a + eval _ opts a = do + let msg0 = "(/)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) + | q == 0 -> let msg1 = msg0 <> " zero denominator" + in mkNode opts (FailT msg1) "" [hh pp, hh qq] + | otherwise -> + let d = p / q + in mkNode opts (PresentT d) (showL opts p <> " / " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- | creates a 'Rational' value +-- +-- >>> pz @(Id < 21 % 5) (-3.1) +-- TrueT +-- +-- >>> pz @(Id < 21 % 5) 4.5 +-- FalseT +-- +-- >>> pz @(Fst Id % Snd Id) (13,2) +-- PresentT (13 % 2) +-- +-- >>> pz @(13 % Id) 0 +-- FailT "(%) zero denominator" +-- +-- >>> pz @(4 % 3 + 5 % 7) "asfd" +-- PresentT (43 % 21) +-- +-- >>> pz @(4 -% 7 * 5 -% 3) "asfd" +-- PresentT (20 % 21) +-- +-- >>> pz @(Negate (14 % 3)) () +-- PresentT ((-14) % 3) +-- +-- >>> pz @(14 % 3) () +-- PresentT (14 % 3) +-- +-- >>> pz @(Negate (14 % 3) ==! FromIntegral _ (Negate 5)) () +-- PresentT GT +-- +-- >>> pz @(14 -% 3 ==! 5 -% 1) "aa" +-- PresentT GT +-- +-- >>> pz @(Negate (14 % 3) ==! Negate 5 % 2) () +-- PresentT LT +-- +-- >>> pz @(14 -% 3 * 5 -% 1) () +-- PresentT (70 % 3) +-- +-- >>> pz @(14 % 3 ==! 5 % 1) () +-- PresentT LT +-- +-- >>> pz @(15 % 3 / 4 % 2) () +-- PresentT (5 % 2) +-- +data p % q +infixl 8 % + +instance (Integral (PP p x) + , Integral (PP q x) + , Eq (PP q x) + , P p x + , P q x + , Show (PP p x) + , Show (PP q x) + ) => P (p % q) x where + type PP (p % q) x = Rational + eval _ opts x = do + let msg0 = "(%)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) + | q == 0 -> let msg1 = msg0 <> " zero denominator" + in mkNode opts (FailT msg1) "" [hh pp, hh qq] + | otherwise -> + let d = fromIntegral p % fromIntegral q + zz= if numerator d == fromIntegral p && denominator d == fromIntegral q then "" + else litVerbose opts " | " (show p <> " % " <> show q) + in mkNode opts (PresentT d) (showL opts d <> zz) [hh pp, hh qq] + +data p -% q -- = Negate (p % q) +infixl 8 -% +type NegateRatioT p q = Negate (p % q) + +instance P (NegateRatioT p q) x => P (p -% q) x where + type PP (p -% q) x = PP (NegateRatioT p q) x + eval _ = eval (Proxy @(NegateRatioT p q)) + + +-- | similar to 'negate' +-- +-- >>> pz @(Negate Id) 14 +-- PresentT (-14) +-- +-- >>> pz @(Negate (Fst Id * Snd Id)) (14,3) +-- PresentT (-42) +-- +-- >>> pz @(Negate (15 -% 4)) "abc" +-- PresentT (15 % 4) +-- +-- >>> pz @(Negate (15 % 3)) () +-- PresentT ((-5) % 1) +-- +-- >>> pz @(Negate (Fst Id % Snd Id)) (14,3) +-- PresentT ((-14) % 3) +-- +data Negate p + +instance ( Show (PP p x) + , Num (PP p x) + , P p x + ) => P (Negate p) x where + type PP (Negate p) x = PP p x + eval _ opts x = do + let msg0 = "Negate" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = negate p + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + + +-- | similar to 'abs' +-- +-- >>> pz @(Abs Id) (-14) +-- PresentT 14 +-- +-- >>> pz @(Abs (Snd Id)) ("xx",14) +-- PresentT 14 +-- +-- >>> pz @(Abs Id) 0 +-- PresentT 0 +-- +-- >>> pz @(Abs (Negate 44)) "aaa" +-- PresentT 44 +-- +data Abs p + +instance ( Show (PP p x) + , Num (PP p x) + , P p x + ) => P (Abs p) x where + type PP (Abs p) x = PP p x + eval _ opts x = do + let msg0 = "Abs" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = abs p + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + + + +-- | similar to 'signum' +-- +-- >>> pz @(Signum Id) (-14) +-- PresentT (-1) +-- +-- >>> pz @(Signum Id) 14 +-- PresentT 1 +-- +-- >>> pz @(Signum Id) 0 +-- PresentT 0 +-- +data Signum p + +instance ( Show (PP p x) + , Num (PP p x) + , P p x + ) => P (Signum p) x where + type PP (Signum p) x = PP p x + eval _ opts x = do + let msg0 = "Signum" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = signum p + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +-- | unwraps a value (see '_Wrapped'') +-- +-- >>> pz @(Unwrap Id) (SG.Sum (-13)) +-- PresentT (-13) +-- +data Unwrap p + +instance (PP p x ~ s + , P p x + , Show s + , Show (Unwrapped s) + , Wrapped s + ) => P (Unwrap p) x where + type PP (Unwrap p) x = Unwrapped (PP p x) + eval _ opts x = do + let msg0 = "Unwrap" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = p ^. _Wrapped' + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +-- | wraps a value (see '_Wrapped'' and '_Unwrapped'') +-- +-- >>> pz @(Wrap (SG.Sum _) Id) (-13) +-- PresentT (Sum {getSum = -13}) +-- +-- >>> pz @(Wrap SG.Any (Ge 4)) 13 +-- PresentT (Any {getAny = True}) +-- +-- >>> pz @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" +-- PresentT ('a' :| "bcd") +-- +data Wrap' t p + +instance (Show (PP p x) + , P p x + , Unwrapped (PP s x) ~ PP p x + , Wrapped (PP s x) + , Show (PP s x) + ) => P (Wrap' s p) x where + type PP (Wrap' s p) x = PP s x + eval _ opts x = do + let msg0 = "Wrap" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = p ^. _Unwrapped' + in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + +data Wrap (t :: Type) p +type WrapT (t :: Type) p = Wrap' (Hole t) p + +instance P (WrapT t p) x => P (Wrap t p) x where + type PP (Wrap t p) x = PP (WrapT t p) x + eval _ = eval (Proxy @(WrapT t p)) +-- | similar to 'coerce' +-- +-- >>> pz @(Coerce (SG.Sum Integer)) (Identity (-13)) +-- PresentT (Sum {getSum = -13}) +-- +data Coerce (t :: k) + +instance (Show a + , Show t + , Coercible t a + ) => P (Coerce t) a where + type PP (Coerce t) a = t + eval _ opts a = + let msg0 = "Coerce" + d = a ^. coerced + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d a) [] + +-- can coerce over a functor: but need to provide type of 'a' and 't' explicitly + +-- | see 'Coerce': coerce over a functor +-- +-- >>> pz @(Coerce2 (SG.Sum Integer)) [Identity (-13), Identity 4, Identity 99] +-- PresentT [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] +-- +-- >>> pz @(Coerce2 (SG.Sum Integer)) (Just (Identity (-13))) +-- PresentT (Just (Sum {getSum = -13})) +-- +-- >>> pz @(Coerce2 (SG.Sum Int)) (Nothing @(Identity Int)) +-- PresentT Nothing +-- +data Coerce2 (t :: k) +instance (Show (f a) + , Show (f t) + , Coercible t a + , Functor f + ) => P (Coerce2 t) (f a) where + type PP (Coerce2 t) (f a) = f t + eval _ opts fa = + let msg0 = "Coerce2" + d = view coerced <$> fa + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d fa) [] + +-- | lift mempty over a Functor +-- +-- >>> pz @(MEmpty2 (SG.Product Int)) [Identity (-13), Identity 4, Identity 99] +-- PresentT [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] +-- +data MEmpty2' t + +instance (Show (f a) + , Show (f (PP t (f a))) + , Functor f + , Monoid (PP t (f a)) + ) => P (MEmpty2' t) (f a) where + type PP (MEmpty2' t) (f a) = f (PP t (f a)) + eval _ opts fa = + let msg0 = "MEmpty2" + b = mempty <$> fa + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b fa) [] + +data MEmpty2 (t :: Type) +type MEmpty2T (t :: Type) = MEmpty2' (Hole t) + +instance P (MEmpty2T t) x => P (MEmpty2 t) x where + type PP (MEmpty2 t) x = PP (MEmpty2T t) x + eval _ = eval (Proxy @(MEmpty2T t)) + +-- | lift pure over a Functor +-- +-- >>> pz @(Pure2 (Either String)) [1,2,4] +-- PresentT [Right 1,Right 2,Right 4] +-- +data Pure2 (t :: Type -> Type) + +instance (Show (f (t a)) + , Show (f a) + , Applicative t + , Functor f + ) => P (Pure2 t) (f a) where + type PP (Pure2 t) (f a) = f (t a) + eval _ opts fa = + let msg0 = "Pure2" + b = fmap pure fa + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b fa) [] + +-- | similar to 'reverse' +-- +-- >>> pz @Reverse [1,2,4] +-- PresentT [4,2,1] +-- +-- >>> pz @Reverse "AbcDeF" +-- PresentT "FeDcbA" +-- +data Reverse + +instance ( Show a + , as ~ [a] + ) => P Reverse as where + type PP Reverse as = as + eval _ opts as = + let msg0 = "Reverse" + d = reverse as + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d as) [] + +-- | reverses using 'reversing' +-- +-- >>> pz @ReverseL (T.pack "AbcDeF") +-- PresentT "FeDcbA" +-- +-- >>> pz @ReverseL ("AbcDeF" :: String) +-- PresentT "FeDcbA" +-- +data ReverseL + +instance ( Show t + , Reversing t + ) => P ReverseL t where + type PP ReverseL t = t + eval _ opts as = + let msg0 = "ReverseL" + d = as ^. reversed + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d as) [] + +-- | swaps using 'SwapC' +-- +-- >>> pz @Swap (Left 123) +-- PresentT (Right 123) +-- +-- >>> pz @Swap (Right 123) +-- PresentT (Left 123) +-- +-- >>> pz @Swap (These 'x' 123) +-- PresentT (These 123 'x') +-- +-- >>> pz @Swap (This 'x') +-- PresentT (That 'x') +-- +-- >>> pz @Swap (That 123) +-- PresentT (This 123) +-- +-- >>> pz @Swap (123,'x') +-- PresentT ('x',123) +-- +-- >>> pz @Swap (Left "abc") +-- PresentT (Right "abc") +-- +-- >>> pz @Swap (Right 123) +-- PresentT (Left 123) +-- +data Swap + +class Bifunctor p => SwapC p where -- (p :: Type -> Type -> Type) where + swapC :: p a b -> p b a +instance SwapC Either where + swapC (Left a) = Right a + swapC (Right a) = Left a +instance SwapC These where + swapC (This a) = That a + swapC (That b) = This b + swapC (These a b) = These b a +instance SwapC (,) where + swapC (a,b) = (b,a) + +instance (Show (p a b) + , SwapC p + , Show (p b a) + ) => P Swap (p a b) where + type PP Swap (p a b) = p b a + eval _ opts pabx = + let msg0 = "Swap" + d = swapC pabx + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabx) [] + +-- | assoc using 'AssocC' +-- +-- >>> pz @Assoc (This (These 123 'x')) +-- PresentT (These 123 (This 'x')) +-- +-- >>> pz @Assoc ((99,'a'),True) +-- PresentT (99,('a',True)) +-- +-- >>> pz @Assoc ((99,'a'),True) +-- PresentT (99,('a',True)) +-- +-- >>> pz @Assoc (Right "Abc" :: Either (Either () ()) String) +-- PresentT (Right (Right "Abc")) +-- +-- >>> pz @Assoc (Left (Left 'x')) +-- PresentT (Left 'x') +-- +data Assoc + +class AssocC p where + assoc :: p (p a b) c -> p a (p b c) + unassoc :: p a (p b c) -> p (p a b) c +instance AssocC Either where + assoc (Left (Left a)) = Left a + assoc (Left (Right b)) = Right (Left b) + assoc (Right b) = Right (Right b) + unassoc (Left a) = Left (Left a) + unassoc (Right (Left b)) = Left (Right b) + unassoc (Right (Right b)) = Right b +instance AssocC These where + assoc (This (This a)) = This a + assoc (This (That b)) = That (This b) + assoc (That b) = That (That b) + assoc (These (This a) c) = These a (That c) + assoc (These (That b) c) = That (These b c) + assoc (These (These a b) c) = These a (These b c) + assoc (This (These a b)) = These a (This b) + unassoc (This a) = This (This a) + unassoc (That (This b)) = This (That b) + unassoc (That (That b)) = That b + unassoc (These a (That c)) = These (This a) c + unassoc (That (These b c)) = These (That b) c + unassoc (These a (These b c)) = These (These a b) c + unassoc (These a (This b)) = This (These a b) + +-- copied from Data.These +partitionThese :: [These a b] -> ([a], [b], [(a, b)]) +partitionThese [] = ([], [], []) +partitionThese (t:ts) = case t of + This x -> (x : xs, ys, xys) + That y -> ( xs, y : ys, xys) + These x y -> ( xs, ys, (x,y) : xys) + where + ~(xs,ys,xys) = partitionThese ts + +instance AssocC (,) where + assoc ((a,b),c) = (a,(b,c)) + unassoc (a,(b,c)) = ((a,b),c) + +instance (Show (p (p a b) c) + , Show (p a (p b c)) + , AssocC p + ) => P Assoc (p (p a b) c) where + type PP Assoc (p (p a b) c) = p a (p b c) + eval _ opts pabc = + let msg0 = "Assoc" + d = assoc pabc + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabc) [] + +-- | unassoc using 'AssocC' +-- +-- >>> pz @Unassoc (These 123 (This 'x')) +-- PresentT (This (These 123 'x')) +-- +-- >>> pz @Unassoc (99,('a',True)) +-- PresentT ((99,'a'),True) +-- +-- >>> pz @Unassoc (This 10 :: These Int (These Bool ())) +-- PresentT (This (This 10)) +-- +-- >>> pz @Unassoc (Right (Right 123)) +-- PresentT (Right 123) +-- +-- >>> pz @Unassoc (Left 'x' :: Either Char (Either Bool Double)) +-- PresentT (Left (Left 'x')) +-- +data Unassoc + +instance (Show (p (p a b) c) + , Show (p a (p b c)) + , AssocC p + ) => P Unassoc (p a (p b c)) where + type PP Unassoc (p a (p b c)) = p (p a b) c + eval _ opts pabc = + let msg0 = "Unassoc" + d = unassoc pabc + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d pabc) [] + +-- | bounded 'succ' function +-- +-- >>> pz @(SuccB' Id) (13 :: Int) +-- PresentT 14 +-- +-- >>> pz @(SuccB' Id) LT +-- PresentT EQ +-- +-- >>> pz @(SuccB 'LT Id) GT +-- PresentT LT +-- +-- >>> pz @(SuccB' Id) GT +-- FailT "Succ bounded" +-- +instance (PP q x ~ a + , P q x + , P p (Proxy a) + , PP p (Proxy a) ~ a + , Show a + , Eq a + , Bounded a + , Enum a + ) => P (SuccB p q) x where + type PP (SuccB p q) x = PP q x + eval _ opts x = do + let msg0 = "SuccB" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case succMay q of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @p) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh qq, hh pp] + Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n q) [hh qq] + +data SuccB p q + +data SuccB' q +type SuccBT' q = SuccB (Failp "Succ bounded") q + +instance P (SuccBT' q) x => P (SuccB' q) x where + type PP (SuccB' q) x = PP (SuccBT' q) x + eval _ = eval (Proxy @(SuccBT' q)) + +-- | bounded 'pred' function +-- +-- >>> pz @(PredB' Id) (13 :: Int) +-- PresentT 12 +-- +-- >>> pz @(PredB' Id) LT +-- FailT "Pred bounded" +-- +data PredB' q +type PredBT' q = PredB (Failp "Pred bounded") q + +instance (PP q x ~ a + , P q x + , P p (Proxy a) + , PP p (Proxy a) ~ a + , Show a + , Eq a + , Bounded a + , Enum a + ) => P (PredB p q) x where + type PP (PredB p q) x = PP q x + eval _ opts x = do + let msg0 = "PredB" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case predMay q of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @p) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh qq, hh pp] + Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n q) [hh qq] + + +-- | unbounded 'succ' function +-- +-- >>> pz @(Succ Id) 13 +-- PresentT 14 +-- +-- >>> pz @(Succ Id) LT +-- PresentT EQ +-- +-- >>> pz @(Succ Id) GT +-- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" +-- +data Succ p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (Succ p) x where + type PP (Succ p) x = PP p x + eval _ opts x = do + let msg0 = "Succ" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (succ p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (" " <> showL opts p) [hh pp] + Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] + + +-- | unbounded 'pred' function +-- +-- >>> pz @(Pred Id) 13 +-- PresentT 12 +-- +-- >>> pz @(Pred Id) LT +-- FailT "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" +-- +data Pred p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (Pred p) x where + type PP (Pred p) x = PP p x + eval _ opts x = do + let msg0 = "Pred" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (pred p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (" " <> showL opts p) [hh pp] + Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] + +data PredB p q + +instance P (PredBT' q) x => P (PredB' q) x where + type PP (PredB' q) x = PP (PredBT' q) x + eval _ = eval (Proxy @(PredBT' q)) + + +-- | 'fromEnum' function +-- +-- >>> pz @(FromEnum Id) 'x' +-- PresentT 120 +-- +data FromEnum p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (FromEnum p) x where + type PP (FromEnum p) x = Int + eval _ opts x = do + let msg0 = "FromEnum" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let n = fromEnum p + in mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] + +-- | unsafe 'toEnum' function +-- +-- >>> pz @(ToEnum Char Id) 120 +-- PresentT 'x' +data ToEnum' t p + +instance (PP p x ~ a + , P p x + , Show a + , Enum (PP t x) + , Show (PP t x) + , Integral a + ) => P (ToEnum' t p) x where + type PP (ToEnum' t p) x = PP t x + eval _ opts x = do + let msg0 = "ToEnum" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (" " <> showL opts p) [hh pp] + Right n -> mkNode opts (PresentT n) (show01 opts msg0 n p) [hh pp] + +data ToEnum (t :: Type) p +type ToEnumT (t :: Type) p = ToEnum' (Hole t) p + +instance P (ToEnumT t p) x => P (ToEnum t p) x where + type PP (ToEnum t p) x = PP (ToEnumT t p) x + eval _ = eval (Proxy @(ToEnumT t p)) +-- | bounded 'toEnum' function +-- +-- >>> pz @(ToEnumBDef Ordering LT) 2 +-- PresentT GT +-- +-- >>> pz @(ToEnumBDef Ordering LT) 6 +-- PresentT LT +-- +-- >>> pz @(ToEnumBFail Ordering) 6 +-- FailT "ToEnum bounded" +-- +data ToEnumBDef' t def + +instance (P def (Proxy (PP t a)) + , PP def (Proxy (PP t a)) ~ PP t a + , Show a + , Show (PP t a) + , Bounded (PP t a) + , Enum (PP t a) + , Integral a + ) => P (ToEnumBDef' t def) a where + type PP (ToEnumBDef' t def) a = PP t a + eval _ opts a = do + let msg0 = "ToEnumBDef" + case toEnumMay $ fromIntegral a of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @def) opts (Proxy @(PP t a)) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh pp] + Just n -> pure $ mkNode opts (PresentT n) (show01 opts msg0 n a) [] + +data ToEnumBDef (t :: Type) def +type ToEnumBDefT (t :: Type) def = ToEnumBDef' (Hole t) def + +instance P (ToEnumBDefT t def) x => P (ToEnumBDef t def) x where + type PP (ToEnumBDef t def) x = PP (ToEnumBDefT t def) x + eval _ = eval (Proxy @(ToEnumBDefT t def)) + +data ToEnumBFail (t :: Type) +type ToEnumBFailT (t :: Type) = ToEnumBDef' (Hole t) (Failp "ToEnum bounded") + +instance P (ToEnumBFailT t) x => P (ToEnumBFail t) x where + type PP (ToEnumBFail t) x = PP (ToEnumBFailT t) x + eval _ = eval (Proxy @(ToEnumBFailT t)) + +-- | a predicate on prime numbers +-- +-- >>> pz @(Prime Id) 2 +-- TrueT +-- +-- >>> pz @(Map '(Id,Prime Id) Id) [0..12] +-- PresentT [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] +-- +data Prime p + +instance (PP p x ~ a + , P p x + , Show a + , Integral a + ) => P (Prime p) x where + type PP (Prime p) x = Bool + eval _ opts x = do + let msg0 = "Prime" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = p > 1 && isPrime (fromIntegral p) + in mkNodeB opts b (msg0 <> showVerbose opts " | " p) [hh pp] + +-- | get the next prime number +-- +-- >>> pz @(PrimeNext Id) 6 +-- PresentT 7 +-- +-- >>> pz @(IterateN 4 (PrimeNext Id)) 3 +-- PresentT [3,5,7,11] +-- +data PrimeNext p + +instance (PP p x ~ a + , P p x + , Show a + , Integral a + ) => P (PrimeNext p) x where + type PP (PrimeNext p) x = Int + eval _ opts x = do + let msg0 = "PrimeNext" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let ret = head $ dropWhile (not . isPrime) [max 0 (fromIntegral p + 1) ..] + in mkNode opts (PresentT ret) (msg0 <> showVerbose opts " | " p) [hh pp] + +-- empty lists at the type level wont work here + +-- | filters a list \'q\' keeping or removing those elements in \'p\' +-- +-- >>> pz @(Keep '[5] '[1,5,5,2,5,2]) () +-- PresentT [5,5,5] +-- +-- >>> pz @(Keep '[0,1,1,5] '[1,5,5,2,5,2]) () +-- PresentT [1,5,5,5] +-- +-- >>> pz @(Remove '[5] '[1,5,5,2,5,2]) () +-- PresentT [1,2,2] +-- +-- >>> pz @(Remove '[0,1,1,5] '[1,5,5,2,5,2]) () +-- PresentT [2,2] +-- +-- >>> pz @(Remove '[99] '[1,5,5,2,5,2]) () +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pz @(Remove '[99,91] '[1,5,5,2,5,2]) () +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pz @(Remove Id '[1,5,5,2,5,2]) [] +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pz @(Remove '[] '[1,5,5,2,5,2]) 44 -- works if you make this a number! +-- PresentT [1,5,5,2,5,2] +-- +data KeepImpl (keep :: Bool) p q + +instance (GetBool keep + , Eq a + , Show a + , P p x + , P q x + , PP p x ~ PP q x + , PP q x ~ [a] + ) => P (KeepImpl keep p q) x where + type PP (KeepImpl keep p q) x = PP q x + eval _ opts x = do + let msg0 = if keep then "Keep" else "Remove" + keep = getBool @keep + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let ret = filter (bool not id keep . (`elem` p)) q + in mkNode opts (PresentT ret) (show01' opts msg0 ret "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +data Keep p q +type KeepT p q = KeepImpl 'True p q + +instance P (KeepT p q) x => P (Keep p q) x where + type PP (Keep p q) x = PP (KeepT p q) x + eval _ = eval (Proxy @(KeepT p q)) + +data Remove p q +type RemoveT p q = KeepImpl 'False p q + +instance P (RemoveT p q) x => P (Remove p q) x where + type PP (Remove p q) x = PP (RemoveT p q) x + eval _ = eval (Proxy @(RemoveT p q)) + +-- | 'elem' function +-- +-- >>> pz @(Elem (Fst Id) (Snd Id)) ('x',"abcdxy") +-- TrueT +-- +-- >>> pz @(Elem (Fst Id) (Snd Id)) ('z',"abcdxy") +-- FalseT +-- +data Elem p q + +instance ([PP p a] ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Eq (PP p a) + ) => P (Elem p q) a where + type PP (Elem p q) a = Bool + eval _ opts a = do + let msg0 = "Elem" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `elem` q + in mkNodeB opts b (showL opts p <> " `elem` " <> showL opts q) [hh pp, hh qq] + +--type Head' p = HeadFail "Head(empty)" p +--type Tail' p = TailFail "Tail(empty)" p +--type Last p = LastFail "Last(empty)" p +--type Init' p = InitFail "Init(empty)" p + +-- | similar to fmap fst +-- +-- >>> pz @FMapFst (Just (13,"Asf")) +-- PresentT (Just 13) +-- +-- to make this work we grab the fst or snd out of the Maybe so it is a head or not/ is a tail or not etc! +-- we still have access to the whole original list so we dont lose anything! +data FMapFst + +instance Functor f => P FMapFst (f (a,x)) where + type PP FMapFst (f (a,x)) = f a + eval _ opts mb = pure $ mkNode opts (PresentT (fst <$> mb)) "FMapFst" [] + +-- | similar to fmap snd +-- +-- >>> pz @FMapSnd (Just ("asf",13)) +-- PresentT (Just 13) +-- +data FMapSnd + +instance Functor f => P FMapSnd (f (x,a)) where + type PP FMapSnd (f (x,a)) = f a + eval _ opts mb = pure $ mkNode opts (PresentT (snd <$> mb)) "FMapSnd" [] + +-- | takes the head or default of a list-like object +-- +-- see 'ConsT' for other supported types eg 'Seq.Seq' +-- +-- >>> pz @(HeadDef 444 Id) [] +-- PresentT 444 +-- +-- >>> pz @(HeadDef 444 Id) [1..5] +-- PresentT 1 +-- +-- >>> pz @(HeadDef 444 Id) [1..5] +-- PresentT 1 +-- +-- >>> pz @(HeadDef (Char1 "w") Id) (Seq.fromList "abcdef") +-- PresentT 'a' +-- +-- >>> pz @(HeadDef (Char1 "w") Id) Seq.empty +-- PresentT 'w' +-- +-- >>> :set -XFlexibleContexts +-- >>> pz @(HeadDef (MEmptyT _) Id) ([] :: [SG.Sum Int]) +-- PresentT (Sum {getSum = 0}) +-- +-- >>> pz @(HeadDef (MEmptyT String) '[ "abc","def","asdfadf" ]) () +-- PresentT "abc" +-- +-- >>> pz @(HeadDef (MEmptyT _) (Snd Id)) (123,[ "abc","def","asdfadf" ]) +-- PresentT "abc" +-- +-- >>> pz @(HeadDef (MEmptyT _) (Snd Id)) (123,[]) +-- PresentT () +-- +data HeadDef p q +type HeadDefT p q = JustDef p (q >> Uncons >> FMapFst) + +instance P (HeadDefT p q) x => P (HeadDef p q) x where + type PP (HeadDef p q) x = PP (HeadDefT p q) x + eval _ = eval (Proxy @(HeadDefT p q)) + + +-- | takes the head of a list or fail +-- +-- see 'ConsT' for other supported types eg 'Seq.Seq' +-- +-- >>> pz @(HeadFail "dude" Id) [ "abc","def","asdfadf" ] +-- PresentT "abc" +-- +-- >>> pz @(HeadFail "empty list" Id) [] +-- FailT "empty list" +-- +data HeadFail msg q +type HeadFailT msg q = JustFail msg (q >> Uncons >> FMapFst) + +instance P (HeadFailT msg q) x => P (HeadFail msg q) x where + type PP (HeadFail msg q) x = PP (HeadFailT msg q) x + eval _ = eval (Proxy @(HeadFailT msg q)) + +data TailDef p q +type TailDefT p q = JustDef p (q >> Uncons >> FMapSnd) + +instance P (TailDefT p q) x => P (TailDef p q) x where + type PP (TailDef p q) x = PP (TailDefT p q) x + eval _ = eval (Proxy @(TailDefT p q)) + + +data TailFail msg q +type TailFailT msg q = JustFail msg (q >> Uncons >> FMapSnd) + +instance P (TailFailT msg q) x => P (TailFail msg q) x where + type PP (TailFail msg q) x = PP (TailFailT msg q) x + eval _ = eval (Proxy @(TailFailT msg q)) + + +data LastDef p q +type LastDefT p q = JustDef p (q >> Unsnoc >> FMapSnd) + +instance P (LastDefT p q) x => P (LastDef p q) x where + type PP (LastDef p q) x = PP (LastDefT p q) x + eval _ = eval (Proxy @(LastDefT p q)) + +data LastFail msg q +type LastFailT msg q = JustFail msg (q >> Unsnoc >> FMapSnd) + +instance P (LastFailT msg q) x => P (LastFail msg q) x where + type PP (LastFail msg q) x = PP (LastFailT msg q) x + eval _ = eval (Proxy @(LastFailT msg q)) + +data InitDef p q +type InitDefT p q = JustDef p (q >> Unsnoc >> FMapFst) + +instance P (InitDefT p q) x => P (InitDef p q) x where + type PP (InitDef p q) x = PP (InitDefT p q) x + eval _ = eval (Proxy @(InitDefT p q)) + +data InitFail msg q +type InitFailT msg q = JustFail msg (q >> Unsnoc >> FMapFst) + +instance P (InitFailT msg q) x => P (InitFail msg q) x where + type PP (InitFail msg q) x = PP (InitFailT msg q) x + eval _ = eval (Proxy @(InitFailT msg q)) + +data LookupDef' v w p q +type LookupDefT' v w p q = JustDef p (q >> Lookup v w) + +instance P (LookupDefT' v w p q) x => P (LookupDef' v w p q) x where + type PP (LookupDef' v w p q) x = PP (LookupDefT' v w p q) x + eval _ = eval (Proxy @(LookupDefT' v w p q)) + +data LookupFail' msg v w q +type LookupFailT' msg v w q = JustFail msg (q >> Lookup v w) + +instance P (LookupFailT' msg v w q) x => P (LookupFail' msg v w q) x where + type PP (LookupFail' msg v w q) x = PP (LookupFailT' msg v w q) x + eval _ = eval (Proxy @(LookupFailT' msg v w q)) + +data LookupDef v w p +type LookupDefT v w p = LookupDef' v w p I + +instance P (LookupDefT v w p) x => P (LookupDef v w p) x where + type PP (LookupDef v w p) x = PP (LookupDefT v w p) x + eval _ = eval (Proxy @(LookupDefT v w p)) + +data LookupFail msg v w +type LookupFailT msg v w = LookupFail' msg v w I + +instance P (LookupFailT msg v w) x => P (LookupFail msg v w) x where + type PP (LookupFail msg v w) x = PP (LookupFailT msg v w) x + eval _ = eval (Proxy @(LookupFailT msg v w)) + +--type Just' p = JustFail "expected Just" p +data Left' p +type LeftT' p = LeftFail "expected Left" p + +instance P (LeftT' p) x => P (Left' p) x where + type PP (Left' p) x = PP (LeftT' p) x + eval _ = eval (Proxy @(LeftT' p)) + +data Right' p +type RightT' p = RightFail "expected Right" p + +instance P (RightT' p) x => P (Right' p) x where + type PP (Right' p) x = PP (RightT' p) x + eval _ = eval (Proxy @(RightT' p)) + +data This' p +type ThisT' p = ThisFail "expected This" p + +instance P (ThisT' p) x => P (This' p) x where + type PP (This' p) x = PP (ThisT' p) x + eval _ = eval (Proxy @(ThisT' p)) + +data That' p +type ThatT' p = ThatFail "expected That" p + +instance P (ThatT' p) x => P (That' p) x where + type PP (That' p) x = PP (ThatT' p) x + eval _ = eval (Proxy @(ThatT' p)) + +data These' p +type TheseT' p = TheseFail "expected These" p + +instance P (TheseT' p) x => P (These' p) x where + type PP (These' p) x = PP (TheseT' p) x + eval _ = eval (Proxy @(TheseT' p)) + + +-- | similar to 'Control.Arrow.|||' but additionally gives \'p\' and \'q\' the original input +-- +-- >>> pz @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Left 123) +-- PresentT "132" +-- +-- >>> pz @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Right 'x') +-- PresentT "((9,Right 'x'),'x')" +-- +-- >>> pz @(EitherX (ShowP Id) (ShowP (Second (Succ Id))) (Snd Id)) (9,Right 'x') +-- PresentT "((9,Right 'x'),'y')" +-- +data EitherX p q r +instance (P r x + , P p (x,a) + , P q (x,b) + , PP r x ~ Either a b + , PP p (x,a) ~ c + , PP q (x,b) ~ c + ) => P (EitherX p q r) x where + type PP (EitherX p q r) x = EitherXT (PP r x) x p + eval _ opts x = do + let msg0 = "EitherX" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right (Left a) -> do + let msg1 = msg0 <> "(Left)" + pp <- eval (Proxy @p) opts (x,a) + pure $ case getValueLR opts msg1 pp [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh rr, hh pp] + Right (Right b) -> do + let msg1 = msg0 <> "(Right)" + qq <- eval (Proxy @q) opts (x,b) + pure $ case getValueLR opts msg1 qq [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool qq) msg1 [hh rr, hh qq] + +type family EitherXT lr x p where + EitherXT (Either a b) x p = PP p (x,a) + EitherXT o _ _ = GL.TypeError ( + 'GL.Text "EitherXT: expected 'Either a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +-- | similar to 'Data.These.mergeTheseWith' but additionally provides \'p\', '\q'\ and \'r\' the original input as the first element in the tuple +-- +-- >>> pz @(TheseX ((Fst (Fst Id) + Snd Id) >> ShowP Id) (ShowP Id) (Snd (Snd Id)) (Snd Id)) (9,This 123) +-- PresentT "132" +-- +-- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (This 123) +-- PresentT (123,"fromthis") +-- +-- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (That "fromthat") +-- PresentT (-99,"fromthat") +-- +-- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (These 123 "fromthese") +-- PresentT (123,"fromthese") +-- +data TheseX p q r s + +instance (P s x + , P p (x,a) + , P q (x,b) + , P r (x,(a,b)) + , PP s x ~ These a b + , PP p (x,a) ~ c + , PP q (x,b) ~ c + , PP r (x,(a,b)) ~ c + ) => P (TheseX p q r s) x where + type PP (TheseX p q r s) x = TheseXT (PP s x) x p + eval _ opts x = do + let msg0 = "TheseX" + ss <- eval (Proxy @s) opts x + case getValueLR opts msg0 ss [] of + Left e -> pure e + Right (This a) -> do + let msg1 = msg0 <> "(This)" + pp <- eval (Proxy @p) opts (x,a) + pure $ case getValueLR opts msg1 pp [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh ss, hh pp] + Right (That b) -> do + let msg1 = msg0 <> "(That)" + qq <- eval (Proxy @q) opts (x,b) + pure $ case getValueLR opts msg1 qq [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool qq) msg1 [hh ss, hh qq] + Right (These a b) -> do + let msg1 = msg0 <> "(These)" + rr <- eval (Proxy @r) opts (x,(a,b)) + pure $ case getValueLR opts msg1 rr [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool rr) msg1 [hh ss, hh rr] + +type family TheseXT lr x p where + TheseXT (These a b) x p = PP p (x,a) + +-- | similar to 'maybe' +-- +-- provides a Proxy to the result of \'q\' but does not provide the surrounding context +-- +-- >>> pz @(MaybeIn "foundnothing" (ShowP (Pred Id))) (Just 20) +-- PresentT "19" +-- +-- >>> pz @(MaybeIn "found nothing" (ShowP (Pred Id))) Nothing +-- PresentT "found nothing" +-- +data MaybeIn p q + +-- tricky: the nothing case is the proxy of PP q a: ie proxy of the final result +instance (P q a + , Show a + , Show (PP q a) + , PP p (Proxy (PP q a)) ~ PP q a + , P p (Proxy (PP q a)) + ) => P (MaybeIn p q) (Maybe a) where + type PP (MaybeIn p q) (Maybe a) = PP q a + eval _ opts ma = do + let msg0 = "MaybeIn" + case ma of + Nothing -> do + let msg1 = msg0 <> "(Nothing)" + pp <- eval (Proxy @p) opts (Proxy @(PP q a)) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) (msg1 <> " " <> showL opts b <> " | Proxy") [hh pp] + Just a -> do + let msg1 = msg0 <> "(Just)" + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg1 qq [] of + Left e -> e + Right b -> mkNode opts (_tBool qq) (show01 opts msg1 b a) [hh qq] + +-- | similar to 'isJust' +-- +-- >>> pz @(IsJust Id) Nothing +-- FalseT +-- +-- >>> pz @(IsJust Id) (Just 'a') +-- TrueT +-- +data IsJust p + +instance ( P p x + , PP p x ~ Maybe a + ) => P (IsJust p) x where + type PP (IsJust p) x = Bool + eval _ opts x = do + let msg0 = "IsJust" + pp <- eval (Proxy @p) opts x + let hhs = [hh pp] + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (Just _) -> mkNodeB opts True msg0 hhs + Right Nothing -> mkNodeB opts False msg0 hhs + +-- | similar to 'isNothing' +-- +-- >>> pz @(IsNothing Id) (Just 123) +-- FalseT +-- +-- >>> pz @(IsNothing Id) Nothing +-- TrueT +-- +data IsNothing p + +instance ( P p x + , PP p x ~ Maybe a + ) => P (IsNothing p) x where + type PP (IsNothing p) x = Bool + eval _ opts x = do + let msg0 = "IsNothing" + pp <- eval (Proxy @p) opts x + let hhs = [hh pp] + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (Just _) -> mkNodeB opts False msg0 hhs + Right Nothing -> mkNodeB opts True msg0 hhs + +data MapMaybe p q +type MapMaybeT p q = ConcatMap (p >> MaybeIn MEmptyP '[Id]) q + +instance P (MapMaybeT p q) x => P (MapMaybe p q) x where + type PP (MapMaybe p q) x = PP (MapMaybeT p q) x + eval _ = eval (Proxy @(MapMaybeT p q)) + +-- | similar to 'Data.Either.catMaybes' +-- +-- >>> pl @(CatMaybes Id) [Just 'a',Nothing,Just 'c',Just 'd',Nothing] +-- Present "acd" (Concat "acd" | ["a","","c","d",""]) +-- PresentT "acd" +-- +data CatMaybes q +type CatMaybesT q = MapMaybe Id q + +instance P (CatMaybesT q) x => P (CatMaybes q) x where + type PP (CatMaybes q) x = PP (CatMaybesT q) x + eval _ = eval (Proxy @(CatMaybesT q)) + +-- | similar to 'SG.stimes' +-- +-- >>> pz @(STimes 4 Id) (SG.Sum 3) +-- PresentT (Sum {getSum = 12}) +-- +-- >>> pz @(STimes 4 Id) "ab" +-- PresentT "abababab" +-- +data STimes n p +instance (P n a + , Integral (PP n a) + , Semigroup (PP p a) + , P p a + , Show (PP p a) + ) => P (STimes n p) a where + type PP (STimes n p) a = PP p a + eval _ opts a = do + let msg0 = "STimes" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> (n::Int),p,pp,qq) -> + let msg1 = msg0 <> " " <> showL opts n <> " p=" <> show p + b = SG.stimes n p + in mkNode opts (PresentT b) (show01' opts msg1 b "n=" n <> showVerbose opts " | " p) [hh pp, hh qq] + + +-- | similar to 'pure' +-- +-- >>> pz @(Pure Maybe Id) 4 +-- PresentT (Just 4) +-- +-- >>> pz @(Pure [] Id) 4 +-- PresentT [4] +-- +-- >>> pz @(Pure (Either String) (Fst Id)) (13,True) +-- PresentT (Right 13) +-- +data Pure (t :: Type -> Type) p +instance (P p x + , Show (PP p x) + , Show (t (PP p x)) + , Applicative t + ) => P (Pure t p) x where + type PP (Pure t p) x = t (PP p x) + eval _ opts x = do + let msg0 = "Pure" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a -> + let b = pure a + in mkNode opts (PresentT b) (show01 opts msg0 b a) [hh pp] + +-- type PMEmpty = MEmptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MEmptyP + +-- | similar to 'mempty' +-- +-- >>> pz @(MEmptyT (SG.Sum Int)) () +-- PresentT (Sum {getSum = 0}) +-- +-- no Monoid for Maybe a unless a is also a monoid but can use empty! +data MEmptyT' t +instance ( Show (PP t a) + , Monoid (PP t a) + ) => P (MEmptyT' t) a where + type PP (MEmptyT' t) a = PP t a + eval _ opts _ = + let msg0 = "MEmptyT" + b = mempty @(PP t a) + in pure $ mkNode opts (PresentT b) (msg0 <> " " <> showL opts b) [] + +data MEmptyT (t :: Type) +type MEmptyTT (t :: Type) = MEmptyT' (Hole t) + +instance P (MEmptyTT t) x => P (MEmptyT t) x where + type PP (MEmptyT t) x = PP (MEmptyTT t) x + eval _ = eval (Proxy @(MEmptyTT t)) + +data MEmptyP +type MEmptyPT = MEmptyT' Unproxy -- expects a proxy: so only some things work with this: eg MaybeIn + +instance P MEmptyPT x => P MEmptyP x where + type PP MEmptyP x = PP MEmptyPT x + eval _ = eval (Proxy @MEmptyPT) + +-- | similar to 'empty' +-- +-- >>> pz @(EmptyT Maybe Id) () +-- PresentT Nothing +-- +-- >>> pz @(EmptyT [] Id) () +-- PresentT [] +-- +-- >>> pz @(EmptyT [] (Char1 "x")) (13,True) +-- PresentT "" +-- +-- >>> pz @(EmptyT (Either String) (Fst Id)) (13,True) +-- PresentT (Left "") +-- +data EmptyT (t :: Type -> Type) p + +instance (P p x + , PP p x ~ a + , Show (t a) + , Show a + , Alternative t + ) => P (EmptyT t p) x where + type PP (EmptyT t p) x = t (PP p x) + eval _ opts x = do + let msg0 = "EmptyT" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = empty @t + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data MkNothing' t -- works always! MaybeBool is a good alternative and then dont need the extra 't' + +-- for this to be useful has to have 't' else we end up with tons of problems +instance P (MkNothing' t) a where + type PP (MkNothing' t) a = Maybe (PP t a) + eval _ opts _ = + let msg0 = "MkNothing" + in pure $ mkNode opts (PresentT Nothing) msg0 [] + +data MkNothing (t :: Type) +type MkNothingT (t :: Type) = MkNothing' (Hole t) + +instance P (MkNothing t) x where + type PP (MkNothing t) x = PP (MkNothingT t) x + eval _ = eval (Proxy @(MkNothingT t)) + +-- | 'GHC.Maybe.Just' constructor +-- +-- >>> pz @(MkJust Id) 44 +-- PresentT (Just 44) +-- +data MkJust p +instance ( PP p x ~ a + , P p x + , Show a + ) => P (MkJust p) x where + type PP (MkJust p) x = Maybe (PP p x) + eval _ opts x = do + let msg0 = "MkJust" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Just p + in mkNode opts (PresentT d) (msg0 <> " Just " <> showL opts p) [hh pp] + +-- | 'Data.Either.Left' constructor +-- +-- >>> pz @(MkLeft _ Id) 44 +-- PresentT (Left 44) +-- +data MkLeft' t p + +instance ( Show (PP p x) + , P p x + ) => P (MkLeft' t p) x where + type PP (MkLeft' t p) x = Either (PP p x) (PP t x) + eval _ opts x = do + let msg0 = "MkLeft" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Left p + in mkNode opts (PresentT d) (msg0 <> " Left " <> showL opts p) [hh pp] + +data MkLeft (t :: Type) p +type MkLeftT (t :: Type) p = MkLeft' (Hole t) p + +instance P (MkLeftT t p) x => P (MkLeft t p) x where + type PP (MkLeft t p) x = PP (MkLeftT t p) x + eval _ = eval (Proxy @(MkLeftT t p)) + +-- | 'Data.Either.Right' constructor +-- +-- >>> pz @(MkRight _ Id) 44 +-- PresentT (Right 44) +-- +data MkRight' t p + +instance ( Show (PP p x) + , P p x + ) => P (MkRight' t p) x where + type PP (MkRight' t p) x = Either (PP t x) (PP p x) + eval _ opts x = do + let msg0 = "MkRight" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Right p + in mkNode opts (PresentT d) (msg0 <> " Right " <> showL opts p) [hh pp] + +data MkRight (t :: Type) p +type MkRightT (t :: Type) p = MkRight' (Hole t) p + +instance P (MkRightT t p) x => P (MkRight t p) x where + type PP (MkRight t p) x = PP (MkRightT t p) x + eval _ = eval (Proxy @(MkRightT t p)) + +-- | 'Data.These.This' constructor +-- +-- >>> pz @(MkThis _ Id) 44 +-- PresentT (This 44) +-- +-- >>> pz @(Proxy Int >> MkThis' Unproxy 10) [] +-- PresentT (This 10) +-- +data MkThis' t p + +instance ( Show (PP p x) + , P p x + ) => P (MkThis' t p) x where + type PP (MkThis' t p) x = These (PP p x) (PP t x) + eval _ opts x = do + let msg0 = "MkThis" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = This p + in mkNode opts (PresentT d) (msg0 <> " This " <> showL opts p) [hh pp] + +data MkThis (t :: Type) p +type MkThisT (t :: Type) p = MkThis' (Hole t) p + +instance P (MkThisT t p) x => P (MkThis t p) x where + type PP (MkThis t p) x = PP (MkThisT t p) x + eval _ = eval (Proxy @(MkThisT t p)) + +-- | 'Data.These.That' constructor +-- +-- >>> pz @(MkThat _ Id) 44 +-- PresentT (That 44) +-- +data MkThat' t p + +instance ( Show (PP p x) + , P p x + ) => P (MkThat' t p) x where + type PP (MkThat' t p) x = These (PP t x) (PP p x) + eval _ opts x = do + let msg0 = "MkThat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = That p + in mkNode opts (PresentT d) (msg0 <> " That " <> showL opts p) [hh pp] + +data MkThat (t :: Type) p +type MkThatT (t :: Type) p = MkThat' (Hole t) p + +instance P (MkThatT t p) x => P (MkThat t p) x where + type PP (MkThat t p) x = PP (MkThatT t p) x + eval _ = eval (Proxy @(MkThatT t p)) + +-- type MkThat t p = MkThis t p >> Swap +-- type MkThat' (t :: Type) = Pure (These t) Id -- t has to be a semigroup + +-- | 'Data.These.These' constructor +-- +-- >>> pz @(MkThese (Fst Id) (Snd Id)) (44,'x') +-- PresentT (These 44 'x') +-- +data MkThese p q +instance (P p a + , P q a + , Show (PP p a) + , Show (PP q a) + ) => P (MkThese p q) a where + type PP (MkThese p q) a = These (PP p a) (PP q a) + eval _ opts a = do + let msg0 = "MkThese" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = These p q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts d) [hh pp, hh qq] + +-- | similar to 'mconcat' +-- +-- >>> pz @(MConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] +-- PresentT (Sum {getSum = 59}) +-- +-- >>> pz @(Map '(Pure SG.Sum Id, Pure SG.Max Id) Id >> MConcat Id) [7 :: Int,6,1,3,5] -- monoid so need eg Int +-- PresentT (Sum {getSum = 22},Max {getMax = 7}) +-- +data MConcat p + +instance (PP p x ~ [a] + , P p x + , Show a + , Monoid a + ) => P (MConcat p) x where + type PP (MConcat p) x = ExtractAFromList (PP p x) + eval _ opts x = do + let msg0 = "MConcat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = mconcat p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +-- | similar to 'SG.sconcat' +-- +-- >>> pz @(ToNEList >> SConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] +-- PresentT (Sum {getSum = 59}) +-- +-- >>> pz @(Map '(Pure SG.Sum Id, Pure SG.Max Id) Id >> ToNEList >> SConcat Id) [7,6,1,3,5] +-- PresentT (Sum {getSum = 22},Max {getMax = 7}) +-- +data SConcat p + +instance (PP p x ~ NonEmpty a + , P p x + , Show a + , Semigroup a + ) => P (SConcat p) x where + type PP (SConcat p) x = ExtractAFromTA (PP p x) + eval _ opts x = do + let msg0 = "SConcat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = SG.sconcat p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +data ToNEList +instance (Show (t a) + , Foldable t + ) => P ToNEList (t a) where + type PP ToNEList (t a) = NonEmpty a + eval _ opts as = + let msg0 = "ToNEList" + in pure $ case toList as of + [] -> mkNode opts (FailT "empty list") msg0 [] + x:xs -> mkNode opts (PresentT (x N.:| xs)) (msg0 <> showVerbose opts " " as) [] + + +-- | similar to a limited form of 'foldMap' +-- +-- >>> pz @(FoldMap (SG.Sum _) Id) [44, 12, 3] +-- PresentT 59 +-- +-- >>> pz @(FoldMap (SG.Product _) Id) [44, 12, 3] +-- PresentT 1584 +-- +-- >>> type Ands' p = FoldMap SG.All p +-- >>> pz @(Ands' Id) [True,False,True,True] +-- PresentT False +-- +-- >>> pz @(Ands' Id) [True,True,True] +-- PresentT True +-- +-- >>> pz @(Ands' Id) [] +-- PresentT True +-- +-- >>> type Ors' p = FoldMap SG.Any p +-- >>> pz @(Ors' Id) [False,False,False] +-- PresentT False +-- +-- >>> pz @(Ors' Id) [] +-- PresentT False +-- +-- >>> pz @(Ors' Id) [False,False,False,True] +-- PresentT True +-- +-- >>> type AllPositive' = FoldMap SG.All (Map Positive Id) +-- >>> pz @AllPositive' [3,1,-5,10,2,3] +-- PresentT False +-- +-- >>> type AllNegative' = FoldMap SG.All (Map Negative Id) +-- >>> pz @AllNegative' [-1,-5,-10,-2,-3] +-- PresentT True +-- +-- >>> :set -XKindSignatures +-- >>> type Max' (t :: Type) = FoldMap (SG.Max t) Id -- requires t be Bounded for monoid instance +-- >>> pz @(Max' Int) [10,4,5,12,3,4] +-- PresentT 12 +-- +data FoldMap (t :: Type) p +type FoldMapT (t :: Type) p = Map (Wrap t Id) p >> Unwrap (MConcat Id) + +instance P (FoldMapT t p) x => P (FoldMap t p) x where + type PP (FoldMap t p) x = PP (FoldMapT t p) x + eval _ = eval (Proxy @(FoldMapT t p)) + +-- | similar to 'concat' +-- +-- >>> pz @(Concat Id) ["abc","D","eF","","G"] +-- PresentT "abcDeFG" +-- +-- >>> pz @(Concat (Snd Id)) ('x',["abc","D","eF","","G"]) +-- PresentT "abcDeFG" +-- +data Concat p + +instance (Show a + , Show (t [a]) + , PP p x ~ t [a] + , P p x + , Foldable t + ) => P (Concat p) x where + type PP (Concat p) x = ExtractAFromTA (PP p x) + eval _ opts x = do + let msg0 = "Concat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = concat p + in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp] + +-- | similar to 'cycle' but for a fixed number \'n\' +-- +-- >>> pz @(Cycle 5 Id) [1,2] +-- PresentT [1,2,1,2,1] +-- +data Cycle n p + +instance (Show a + , Show (t a) + , PP p x ~ t a + , P p x + , Integral (PP n x) + , P n x + , Foldable t + ) => P (Cycle n p) x where + type PP (Cycle n p) x = [ExtractAFromTA (PP p x)] + eval _ opts x = do + let msg0 = "Cycle" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts x [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> n,p,nn,pp) -> + let hhs = [hh nn, hh pp] + in case chkSize opts msg0 p hhs of + Left e -> e + Right () -> + let msg1 = msg0 <> "(" <> show n <> ")" + d = take n (cycle (toList p)) + in mkNode opts (PresentT d) (show01 opts msg1 d p) hhs + +data ProxyT' t + +instance P (ProxyT' t) x where + type PP (ProxyT' t) x = Proxy (PP t x) + eval _ opts _ = + pure $ mkNode opts (PresentT Proxy) "ProxyT" [] + +data ProxyT (t :: Type) +type ProxyTT (t :: Type) = ProxyT' (Hole t) + +instance P (ProxyT t) x where + type PP (ProxyT t) x = PP (ProxyTT t) x + eval _ = eval (Proxy @(ProxyTT t)) + +-- | similar to 'Data.List.!!' +-- +-- >>> pz @(Ix 4 "not found") ["abc","D","eF","","G"] +-- PresentT "G" +-- +-- >>> pz @(Ix 40 "not found") ["abc","D","eF","","G"] +-- PresentT "not found" +-- +data Ix (n :: Nat) def + +instance (P def (Proxy a) + , PP def (Proxy a) ~ a + , KnownNat n + , Show a + ) => P (Ix n def) [a] where + type PP (Ix n def) [a] = a + eval _ opts as = do + let n = nat @n + msg0 = "Ix(" <> show n <> ")" + case as ^? ix n of + Nothing -> do + let msg1 = msg0 <> " not found" + pp <- eval (Proxy @def) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) msg1 [hh pp] + Just a -> pure $ mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + +data Ix' (n :: Nat) +type IxT' (n :: Nat) = Ix n (Failp "Ix index not found") + +instance P (IxT' n) x => P (Ix' n) x where + type PP (Ix' n) x = PP (IxT' n) x + eval _ = eval (Proxy @(IxT' n)) + +-- | similar to 'Data.List.!!' leveraging 'Ixed' +-- +-- >>> pz @(IxL Id 2 "notfound") ["abc","D","eF","","G"] +-- PresentT "eF" +-- +-- >>> pz @(IxL Id 20 "notfound") ["abc","D","eF","","G"] +-- PresentT "notfound" +-- +data IxL p q def -- p is the big value and q is the index and def is the default + +instance (P q a + , P p a + , Show (PP p a) + , Ixed (PP p a) + , PP q a ~ Index (PP p a) + , Show (Index (PP p a)) + , Show (IxValue (PP p a)) + , P r (Proxy (IxValue (PP p a))) + , PP r (Proxy (IxValue (PP p a))) ~ IxValue (PP p a) + ) + => P (IxL p q r) a where + type PP (IxL p q r) a = IxValue (PP p a) + eval _ opts a = do + let msg0 = "IxL" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> "(" <> show q <> ")" + in case p ^? ix q of + Nothing -> do + rr <- eval (Proxy @r) opts (Proxy @(IxValue (PP p a))) + pure $ case getValueLR opts msg1 rr [hh pp, hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool rr) (msg1 <> " index not found") [hh pp, hh qq] + Just ret -> pure $ mkNode opts (PresentT ret) (show01' opts msg1 ret "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to 'Data.List.!!' leveraging 'Ixed' +-- +-- >>> pz @(Id !! 2) ["abc","D","eF","","G"] +-- PresentT "eF" +-- +-- >>> pz @(Id !! 20) ["abc","D","eF","","G"] +-- FailT "(!!) index not found" +-- +-- >>> import qualified Data.Map.Strict as M +-- >>> pz @(Id !! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) +-- PresentT 2 +-- +data p !! q +type BangBangT p q = IxL p q (Failp "(!!) index not found") + +instance P (BangBangT p q) a => P (p !! q) a where + type PP (p !! q) a = PP (BangBangT p q) a + eval _ = eval (Proxy @(BangBangT p q)) + +-- | 'lookup' leveraging 'Ixed' +-- +-- >>> pz @(Lookup Id 2) ["abc","D","eF","","G"] +-- PresentT (Just "eF") +-- +-- >>> pz @(Lookup Id 20) ["abc","D","eF","","G"] +-- PresentT Nothing +-- +-- >>> pl @((Id !!? Char1 "d") > MkJust 99 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) +-- False (False || False | (Just 4 > Just 99) || (4 <= 3)) +-- FalseT +-- +-- >>> pz @((Id !!? Char1 "d") > MkJust 2 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) +-- TrueT +-- +data Lookup p q + +instance (P q a + , P p a + , Show (PP p a) + , Ixed (PP p a) + , PP q a ~ Index (PP p a) + , Show (Index (PP p a)) + , Show (IxValue (PP p a)) + ) + => P (Lookup p q) a where + type PP (Lookup p q) a = Maybe (IxValue (PP p a)) + eval _ opts a = do + let msg0 = "Lookup" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> "(" <> show q <> ")" + hhs = [hh pp, hh qq] + in case p ^? ix q of + Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " not found") hhs + Just ret -> mkNode opts (PresentT (Just ret)) (show01' opts msg1 ret "p=" p <> showVerbose opts " | q=" q) hhs + +data p !!? q +type BangBangQT p q = Lookup p q + +instance P (BangBangQT p q) a => P (p !!? q) a where + type PP (p !!? q) a = PP (BangBangQT p q) a + eval _ = eval (Proxy @(BangBangQT p q)) + + +-- | 'Data.List.ands' +-- +-- >>> pz @(Ands Id) [True,True,True] +-- TrueT +-- +-- >>> pl @(Ands Id) [True,True,True,False] +-- False (Ands(4) i=3 | [True,True,True,False]) +-- FalseT +-- +-- >>> pz @(Ands Id) [] +-- TrueT +-- +data Ands p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , a ~ Bool + ) => P (Ands p) x where + type PP (Ands p) x = Bool + eval _ opts x = do + let msg0 = "Ands" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let msg1 = msg0 ++ "(" ++ show (length p) ++ ")" + w = case findIndex not (toList p) of + Nothing -> "" + Just i -> " i="++show i + in mkNodeB opts (and p) (msg1 <> w <> showVerbose opts " | " p) [hh pp] + +-- | 'Data.List.ors' +-- +-- >>> pz @(Ors Id) [False,False,False] +-- FalseT +-- +-- >>> pl @(Ors Id) [True,True,True,False] +-- True (Ors(4) i=0 | [True,True,True,False]) +-- TrueT +-- +-- >>> pl @(Ors Id) [] +-- False (Ors(0) | []) +-- FalseT +-- +data Ors p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , a ~ Bool + ) => P (Ors p) x where + type PP (Ors p) x = Bool + eval _ opts x = do + let msg0 = "Ors" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let msg1 = msg0 ++ "(" ++ show (length p) ++ ")" + w = case findIndex id (toList p) of + Nothing -> "" + Just i -> " i="++show i + in mkNodeB opts (or p) (msg1 <> w <> showVerbose opts " | " p) [hh pp] + + +-- | similar to (++) +-- +-- >>> pz @(Fst Id ++ Snd Id) ([9,10,11],[1,2,3,4]) +-- PresentT [9,10,11,1,2,3,4] +-- +-- >>> pz @(Snd Id ++ Fst Id) ([],[5]) +-- PresentT [5] +-- +-- >>> pz @(Char1 "xyz" :+ W "ab" ++ W "cdefg") () +-- PresentT "xabcdefg" +-- +-- >>> pz @([1,2,3] ++ EmptyList _) "somestuff" +-- PresentT [1,2,3] +-- +data p ++ q +infixr 5 ++ + +instance (P p x + , P q x + , Show (PP p x) + , PP p x ~ [a] + , PP q x ~ [a] + ) => P (p ++ q) x where + type PP (p ++ q) x = PP q x + eval _ opts z = do + let msg0 = "(++)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p ++ q + in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + + + +-- cant directly create a singleton type using '[] since the type of '[] is unknown. instead use 'Singleton' or 'EmptyT' + +-- | similar to cons +-- +-- >>> pz @(Fst Id :+ Snd Id) (99,[1,2,3,4]) +-- PresentT [99,1,2,3,4] +-- +-- >>> pz @(Snd Id :+ Fst Id) ([],5) +-- PresentT [5] +-- +-- >>> pz @(123 :+ EmptyList _) "somestuff" +-- PresentT [123] +-- +data p :+ q +infixr 5 :+ + +instance (P p x + , P q x + , Show (PP p x) + , Show (PP q x) + , Cons (PP q x) (PP q x) (PP p x) (PP p x) + ) => P (p :+ q) x where + type PP (p :+ q) x = PP q x + eval _ opts z = do + let msg0 = "(:+)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `cons` q + in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to snoc +-- +-- >>> pz @(Snd Id +: Fst Id) (99,[1,2,3,4]) +-- PresentT [1,2,3,4,99] +-- +-- >>> pz @(Fst Id +: Snd Id) ([],5) +-- PresentT [5] +-- +-- >>> pz @(EmptyT [] Id +: 5) 5 +-- PresentT [5] +-- +data p +: q +infixl 5 +: + +instance (P p x + , P q x + , Show (PP q x) + , Show (PP p x) + , Snoc (PP p x) (PP p x) (PP q x) (PP q x) + ) => P (p +: q) x where + type PP (p +: q) x = PP p x + eval _ opts z = do + let msg0 = "(+:)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `snoc` q + in mkNode opts (PresentT b) (show01' opts msg0 b "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | 'Control.Lens.uncons' +-- +-- >>> pz @Uncons [1,2,3,4] +-- PresentT (Just (1,[2,3,4])) +-- +-- >>> pz @Uncons [] +-- PresentT Nothing +-- +-- >>> pz @Uncons (Seq.fromList "abc") +-- PresentT (Just ('a',fromList "bc")) +-- +-- >>> pz @Uncons ("xyz" :: T.Text) +-- PresentT (Just ('x',"yz")) +-- +data Uncons + +instance (Show (ConsT s) + , Show s + , Cons s s (ConsT s) (ConsT s) + ) => P Uncons s where + type PP Uncons s = Maybe (ConsT s,s) + eval _ opts as = + let msg0 = "Uncons" + b = as ^? _Cons + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + +-- | 'Control.Lens.unsnoc' +-- +-- >>> pz @Unsnoc [1,2,3,4] +-- PresentT (Just ([1,2,3],4)) +-- +-- >>> pz @Unsnoc [] +-- PresentT Nothing +-- +-- >>> pz @Unsnoc ("xyz" :: T.Text) +-- PresentT (Just ("xy",'z')) +-- +data Unsnoc + +instance (Show (ConsT s) + , Show s + , Snoc s s (ConsT s) (ConsT s) + ) => P Unsnoc s where + type PP Unsnoc s = Maybe (s,ConsT s) + eval _ opts as = + let msg0 = "Unsnoc" + b = as ^? _Snoc + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + +-- | similar to 'null' using 'AsEmpty' +-- +-- >>> pz @IsEmpty [1,2,3,4] +-- FalseT +-- +-- >>> pz @IsEmpty [] +-- TrueT +-- +-- >>> pz @IsEmpty LT +-- FalseT +-- +-- >>> pz @IsEmpty EQ +-- TrueT +-- +data IsEmpty + +instance ( Show as + , AsEmpty as + ) => P IsEmpty as where + type PP IsEmpty as = Bool + eval _ opts as = + let b = has _Empty as + in pure $ mkNodeB opts b ("IsEmpty" <> showVerbose opts " | " as) [] + +data Null' p + +instance (Show (t a) + , Foldable t + , t a ~ PP p x + , P p x + ) => P (Null' p) x where + type PP (Null' p) x = Bool + eval _ opts x = do + let msg0 = "Null" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = null p + in mkNodeB opts b ("Null" <> showVerbose opts " | " p) [hh pp] + +-- | similar to 'null' using 'Foldable' +-- +-- >>> pz @Null [1,2,3,4] +-- FalseT +-- +-- >>> pz @Null [] +-- TrueT +-- +-- >>> pz @Null Nothing +-- TrueT +-- +data Null +type NullT = Null' Id +instance P NullT a => P Null a where + type PP Null a = Bool + eval _ = evalBool (Proxy @NullT) + +-- | similar to 'enumFromTo' +-- +-- >>> pz @(2 ... 5) () +-- PresentT [2,3,4,5] +-- +-- >>> pz @('LT ... 'GT) () +-- PresentT [LT,EQ,GT] +-- +-- >>> pz @(EnumFromTo 'GT 'LT) () +-- PresentT [] +-- +-- >>> pz @(EnumFromTo (Pred Id) (Succ Id)) (SG.Max 10) +-- PresentT [Max {getMax = 9},Max {getMax = 10},Max {getMax = 11}] +-- +-- >>> pz @(EnumFromTo 1 20 >> Map '(Id, (If (Id `Mod` 3 == 0) "Fizz" "" <> If (Id `Mod` 5 == 0) "Buzz" "" )) Id) 123 +-- PresentT [(1,""),(2,""),(3,"Fizz"),(4,""),(5,"Buzz"),(6,"Fizz"),(7,""),(8,""),(9,"Fizz"),(10,"Buzz"),(11,""),(12,"Fizz"),(13,""),(14,""),(15,"FizzBuzz"),(16,""),(17,""),(18,"Fizz"),(19,""),(20,"Buzz")] +-- +data EnumFromTo p q +data p ... q +infix 4 ... + +type EnumFromToT p q = EnumFromTo p q + +instance P (EnumFromToT p q) x => P (p ... q) x where + type PP (p ... q) x = PP (EnumFromToT p q) x + eval _ = eval (Proxy @(EnumFromToT p q)) + +instance (P p x + , P q x + , PP p x ~ a + , Show a + , PP q x ~ a + , Enum a + ) => P (EnumFromTo p q) x where + type PP (EnumFromTo p q) x = [PP p x] + eval _ opts z = do + let msg0 = "..." + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> mkNode opts (PresentT (enumFromTo p q)) (showL opts p <> " " <> msg0 <> " " <> showL opts q) [hh pp, hh qq] + +-- | similar to 'enumFromThenTo' +-- +-- >>> pz @(EnumFromThenTo (ToEnum Day 10) (ToEnum Day 20) (ToEnum Day 70)) () +-- PresentT [1858-11-27,1858-12-07,1858-12-17,1858-12-27,1859-01-06,1859-01-16,1859-01-26] +-- +-- >>> pz @(EnumFromThenTo (ReadP Day "2020-01-12") (ReadP Day "2020-02-12") (ReadP Day "2020-08-12")) () +-- PresentT [2020-01-12,2020-02-12,2020-03-14,2020-04-14,2020-05-15,2020-06-15,2020-07-16] +-- +data EnumFromThenTo p q r + +instance (P p x + , P q x + , P r x + , PP p x ~ a + , Show a + , PP q x ~ a + , PP r x ~ a + , Enum a + ) => P (EnumFromThenTo p q r) x where + type PP (EnumFromThenTo p q r) x = [PP p x] + eval _ opts z = do + let msg0 = "EnumFromThenTo" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + rr <- eval (Proxy @r) opts z + pure $ case getValueLR opts (msg0 ++ " r failed") rr [hh pp, hh qq] of + Left e -> e + Right r -> + mkNode opts (PresentT (enumFromThenTo p q r)) (msg0 <> " [" <> showL opts p <> ", " <> showL opts q <> " .. " <> showL opts r <> "]") [hh pp, hh qq, hh rr] + +-- | similar to 'partitionEithers' +-- +-- >>> pz @PartitionEithers [Left 'a',Right 2,Left 'c',Right 4,Right 99] +-- PresentT ("ac",[2,4,99]) +-- +-- >>> pz @PartitionEithers [Right 2,Right 4,Right 99] +-- PresentT ([],[2,4,99]) +-- +-- >>> pz @PartitionEithers [Left 'a',Left 'c'] +-- PresentT ("ac",[]) +-- +-- >>> pz @PartitionEithers ([] :: [Either () Int]) +-- PresentT ([],[]) +-- +data PartitionEithers + +instance ( Show a + , Show b + ) => P PartitionEithers [Either a b] where + type PP PartitionEithers [Either a b] = ([a], [b]) + eval _ opts as = + let msg0 = "PartitionEithers" + b = partitionEithers as + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + +-- | similar to 'partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract +-- +-- >>> pz @PartitionThese [This 'a', That 2, This 'c', These 'z' 1, That 4, These 'a' 2, That 99] +-- PresentT ("ac",[2,4,99],[('z',1),('a',2)]) +-- +data PartitionThese + +instance ( Show a + , Show b + ) => P PartitionThese [These a b] where + type PP PartitionThese [These a b] = ([a], [b], [(a, b)]) + eval _ opts as = + let msg0 = "PartitionThese" + b = partitionThese as + in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + +data Thiss +type ThissT = Fst PartitionThese + +instance P ThissT x => P Thiss x where + type PP Thiss x = PP ThissT x + eval _ = eval (Proxy @ThissT) + +data Thats +type ThatsT = Snd PartitionThese + +instance P ThatsT x => P Thats x where + type PP Thats x = PP ThatsT x + eval _ = eval (Proxy @ThatsT) + +data Theses +type ThesesT = Thd PartitionThese + +instance P ThesesT x => P Theses x where + type PP Theses x = PP ThesesT x + eval _ = eval (Proxy @ThesesT) + +-- want to pass Proxy b to q but then we have no way to calculate 'b' + +-- | similar to 'scanl' +-- +-- >>> pz @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[1..5]) +-- PresentT [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] +-- +-- >>> pz @(ScanN 4 Id (Succ Id)) 'c' +-- PresentT "cdefg" +-- +-- >>> pz @(FoldN 4 Id (Succ Id)) 'c' +-- PresentT 'g' +-- +-- >>> pz @(Dup >> ScanN 4 Id (Pred Id *** Succ Id)) 'g' +-- PresentT [('g','g'),('f','h'),('e','i'),('d','j'),('c','k')] +-- +data Scanl p q r +-- scanr :: (a -> b -> b) -> b -> [a] -> [b] +-- result is scanl but signature is flipped ((a,b) -> b) -> b -> [a] -> [b] + +instance (PP p (b,a) ~ b + , PP q x ~ b + , PP r x ~ [a] + , P p (b,a) + , P q x + , P r x + , Show b + , Show a + ) + => P (Scanl p q r) x where + type PP (Scanl p q r) x = [PP q x] + eval _ opts z = do + let msg0 = "Scanl" + lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts z [] + case lr of + Left e -> pure e + Right (q,r,qq,rr) -> + case chkSize opts msg0 r [hh rr] of + Left e -> pure e + Right () -> do + let ff i b as' rs + | i >= oRecursion opts = pure (rs, Left $ mkNode opts (FailT (msg0 <> ":recursion limit i=" <> showIndex i)) ("(b,as')=" <> showL opts (b,as')) []) + | otherwise = + case as' of + [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (PresentT q) (msg0 <> "(done)") [])], Right ()) + a:as -> do + pp :: TT b <- evalHide (Proxy @p) opts (b,a) + case getValueLR opts (msg0 <> " i=" <> showIndex i <> " a=" <> show a) pp [] of + Left e -> pure (rs,Left e) + Right b' -> ff (i+1) b' as (rs ++ [((i,b), pp)]) + (ts,lrx) :: ([((Int, b), TT b)], Either (TT [b]) ()) <- ff 1 q r [] + pure $ case splitAndAlign opts msg0 (((0,q), mkNode opts (PresentT q) (msg0 <> "(initial)") []) : ts) of + Left e -> errorInProgram $ "Scanl e=" ++ show (fromTT e) + Right abcs -> + let vals = map (view _1) abcs + itts = map (view _2 &&& view _3) abcs + in case lrx of + Left e -> mkNode opts (_tBool e) msg0 (hh qq : hh rr : map (hh . fixit) itts ++ [hh e]) + Right () -> mkNode opts (PresentT vals) (show01' opts msg0 vals "b=" q <> showVerbose opts " | as=" r) (hh qq : hh rr : map (hh . fixit) itts) + +data ScanN n p q +type ScanNT n p q = Scanl (Fst Id >> q) p (EnumFromTo 1 n) -- n times using q then run p + +instance P (ScanNT n p q) x => P (ScanN n p q) x where + type PP (ScanN n p q) x = PP (ScanNT n p q) x + eval _ = eval (Proxy @(ScanNT n p q)) + +data ScanNA q +type ScanNAT q = ScanN (Fst Id) (Snd Id) q + +instance P (ScanNAT q) x => P (ScanNA q) x where + type PP (ScanNA q) x = PP (ScanNAT q) x + eval _ = eval (Proxy @(ScanNAT q)) + +data FoldN n p q +type FoldNT n p q = Last (ScanN n p q) + +instance P (FoldNT n p q) x => P (FoldN n p q) x where + type PP (FoldN n p q) x = PP (FoldNT n p q) x + eval _ = eval (Proxy @(FoldNT n p q)) + +data FoldL p q r +type FoldLT p q r = Last (Scanl p q r) + +instance P (FoldLT p q r) x => P (FoldL p q r) x where + type PP (FoldL p q r) x = PP (FoldLT p q r) x + eval _ = eval (Proxy @(FoldLT p q r)) + +-- | similar to 'unfoldr' +-- +-- >>> pz @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] +-- PresentT [[1,2],[3,4],[5]] +-- +data Unfoldr p q +--type IterateN (t :: Type) n f = Unfoldr (If (Fst Id == 0) (MkNothing t) (Snd Id &&& (Pred Id *** f) >> MkJust Id)) '(n, Id) + +instance (PP q a ~ s + , PP p s ~ Maybe (b,s) + , P q a + , P p s + , Show s + , Show b + ) + => P (Unfoldr p q) a where + type PP (Unfoldr p q) a = [UnfoldT (PP p (PP q a))] + eval _ opts z = do + let msg0 = "Unfoldr" + qq <- eval (Proxy @q) opts z + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + let msg1 = msg0 <> " " <> showL opts q + ff i s rs | i >= oRecursion opts = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":recursion limit i=" <> showIndex i)) ("s=" <> showL opts s) []) + | otherwise = do + pp :: TT (PP p s) <- evalHide (Proxy @p) opts s + case getValueLR opts (msg1 <> " i=" <> showIndex i <> " s=" <> show s) pp [] of + Left e -> pure (rs, Left e) + Right Nothing -> pure (rs, Right ()) + Right w@(Just (_b,s')) -> ff (i+1) s' (rs ++ [((i,w), pp)]) + (ts,lr) :: ([((Int, PP p s), TT (PP p s))], Either (TT [b]) ()) <- ff 1 q [] + pure $ case splitAndAlign opts msg1 ts of + Left e -> errorInProgram $ "Unfoldr e=" ++ show (fromTT e) + Right abcs -> + let vals = map (view _1) abcs + itts = map (view _2 &&& view _3) abcs + in case lr of + Left e -> mkNode opts (_tBool e) msg1 (hh qq : map (hh . fixit) itts ++ [hh e]) + Right () -> + let ret = fst <$> catMaybes vals + in mkNode opts (PresentT ret) (show01' opts msg1 ret "s=" q ) (hh qq : map (hh . fixit) itts) + +type family UnfoldT mbs where + UnfoldT (Maybe (b,s)) = b + +-- | like 'iterate' but for a fixed number of elements +-- +-- >>> pz @(IterateN 4 (Succ Id)) 4 +-- PresentT [4,5,6,7] +-- +-- >>> pz @('(0,1) >> IterateN 20 '(Snd Id, Fst Id + Snd Id) >> Map (Fst Id) Id) "sdf" +-- PresentT [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181] +-- +data IterateN n f +type IterateNT n f = Unfoldr (MaybeBool (Fst Id > 0) '(Snd Id, Pred Id *** f)) '(n, Id) + +instance P (IterateNT n f) x => P (IterateN n f) x where + type PP (IterateN n f) x = PP (IterateNT n f) x + eval _ = eval (Proxy @(IterateNT n f)) + +data IterateUntil p f +type IterateUntilT p f = IterateWhile (Not p) f + +instance P (IterateUntilT p f) x => P (IterateUntil p f) x where + type PP (IterateUntil p f) x = PP (IterateUntilT p f) x + eval _ = eval (Proxy @(IterateUntilT p f)) + +data IterateWhile p f +type IterateWhileT p f = Unfoldr (MaybeBool p '(Id, f)) Id + +instance P (IterateWhileT p f) x => P (IterateWhile p f) x where + type PP (IterateWhile p f) x = PP (IterateWhileT p f) x + eval _ = eval (Proxy @(IterateWhileT p f)) + +data IterateNWhile n p f +type IterateNWhileT n p f = '(n, Id) >> IterateWhile (Fst Id > 0 && (Snd Id >> p)) (Pred Id *** f) >> Map (Snd Id) Id + +instance P (IterateNWhileT n p f) x => P (IterateNWhile n p f) x where + type PP (IterateNWhile n p f) x = PP (IterateNWhileT n p f) x + eval _ = eval (Proxy @(IterateNWhileT n p f)) + +data IterateNUntil n p f +type IterateNUntilT n p f = IterateNWhile n (Not p) f + +instance P (IterateNUntilT n p f) x => P (IterateNUntil n p f) x where + type PP (IterateNUntil n p f) x = PP (IterateNUntilT n p f) x + eval _ = eval (Proxy @(IterateNUntilT n p f)) + +-- | similar to 'map' +-- +-- >>> pz @(Map (Pred Id) Id) [1..5] +-- PresentT [0,1,2,3,4] +-- +data Map p q + +instance (Show (PP p a) + , P p a + , PP q x ~ f a + , P q x + , Show a + , Show (f a) + , Foldable f + ) => P (Map p q) x where + type PP (Map p q) x = [PP p (ExtractAFromTA (PP q x))] + eval _ opts x = do + let msg0 = "Map" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalHide (Proxy @p) opts a) [0::Int ..] (toList q) + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let vals = map (view _1) abcs + in mkNode opts (PresentT vals) (show01 opts msg0 vals q) (hh qq : map (hh . fixit) ts) + +data ConcatMap p q +type ConcatMapT p q = Concat (Map p q) + +instance P (ConcatMapT p q) x => P (ConcatMap p q) x where + type PP (ConcatMap p q) x = PP (ConcatMapT p q) x + eval _ = eval (Proxy @(ConcatMapT p q)) + +-- | if p then run q else run r +-- +-- >>> pz @(If (Gt 4) "greater than 4" "less than or equal to 4" ) 10 +-- PresentT "greater than 4" +-- +-- >>> pz @(If (Gt 4) "greater than 4" "less than or equal to 4") 0 +-- PresentT "less than or equal to 4" +-- +-- >>> pz @(If (Snd Id == "a") '("xxx",Fst Id + 13) (If (Snd Id == "b") '("yyy",Fst Id + 7) (Failt _ "oops"))) (99,"b") +-- PresentT ("yyy",106) +-- +data If p q r + +instance (Show (PP r a) + , P p a + , PP p a ~ Bool + , P q a + , P r a + , PP q a ~ PP r a + ) => P (If p q r) a where + type PP (If p q r) a = PP q a + eval _ opts a = do + let msg0 = "If" + pp <- evalBool (Proxy @p) opts a + case getValueLR opts (msg0 <> " condition failed") pp [] of + Left e -> pure e + Right b -> do + qqrr <- if b + then eval (Proxy @q) opts a + else eval (Proxy @r) opts a + pure $ case getValueLR opts (msg0 <> " [" <> show b <> "]") qqrr [hh pp, hh qqrr] of + Left e -> e + Right ret -> mkNode opts (_tBool qqrr) (msg0 <> " " <> if b then "(true cond)" else "(false cond)" <> " " <> showL opts ret) [hh pp, hh qqrr] + +-- | creates a list of overlapping pairs of elements. requires two or more elements +-- +-- >>> pz @Pairs [1,2,3,4] +-- PresentT [(1,2),(2,3),(3,4)] +-- +-- >>> pz @Pairs [] +-- FailT "Pairs no data found" +-- +-- >>> pz @Pairs [1] +-- FailT "Pairs only one element found" +-- +data Pairs +instance Show a => P Pairs [a] where + type PP Pairs [a] = [(a,a)] + eval _ opts as = + let msg0 = "Pairs" + lr = case as of + [] -> Left (msg0 <> " no data found") + [_] -> Left (msg0 <> " only one element found") + _:bs@(_:_) -> Right (zip as bs) + in pure $ case lr of + Left e -> mkNode opts (FailT e) e [] + Right zs -> mkNode opts (PresentT zs) (show01 opts msg0 zs as ) [] + + +-- | similar to 'partition' +-- +-- >>> pz @(Partition (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([10,4,7,3,3,5],[1,1]) +-- +-- >>> pz @(Partition (Prime Id) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([7,3,3,5],[10,4,1,1]) +-- +-- >>> pz @(Partition (Ge 300) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pz @(Partition (Id < 300) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([10,4,1,7,3,1,3,5],[]) +-- +data Partition p q + +instance (P p x + , Show x + , PP q a ~ [x] + , PP p x ~ Bool + , P q a + ) => P (Partition p q) a where + type PP (Partition p q) a = (PP q a, PP q a) + eval _ opts a' = do + let msg0 = "Partition" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBoolHide (Proxy @p) opts a) [0::Int ..] q + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let itts = map (view _2 &&& view _3) abcs + w0 = partition (view _1) abcs + zz1 = (map (view (_2 . _2)) *** map (view (_2 . _2))) w0 + in mkNode opts (PresentT zz1) (show01' opts msg0 zz1 "s=" q) (hh qq : map (hh . fixit) itts) + + +-- | partition values based on a function +-- +-- >>> pz @(PartitionBy Ordering (Case 'EQ '[Id < 0, Id > 0] '[ 'LT, 'GT] Id) Id) [-4,-2,5,6,7,0,-1,2,-3,4,0] +-- PresentT (fromList [(LT,[-3,-1,-2,-4]),(EQ,[0,0]),(GT,[4,2,7,6,5])]) +-- +-- >>> pl @(PartitionBy Ordering (Case (Failt _ "asdf") '[Id < 2, Id == 2, Id > 2] '[ 'LT, 'EQ, 'GT] Id) Id) [-4,2,5,6,7,1,2,3,4] +-- Present fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])] (PartitionBy fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])] | s=[-4,2,5,6,7,1,2,3,4]) +-- PresentT (fromList [(LT,[1,-4]),(EQ,[2,2]),(GT,[4,3,7,6,5])]) +-- +-- >>> pl @(PartitionBy Ordering (Case (Failt _ "xyzxyzxyzzyyysyfsyfydf") '[Id < 2, Id == 2, Id > 3] '[ 'LT, 'EQ, 'GT] Id) Id) [-4,2,5,6,7,1,2,3,4] +-- Error xyzxyzxyzzyyysyfsyfydf (PartitionBy(i=7, a=3) excnt=1) +-- FailT "xyzxyzxyzzyyysyfsyfydf" +-- +data PartitionBy t p q + +instance (P p x + , Ord t + , Show x + , Show t + , PP q a ~ [x] + , PP p x ~ t + , P q a + ) => P (PartitionBy t p q) a where + type PP (PartitionBy t p q) a = M.Map t (PP q a) + eval _ opts a' = do + let msg0 = "PartitionBy" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalHide (Proxy @p) opts a) [0::Int ..] q + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let kvs = map (view _1 &&& ((:[]) . view (_2 . _2))) abcs + itts = map (view _2 &&& view _3) abcs + ret = M.fromListWith (++) kvs + in mkNode opts (PresentT ret) (show01' opts msg0 ret "s=" q ) (hh qq : map (hh . fixit) itts) + +-- | similar to 'groupBy' +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [1,3,4,5,1,5,5] +-- PresentT [[1],[3],[4],[5],[1],[5,5]] +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [1,1,1,3,4,5,1,5,5] +-- PresentT [[1,1,1],[3],[4],[5],[1],[5,5]] +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [5,5] +-- PresentT [[5,5]] +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [1,2] +-- PresentT [[1],[2]] +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [1] +-- PresentT [[1]] +-- +-- >>> pz @(GroupBy (Fst Id == Snd Id) Id) [] +-- PresentT [] +-- +-- >>> pz @(GroupBy (Fst Id < Snd Id) Id) [1,2,3,4,4,1,2] +-- PresentT [[1,2,3,4],[4],[1,2]] +-- +-- >>> pz @(GroupBy (Fst Id /= Snd Id) Id) [1,2,3,4,4,4,1] +-- PresentT [[1,2,3,4],[4],[4,1]] +-- +-- >>> pan @(GroupBy (Fst Id == Snd Id) Id) "hello goodbye" +-- P GroupBy ["h","e","ll","o"," ","g","oo","d","b","y","e"] +-- | +-- +- P Id "hello goodbye" +-- | +-- +- False i=0:'h' == 'e' +-- | +-- +- False i=1:'e' == 'l' +-- | +-- +- True i=2:'l' == 'l' +-- | +-- +- False i=3:'l' == 'o' +-- | +-- +- False i=4:'o' == ' ' +-- | +-- +- True i=5:' ' == ' ' +-- | +-- +- True i=6:' ' == ' ' +-- | +-- +- True i=7:' ' == ' ' +-- | +-- +- False i=8:' ' == 'g' +-- | +-- +- False i=9:'g' == 'o' +-- | +-- +- True i=10:'o' == 'o' +-- | +-- +- False i=11:'o' == 'd' +-- | +-- +- False i=12:'d' == 'b' +-- | +-- +- False i=13:'b' == 'y' +-- | +-- `- False i=14:'y' == 'e' +-- PresentT ["h","e","ll","o"," ","g","oo","d","b","y","e"] +-- +data GroupBy p q + +instance (Show x + , PP q a ~ [x] + , PP p (x,x) ~ Bool + , P p (x,x) + , P q a + ) => P (GroupBy p q) a where + type PP (GroupBy p q) a = [PP q a] + eval _ opts a' = do + let msg0 = "GroupBy" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + case q of + [] -> pure $ mkNode opts (PresentT []) (show01' opts msg0 q "s=" q) [hh qq] + [_] -> pure $ mkNode opts (PresentT [q]) (show01' opts msg0 [q] "s=" q) [hh qq] + x:xs -> do + ts <- zipWithM (\i (a,b) -> ((i, b),) <$> evalBoolHide (Proxy @p) opts (a,b)) [0::Int ..] (zip (x:xs) xs) + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let ret = gp1 x abcs + itts = map (view _2 &&& view _3) abcs + in mkNode opts (PresentT ret) (show01' opts msg0 ret "s=" q ) (hh qq : map (hh . fixit) itts) + +gp1 :: x -> [(Bool, (Int, x), TT Bool)] -> [[x]] +gp1 b = go [b] + where + go ret = + \case + [] -> [ret] + (tf, (_, a), _):as -> if tf then go (ret <> [a]) as + else ret : go [a] as + +data Filter p q +type FilterT p q = Fst (Partition p q) + +instance P (FilterT p q) x => P (Filter p q) x where + type PP (Filter p q) x = PP (FilterT p q) x + eval _ = eval (Proxy @(FilterT p q)) + +-- | similar to 'break' +-- +-- >>> pz @(Break (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pz @(Break (Lt 3) Id) [10,4,1,7,3,1,3,5] +-- PresentT ([10,4],[1,7,3,1,3,5]) +-- +data Break p q + +-- only process up to the pivot! only process while Right False +-- a predicate can return PresentP not just TrueP +instance (P p x + , PP q a ~ [x] + , PP p x ~ Bool + , P q a + ) => P (Break p q) a where + type PP (Break p q) a = (PP q a, PP q a) + eval _ opts a' = do + let msg0 = "Break" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right () -> do + let ff [] zs = pure (zs, [], Nothing) -- [(ia,qq)] extras | the rest of the data | optional last pivot or failure + ff ((i,a):ias) zs = do + pp <- evalBoolHide (Proxy @p) opts a + let v = ((i,a), pp) + case getValueLR opts msg0 pp [hh qq] of + Right False -> ff ias (zs Seq.|> v) + Right True -> pure (zs,map snd ias,Just v) + Left _ -> pure (zs,map snd ias,Just v) + (ialls,rhs,mpivot) <- ff (itoList q) Seq.empty + pure $ case mpivot of + Nothing -> + mkNode opts (PresentT (map (snd . fst) (toList ialls), rhs)) + (msg0 <> " cnt=" <> show (length ialls, length rhs)) + (map (hh . fixit) (toList ialls)) + Just iall@(ia, tt) -> + case getValueLR opts (msg0 <> " predicate failed") tt (hh qq : map (hh . fixit) (toList (ialls Seq.|> iall))) of + Right True -> + mkNode opts (PresentT (map (snd . fst) (toList ialls), snd ia : rhs)) + (msg0 <> " cnt=" <> show (length ialls, 1+length rhs)) + (hh qq : hh tt : map (hh . fixit) (toList (ialls Seq.|> iall))) + + Right False -> errorInProgram "Break" + Left e -> e + +data Span p q +type SpanT p q = Break (Not p) q + +instance P (SpanT p q) x => P (Span p q) x where + type PP (Span p q) x = PP (SpanT p q) x + eval _ = eval (Proxy @(SpanT p q)) + +-- | Fails the computation with a message +-- +-- >>> pz @(Failt Int (PrintF "value=%03d" Id)) 99 +-- FailT "value=099" +-- +-- >>> pz @(FailS (PrintT "value=%03d string=%s" Id)) (99,"somedata") +-- FailT "value=099 string=somedata" +-- +data Fail t prt + +instance (P prt a + , PP prt a ~ String + ) => P (Fail t prt) a where + type PP (Fail t prt) a = PP t a + eval _ opts a = do + let msg0 = "Fail" + pp <- eval (Proxy @prt) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> mkNode opts (FailT s) (msg0 <> " " <> s) [hh pp | isVerbose opts] + +data FailS p +instance P (Fail I p) x => P (FailS p) x where + type PP (FailS p) x = PP (Fail I p) x + eval _ = eval (Proxy @(Fail I p)) + +data Failt (t :: Type) p +instance P (Fail (Hole t) p) x => P (Failt t p) x where + type PP (Failt t p) x = PP (Fail (Hole t) p) x + eval _ = eval (Proxy @(Fail (Hole t) p)) + +data Failp p +instance P (Fail Unproxy p) x => P (Failp p) x where + type PP (Failp p) x = PP (Fail Unproxy p) x + eval _ = eval (Proxy @(Fail Unproxy p)) + +data Hole (t :: Type) + +-- | Acts as a proxy in this dsl where you can explicitly set the Type. +-- +-- It is passed around as an argument to help the type checker when needed. +-- see 'ParseTimeP', 'ReadBase' +-- +instance Typeable t => P (Hole t) a where + type PP (Hole t) a = t -- can only be Type not Type -> Type (can use Proxy but then we go down the rabbithole) + eval _ opts _a = + let msg0 = "Hole(" <> showT @t <> ")" + in pure $ mkNode opts (FailT msg0) "you probably meant to get access to the type of PP only and not evaluate" [] + +data Unproxy + +instance Typeable a => P Unproxy (Proxy (a :: Type)) where + type PP Unproxy (Proxy a) = a + eval _ opts _a = + let msg0 = "Unproxy(" <> showT @a <> ")" + in pure $ mkNode opts (FailT msg0) "you probably meant to get access to the type of PP only and not evaluate" [] + +-- | catch a failure +-- +-- >>> pz @(Catch (Succ Id) (Fst Id >> Second (ShowP Id) >> PrintT "%s %s" Id >> 'LT)) GT +-- PresentT LT +-- +-- >>> pz @(Catch' (Succ Id) (Second (ShowP Id) >> PrintT "%s %s" Id)) GT +-- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT" +-- +-- >>> pz @(Catch' (Succ Id) (Second (ShowP Id) >> PrintT "%s %s" Id)) LT +-- PresentT EQ +-- +-- >>> pz @(Len > 1 && Catch (Id !! 3 == 66) 'False) [1,2] +-- FalseT +-- +-- more flexible: takes a (String,x) and a proxy so we can still call 'False 'True +-- now takes the FailT string and x so you can print more detail if you want +-- need the proxy so we can fail without having to explicitly specify a type +data Catch p q -- catch p and if fails runs q only on failt + +data Catch' p s +type CatchT' p s = Catch p (FailCatch s) -- eg set eg s=PrintF "%d" Id or PrintF "%s" (ShowP Id) +type FailCatch s = Fail (Snd Id >> Unproxy) (Fst Id >> s) + +instance P (CatchT' p s) x => P (Catch' p s) x where + type PP (Catch' p s) x = PP (CatchT' p s) x + eval _ = eval (Proxy @(CatchT' p s)) + +instance (P p x + , P q ((String, x) + , Proxy (PP p x)) + , PP p x ~ PP q ((String, x), Proxy (PP p x)) + ) => P (Catch p q) x where + type PP (Catch p q) x = PP p x + eval _ opts x = do + let msg0 = "Catch" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> do + let emsg = e ^?! tBool . _FailT -- extract the failt string a push back into the fail case + qq <- eval (Proxy @q) opts ((emsg, x), Proxy @(PP p x)) + pure $ case getValueLR opts (msg0 <> " default condition failed") qq [hh pp] of + Left e1 -> e1 + Right _ -> mkNode opts (_tBool qq) (msg0 <> " caught exception[" <> emsg <> "]") [hh pp, hh qq] + Right _ -> pure $ mkNode opts (_tBool pp) (msg0 <> " did not fire") [hh pp] + +-- | similar to 'even' +-- +-- >>> pz @(Map Even Id) [9,-4,12,1,2,3] +-- PresentT [False,True,True,False,True,False] +-- +-- >>> pz @(Map '(Even,Odd) Id) [9,-4,12,1,2,3] +-- PresentT [(False,True),(True,False),(True,False),(False,True),(True,False),(False,True)] +-- +data Even +type EvenT = Mod I 2 == 0 + +instance P EvenT x => P Even x where + type PP Even x = Bool + eval _ = evalBool (Proxy @EvenT) + +data Odd +type OddT = Mod I 2 == 1 + +instance P OddT x => P Odd x where + type PP Odd x = Bool + eval _ = evalBool (Proxy @OddT) + + +--type Div' p q = Fst (DivMod p q) +--type Mod' p q = Snd (DivMod p q) + +-- | similar to 'div' +-- +-- >>> pz @(Div (Fst Id) (Snd Id)) (10,4) +-- PresentT 2 +-- +-- >>> pz @(Div (Fst Id) (Snd Id)) (10,0) +-- FailT "Div zero denominator" +-- +data Div p q +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (Div p q) a where + type PP (Div p q) a = PP p a + eval _ opts a = do + let msg0 = "Div" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `div` q + in mkNode opts (PresentT d) (showL opts p <> " `div` " <> showL opts q <> " = " <> showL opts d) hhs + + +-- | similar to 'mod' +-- +-- >>> pz @(Mod (Fst Id) (Snd Id)) (10,3) +-- PresentT 1 +-- +-- >>> pz @(Mod (Fst Id) (Snd Id)) (10,0) +-- FailT "Mod zero denominator" +-- +data Mod p q +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (Mod p q) a where + type PP (Mod p q) a = PP p a + eval _ opts a = do + let msg0 = "Mod" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `mod` q + in mkNode opts (PresentT d) (showL opts p <> " `mod` " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'divMod' +-- +-- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,3) +-- PresentT (3,1) +-- +-- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,-3) +-- PresentT (-4,-2) +-- +-- >>> pz @(DivMod (Fst Id) (Snd Id)) (-10,3) +-- PresentT (-4,2) +-- +-- >>> pz @(DivMod (Fst Id) (Snd Id)) (-10,-3) +-- PresentT (3,-1) +-- +-- >>> pz @(DivMod (Fst Id) (Snd Id)) (10,0) +-- FailT "DivMod zero denominator" +-- +data DivMod p q + +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (DivMod p q) a where + type PP (DivMod p q) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "DivMod" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `divMod` q + in mkNode opts (PresentT d) (showL opts p <> " `divMod` " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'quotRem' +-- +-- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,3) +-- PresentT (3,1) +-- +-- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,-3) +-- PresentT (-3,1) +-- +-- >>> pz @(QuotRem (Fst Id) (Snd Id)) (-10,-3) +-- PresentT (3,-1) +-- +-- >>> pz @(QuotRem (Fst Id) (Snd Id)) (-10,3) +-- PresentT (-3,-1) +-- +-- >>> pz @(QuotRem (Fst Id) (Snd Id)) (10,0) +-- FailT "QuotRem zero denominator" +-- +data QuotRem p q + +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (QuotRem p q) a where + type PP (QuotRem p q) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "QuotRem" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `quotRem` q + in mkNode opts (PresentT d) (showL opts p <> " `quotRem` " <> showL opts q <> " = " <> showL opts d) hhs + +data Quot p q +type QuotT p q = Fst (QuotRem p q) + +instance P (QuotT p q) x => P (Quot p q) x where + type PP (Quot p q) x = PP (QuotT p q) x + eval _ = eval (Proxy @(QuotT p q)) + +data Rem p q +type RemT p q = Snd (QuotRem p q) + +instance P (RemT p q) x => P (Rem p q) x where + type PP (Rem p q) x = PP (RemT p q) x + eval _ = eval (Proxy @(RemT p q)) + +--type OneP = Guard "expected list of length 1" (Len == 1) >> Head Id +--type OneP = Guard (PrintF "expected list of length 1 but found length=%d" Len) (Len == 1) >> Head Id + +-- k or prt has access to (Int,a) where Int is the current guard position: hence need to use PrintT +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out) + +-- | Guards contain a type level list of tuples the action to run on failure of the predicate and the predicate itself +-- Each tuple validating against the corresponding value in a value list +-- +-- \'prt\' receives (Int,a) as input which is the position and value if there is a failure +-- +-- >>> pz @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 4)]) [17,4] +-- PresentT [17,4] +-- +-- >>> pz @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 5)]) [17,4] +-- FailT "arg2 failed" +-- +-- >>> pz @(Guards '[ '("arg1 failed",Gt 99), '("arg2 failed", Same 4)]) [17,4] +-- FailT "arg1 failed" +-- +-- >>> pz @(Guards '[ '(PrintT "arg %d failed with value %d" Id,Gt 4), '(PrintT "%d %d" Id, Same 4)]) [17,3] +-- FailT "1 3" +-- +-- >>> pz @(GuardsQuick (PrintT "arg %d failed with value %d" Id) '[Gt 4, Ge 3, Same 4]) [17,3,5] +-- FailT "arg 2 failed with value 5" +-- +-- >>> pz @(GuardsQuick (PrintT "arg %d failed with value %d" Id) '[Gt 4, Ge 3, Same 4]) [17,3,5,99] +-- FailT "Guards:invalid length(4) expected 3" +-- +data GuardsImpl (n :: Nat) (os :: [(k,k1)]) + +data Guards (ps :: [(k,k1)]) + +instance ( [a] ~ x + , GetLen ps + , P (GuardsImpl (LenT ps) ps) x + ) => P (Guards ps) x where + type PP (Guards ps) x = PP (GuardsImpl (LenT ps) ps) x + eval _ opts as = do + let msg0 = "Guards" + n = getLen @ps + if n /= length as then + let msg1 = msg0 <> badLength as n + in pure $ mkNode opts (FailT msg1) "" [] + else eval (Proxy @(GuardsImpl (LenT ps) ps)) opts as + +badLength :: ( Foldable t + , Show n + , Num n + ) => t a + -> n + -> String +badLength as n = ":invalid length(" <> show (length as) <> ") expected " ++ show (n+0) + +instance ( [a] ~ x + , Show a + ) => P (GuardsImpl n ('[] :: [(k,k1)])) x where + type PP (GuardsImpl n ('[] :: [(k,k1)])) x = x + eval _ opts as = + let msg0 = "Guards" + in if not (null as) then errorInProgram $ "GuardsImpl base case has extra data " ++ show as + else pure $ mkNode opts (PresentT as) (msg0 <> " no data") [] + +instance (PP prt (Int, a) ~ String + , P prt (Int, a) + , KnownNat n + , GetLen ps + , P p a + , PP p a ~ Bool + , P (GuardsImpl n ps) [a] + , PP (GuardsImpl n ps) [a] ~ [a] + , Show a + , [a] ~ x + ) => P (GuardsImpl n ('(prt,p) ': ps)) x where + type PP (GuardsImpl n ('(prt,p) ': ps)) x = x + eval _ opts as' = do + let cpos = n-pos-1 + msgbase1 = "Guard(" <> show cpos <> ")" + msgbase2 = "Guards" + n :: Int + n = nat @n + pos = getLen @ps + case as' of + a:as -> do + pp <- evalBoolHide (Proxy @p) opts a + case getValueLR opts (msgbase1 <> " p failed") pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts (cpos,a) -- only run prt when predicate is False + pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (FailT msgx) (msgbase1 <> " failed [" <> msgx <> "]" <> " " <> showL opts a) (hh pp : [hh qq | isVerbose opts]) + Right True -> + if pos == 0 then -- we are at the bottom of the tree + pure $ mkNode opts (PresentT [a]) msgbase2 [hh pp] + else do + ss <- eval (Proxy @(GuardsImpl n ps)) opts as + pure $ case getValueLR opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right zs -> (ss & tForest %~ \x -> fromTT pp : x) & tBool .~ PresentT (a:zs) + _ -> errorInProgram "GuardsImpl n+1 case has no data" + +data GuardsQuick (prt :: k) (ps :: [k1]) +type GuardsQuickT (prt :: k) (ps :: [k1]) = Guards (ToGuardsT prt ps) + +instance P (GuardsQuickT prt ps) x => P (GuardsQuick prt ps) x where + type PP (GuardsQuick prt ps) x = PP (GuardsQuickT prt ps) x + eval _ = eval (Proxy @(GuardsQuickT prt ps)) + +-- | boolean guard which checks a given a list of predicates against the list of values +-- +-- prefer 'Bools' as 'BoolsQuick' doesnt give much added value: passes in the index and the value to prt but you already have the index in the message +-- +-- pulls the top message from the tree if a predicate is false +-- +-- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,93,14] +-- False (Bool(1) [mm] (93 <= 59)) +-- FalseT +-- +-- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,13,94] +-- False (Bool(2) [<<<2 94>>>] (94 <= 59)) +-- FalseT +-- +-- >>> pl @(Bools '[ '(W "hh",Between 0 23 Id), '(W "mm",Between 0 59 Id), '(PrintT "<<<%d %d>>>" Id,Between 0 59 Id) ] ) [12,13,14] +-- True (Bools) +-- TrueT +-- +-- >>> pl @(BoolsQuick "abc" '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,14] +-- True (Bools) +-- TrueT +-- +-- >>> pl @(BoolsQuick (PrintT "id=%d val=%d" Id) '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,14] +-- True (Bools) +-- TrueT +-- +-- >>> pl @(BoolsQuick (PrintT "id=%d val=%d" Id) '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,99] +-- False (Bool(2) [id=2 val=99] (99 <= 59)) +-- FalseT +-- +-- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,13,14] +-- True (Bools) +-- TrueT +-- +-- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,60,14] +-- False (Bool(1) [minutes] (60 <= 59)) +-- FalseT +-- +-- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] ) [12,60,14,20] +-- False (Bools:invalid length(4) expected 3) +-- FalseT +-- +data Bools (ps :: [(k,k1)]) + +instance ([a] ~ x + , GetLen ps + , P (BoolsImpl (LenT ps) ps) x + , PP (BoolsImpl (LenT ps) ps) x ~ Bool + ) => P (Bools ps) x where + type PP (Bools ps) x = Bool + eval _ opts as = do + let msg0 = "Bools" + msg1 = "Bool("++show n++")" + n = getLen @ps + case chkSize opts msg1 as [] of + Left e -> pure e + Right () -> + if n /= length as then + let msg2 = msg0 <> badLength as n + in pure $ mkNodeB opts False msg2 [] -- was FailT but now just FalseT + else evalBool (Proxy @(BoolsImpl (LenT ps) ps)) opts as + +data BoolsImpl (n :: Nat) (os :: [(k,k1)]) + +instance (KnownNat n + , Show a + , [a] ~ x + ) => P (BoolsImpl n ('[] :: [(k,k1)])) x where + type PP (BoolsImpl n ('[] :: [(k,k1)])) x = Bool + eval _ opts as = + let msg0 = "Bool(" <> show n <> ")" + n :: Int = nat @n + in if not (null as) then errorInProgram $ "BoolsImpl base case has extra data " ++ show as + else pure $ mkNodeB opts True (msg0 <> " empty") [] + +instance (PP prt (Int, a) ~ String + , P prt (Int, a) + , KnownNat n + , GetLen ps + , P p a + , PP p a ~ Bool + , P (BoolsImpl n ps) x + , PP (BoolsImpl n ps) [a] ~ Bool +-- , Show a + , [a] ~ x + ) => P (BoolsImpl n ('(prt,p) ': ps)) x where + type PP (BoolsImpl n ('(prt,p) ': ps)) x = Bool + eval _ opts as' = do + let cpos = n-pos-1 + msgbase1 = "Bool(" <> showIndex cpos <> ")" + msgbase2 = "Bools" + n :: Int = nat @n + pos = getLen @ps + case as' of + a:as -> do + pp <- evalBoolHide (Proxy @p) opts a + case getValueLR opts (msgbase1 <> " p failed") pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts (cpos,a) -- only run prt when predicate is False + pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNodeB opts False (msgbase1 <> " [" <> msgx <> "] " <> topMessage pp) (hh pp : [hh qq | isVerbose opts]) + Right True -> + if pos == 0 then -- we are at the bottom of the tree + pure $ mkNodeB opts True msgbase2 [hh pp] + else do + ss <- evalBool (Proxy @(BoolsImpl n ps)) opts as + pure $ case getValueLR opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right _ -> ss & tForest %~ \x -> fromTT pp : x + _ -> errorInProgram "BoolsImpl n+1 case has no data" + +data BoolsQuick (prt :: k) (ps :: [k1]) +type BoolsQuickT (prt :: k) (ps :: [k1]) = Bools (ToGuardsT prt ps) + +-- why do we need this? when BoolsN works without [use the x ~ [a] trick in BoolsN] +instance (PP (Bools (ToGuardsT prt ps)) x ~ Bool + , P (BoolsQuickT prt ps) x + ) => P (BoolsQuick prt ps) x where + type PP (BoolsQuick prt ps) x = PP (BoolsQuickT prt ps) x + eval _ = evalBool (Proxy @(BoolsQuickT prt ps)) + +-- | leverages 'RepeatT' for repeating predicates (passthrough method) +-- +-- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,256] +-- False (Bool(3) [id=3 must be between 0 and 255, found 256] (256 <= 255)) +-- FalseT +-- +-- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,44] +-- True (Bools) +-- TrueT +-- +data BoolsN prt (n :: Nat) (p :: k1) +type BoolsNT prt (n :: Nat) (p :: k1) = Bools (ToGuardsT prt (RepeatT n p)) + +instance ( x ~ [a] + , P (BoolsNT prt n p) x + ) => P (BoolsN prt n p) x where + type PP (BoolsN prt n p) x = PP (BoolsNT prt n p) x + eval _ = evalBool (Proxy @(BoolsNT prt n p)) + +-- | if a predicate fails then then the corresponding symbol and value will be passed to the print function +-- +-- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [13,59,61] +-- FailT "seconds invalid: found 61" +-- +-- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [27,59,12] +-- FailT "hours invalid: found 27" +-- +-- >>> pz @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)]) [23,59,12] +-- PresentT [23,59,12] +-- +data GuardsDetailImpl (ps :: [(k,k1)]) + +instance ([a] ~ x + , GetLen ps + , P (GuardsImplX (LenT ps) ps) x + ) => P (GuardsDetailImpl ps) x where + type PP (GuardsDetailImpl ps) x = PP (GuardsImplX (LenT ps) ps) x + eval _ opts as = do + let msg0 = "Guards" + n = getLen @ps + if n /= length as then + let msg1 = msg0 <> badLength as n + in pure $ mkNode opts (FailT msg1) "" [] + else eval (Proxy @(GuardsImplX (LenT ps) ps)) opts as + +data GuardsImplX (n :: Nat) (os :: [(k,k1)]) + +instance ( [a] ~ x + , Show a + ) => P (GuardsImplX n ('[] :: [(k,k1)])) x where + type PP (GuardsImplX n ('[] :: [(k,k1)])) x = x + eval _ opts as = + let msg0 = "Guards" + -- n :: Int = nat @n + in if not (null as) then errorInProgram $ "GuardsImplX base case has extra data " ++ show as + else pure $ mkNode opts (PresentT as) msg0 [] + +instance (PP prt a ~ String + , P prt a + , KnownNat n + , GetLen ps + , P p a + , PP p a ~ Bool + , P (GuardsImplX n ps) [a] + , PP (GuardsImplX n ps) [a] ~ [a] + , Show a + , [a] ~ x + ) => P (GuardsImplX n ('(prt,p) ': ps)) x where + type PP (GuardsImplX n ('(prt,p) ': ps)) x = x + eval _ opts as' = do + let cpos = n-pos-1 + msgbase1 = "Guard(" <> showIndex cpos <> ")" + msgbase2 = "Guards" + n :: Int = nat @n + pos = getLen @ps + case as' of + a:as -> do + pp <- evalBoolHide (Proxy @p) opts a + case getValueLR opts (msgbase1 <> " p failed") pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts a -- only run prt when predicate is False + pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (FailT msgx) (msgbase1 <> " failed [" <> msgx <> "]" <> " " <> showL opts a) (hh pp : [hh qq | isVerbose opts]) + Right True -> do + ss <- eval (Proxy @(GuardsImplX n ps)) opts as + pure $ case getValueLR opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right zs -> mkNode opts (PresentT (a:zs)) (msgbase1 <> " " <> showL opts a) [hh pp, hh ss] + _ -> errorInProgram "GuardsImplX n+1 case has no data" + +data GuardsDetail prt (ps :: [(k0,k1)]) +type GuardsDetailT prt (ps :: [(k0,k1)]) = GuardsDetailImpl (ToGuardsDetailT prt ps) + +instance P (GuardsDetailT prt ps) x => P (GuardsDetail prt ps) x where + type PP (GuardsDetail prt ps) x = PP (GuardsDetailT prt ps) x + eval _ = eval (Proxy @(GuardsDetailT prt ps)) + +type family ToGuardsDetailT (prt :: k1) (os :: [(k2,k3)]) :: [(Type,k3)] where + ToGuardsDetailT prt '[ '(s,p) ] = '(PrintT prt '(s,Id), p) : '[] + ToGuardsDetailT prt ( '(s,p) ': ps) = '(PrintT prt '(s,Id), p) ': ToGuardsDetailT prt ps + ToGuardsDetailT prt '[] = GL.TypeError ('GL.Text "ToGuardsDetailT cannot be empty") + +-- | leverages 'RepeatT' for repeating predicates (passthrough method) +-- +-- >>> pz @(GuardsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,256] +-- FailT "id=3 must be between 0 and 255, found 256" +-- +-- >>> pz @(GuardsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,44] +-- PresentT [121,33,7,44] +-- +data GuardsN prt (n :: Nat) p +type GuardsNT prt (n :: Nat) p = Guards (ToGuardsT prt (RepeatT n p)) + +instance ( x ~ [a] + , P (GuardsNT prt n p) x + ) => P (GuardsN prt n p) x where + type PP (GuardsN prt n p) x = PP (GuardsNT prt n p) x + eval _ = eval (Proxy @(GuardsNT prt n p)) + +-- | \'p\' is the predicate and on failure of the predicate runs \'prt\' +-- +-- >>> pz @(Guard "expected > 3" (Gt 3)) 17 +-- PresentT 17 +-- +-- >>> pz @(Guard "expected > 3" (Gt 3)) 1 +-- FailT "expected > 3" +-- +-- >>> pz @(Guard (PrintF "%d not > 3" Id) (Gt 3)) (-99) +-- FailT "-99 not > 3" +-- +data Guard prt p + +data ExitWhen prt p +type ExitWhenT prt p = Guard prt (Not p) + +instance P (ExitWhenT prt p) x => P (ExitWhen prt p) x where + type PP (ExitWhen prt p) x = PP (ExitWhenT prt p) x + eval _ = eval (Proxy @(ExitWhenT prt p)) + +instance (Show a + , P prt a + , PP prt a ~ String + , P p a + , PP p a ~ Bool + ) => P (Guard prt p) a where + type PP (Guard prt p) a = a + eval _ opts a = do + let msg0 = "Guard" + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts a + pure $ case getValueLR opts (msg0 <> " Msg") qq [hh pp] of + Left e -> e + Right ee -> mkNode opts (FailT ee) (msg0 <> " | " <> showL opts a) (hh pp : [hh qq | isVerbose opts]) + Right True -> pure $ mkNode opts (PresentT a) (msg0 <> "(ok)" <> " | " <> showL opts a) [hh pp] -- dont show the guard message if successful + + +-- | similar to 'Guard' but uses the root message of the False predicate case as the failure message +-- +-- most uses of GuardSimple can be replaced by a boolean predicate unless you require a failure message instead of true/false +-- +-- >>> pz @(GuardSimple (Luhn Id)) [1..4] +-- FailT "(Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4])" +-- +-- >>> pl @(Luhn Id) [1..4] +-- False (Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4]) +-- FalseT +-- +-- >>> pz @(GuardSimple (Luhn Id)) [1,2,3,0] +-- PresentT [1,2,3,0] +-- +-- >>> pz @(GuardSimple (Len > 30)) [1,2,3,0] +-- FailT "(4 > 30)" +-- +data GuardSimple p + +instance (Show a + , P p a + , PP p a ~ Bool + ) => P (GuardSimple p) a where + type PP (GuardSimple p) a = a + eval _ opts a = do + let msg0 = "GuardSimple" + pp <- evalBool (Proxy @p) (subopts opts) a -- temporarily lift DZero to DLite so as not to lose the failure message + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right False -> + let msgx = topMessage pp + in mkNode opts (FailT msgx) (msg0 <> " | " <> showL opts a) [hh pp] + Right True -> + mkNode opts (PresentT a) (msg0 <> "(ok)" <> " | " <> showL opts a) [hh pp] + + +-- | just run the effect but skip the value +-- for example for use with Stdout so it doesnt interfere with the \'a\' on the rhs unless there is an failure +data Skip p + +instance ( Show (PP p a) + , P p a + ) => P (Skip p) a where + type PP (Skip p) a = a + eval _ opts a = do + let msg0 = "Skip" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts p) [hh pp] + +data p |> q +type SkipLT p q = Skip p >> q +infixr 1 |> + +instance P (SkipLT p q) x => P (p |> q) x where + type PP (p |> q) x = PP (SkipLT p q) x + eval _ = eval (Proxy @(SkipLT p q)) + +data p >| q +type SkipRT p q = p >> Skip q +infixr 1 >| + +instance P (SkipRT p q) x => P (p >| q) x where + type PP (p >| q) x = PP (SkipRT p q) x + eval _ = eval (Proxy @(SkipRT p q)) + +data p >|> q +type SkipBothT p q = Skip p >> Skip q +infixr 1 >|> + +instance P (SkipBothT p q) x => P (p >|> q) x where + type PP (p >|> q) x = PP (SkipBothT p q) x + eval _ = eval (Proxy @(SkipBothT p q)) + +-- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' + +-- | This is composition for predicates +-- +-- >>> pz @(Fst Id >> Succ (Id !! 0)) ([11,12],'x') +-- PresentT 12 +-- +-- >>> pz @(Len *** Succ Id >> ShowP (First (Pred Id))) ([11,12],'x') +-- PresentT "(1,'y')" +-- +data p >> q +infixr 1 >> + +instance (Show (PP p a) + , Show (PP q (PP p a)) + , P p a + , P q (PP p a) + ) => P (p >> q) a where + type PP (p >> q) a = PP q (PP p a) + eval _ opts a = do + let msg0 = "(>>)" + pp <- eval (Proxy @p) opts a + case getValueLR opts "(>>) lhs failed" pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts p + pure $ case getValueLR opts (show p <> " (>>) rhs failed") qq [hh pp] of + Left e -> e + Right q -> mkNode opts (_tBool qq) (lit01 opts msg0 q "" (topMessageEgregious qq)) [hh pp, hh qq] + +-- bearbeiten! only used by >> +topMessageEgregious :: TT a -> String +topMessageEgregious pp = innermost (pp ^. tString) + where innermost = ('{':) . reverse . ('}':) . takeWhile (/='{') . dropWhile (=='}') . reverse + +data p << q +type LeftArrowsT p q = q >> p +infixr 1 << + +instance P (LeftArrowsT p q) x => P (p << q) x where + type PP (p << q) x = PP (LeftArrowsT p q) x + eval _ = eval (Proxy @(LeftArrowsT p q)) + +type p >>> q = p >> q +infixl 1 >>> + +-- | similar to 'Prelude.&&' +-- +-- >>> pz @(Fst Id && Snd Id) (True, True) +-- TrueT +-- +-- >>> pz @(Id > 15 && Id < 17) 16 +-- TrueT +-- +-- >>> pz @(Id > 15 && Id < 17) 30 +-- FalseT +-- +-- >>> pz @(Fst Id && (Length (Snd Id) >= 4)) (True,[11,12,13,14]) +-- TrueT +-- +-- >>> pz @(Fst Id && (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- FalseT +-- +data p && q +infixr 3 && + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p && q) a where + type PP (p && q) a = Bool + eval _ opts a = do + let msg0 = "&&" + lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let zz = case (p,q) of + (True, True) -> "" + (False, True) -> topMessage pp + (True, False) -> topMessage qq + (False, False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + in mkNodeB opts (p&&q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> (if null zz then zz else " | " <> zz)) [hh pp, hh qq] + +-- | short circuit version of boolean And +-- +-- >>> pl @(Id > 10 &&~ Failt _ "ss") 9 +-- False (False &&~ _ | (9 > 10)) +-- FalseT +-- +-- >>> pl @(Id > 10 &&~ Id == 12) 11 +-- False (True &&~ False | (11 == 12)) +-- FalseT +-- +-- >>> pl @(Id > 10 &&~ Id == 11) 11 +-- True (True &&~ True) +-- TrueT +-- +data p &&~ q +infixr 3 &&~ + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p &&~ q) a where + type PP (p &&~ q) a = Bool + eval _ opts a = do + let msg0 = "&&~" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right False -> + pure $ mkNodeB opts False ("False" <> " " <> msg0 <> " _" <> litVerbose opts " | " (topMessage pp)) [hh pp] + Right True -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right q -> + let zz = if q then "" + else " | " <> topMessage qq + in mkNodeB opts q ("True" <> " " <> msg0 <> " " <> showL opts q <> litVerbose opts "" zz) [hh pp, hh qq] + +-- | similar to 'Prelude.||' +-- +-- >>> pz @(Fst Id || (Length (Snd Id) >= 4)) (False,[11,12,13,14]) +-- TrueT +-- +-- >>> pz @(Not (Fst Id) || (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- FalseT +-- +data p || q +infixr 2 || + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p || q) a where + type PP (p || q) a = Bool + eval _ opts a = do + let msg0 = "||" + lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let zz = case (p,q) of + (False,False) -> " | " <> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + _ -> "" + in mkNodeB opts (p||q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> zz) [hh pp, hh qq] + +-- | short circuit version of boolean Or +-- +-- >>> pl @(Id > 10 ||~ Failt _ "ss") 11 +-- True (True ||~ _ | (11 > 10)) +-- TrueT +-- +-- >>> pz @(Id > 10 ||~ Id == 9) 9 +-- TrueT +-- +-- >>> pl @(Id > 10 ||~ Id > 9) 9 +-- False (False ||~ False | (9 > 10) ||~ (9 > 9)) +-- FalseT +-- +data p ||~ q +infixr 2 ||~ + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p ||~ q) a where + type PP (p ||~ q) a = Bool + eval _ opts a = do + let msg0 = "||~" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right q -> + let zz = if q then "" + else " | " <> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + in mkNodeB opts q ("False" <> " " <> msg0 <> " " <> showL opts q <> litVerbose opts "" zz) [hh pp, hh qq] + Right True -> + pure $ mkNodeB opts True ("True" <> " " <> msg0 <> " _" <> litVerbose opts " | " (topMessage pp)) [hh pp] + +-- | implication +-- +-- >>> pz @(Fst Id ~> (Length (Snd Id) >= 4)) (True,[11,12,13,14]) +-- TrueT +-- +-- >>> pz @(Fst Id ~> (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- FalseT +-- +-- >>> pz @(Fst Id ~> (Length (Snd Id) == 4)) (False,[12,11,12,13,14]) +-- TrueT +-- +-- >>> pz @(Fst Id ~> (Length (Snd Id) >= 4)) (False,[11,12,13,14]) +-- TrueT +-- +data p ~> q +infixr 1 ~> + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p ~> q) a where + type PP (p ~> q) a = Bool + eval _ opts a = do + let msg0 = "~>" + lr <- runPQBool msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let zz = case (p,q) of + (True,False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + _ -> "" + in mkNodeB opts (p~>q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> (if null zz then zz else " | " <> zz)) [hh pp, hh qq] + +-- | 'not' function +-- +-- >>> pz @(Not Id) False +-- TrueT +-- +-- >>> pz @(Not Id) True +-- FalseT +-- +-- >>> pz @(Not (Fst Id)) (True,22) +-- FalseT +-- +-- >>> pl @(Not (Lt 3)) 13 +-- True (Not (13 < 3)) +-- TrueT +-- +data Not p + +instance ( PP p x ~ Bool + , P p x + ) => P (Not p) x where + type PP (Not p) x = Bool + eval _ opts x = do + let msg0 = "Not" + pp <- evalBool (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = not p + in mkNodeB opts b (msg0 <> litVerbose opts " " (topMessage pp)) [hh pp] + +-- | 'id' function on a boolean +-- +-- >>> pz @(IdBool Id) False +-- FalseT +-- +-- >>> pz @(IdBool Id) True +-- TrueT +-- +-- >>> pz @(IdBool (Fst Id)) (True,22) +-- TrueT +-- +-- >>> pl @(IdBool (Lt 3)) 13 +-- False (IdBool (13 < 3)) +-- FalseT +-- +data IdBool p + +instance ( PP p x ~ Bool + , P p x + ) => P (IdBool p) x where + type PP (IdBool p) x = Bool + eval _ opts x = do + let msg0 = "IdBool" + pp <- evalBool (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = p + in mkNodeB opts b (msg0 <> litVerbose opts " " (topMessage pp)) [hh pp] + +-- | similar to 'compare' +-- +-- >>> pz @(Fst Id ==! Snd Id) (10,9) +-- PresentT GT +-- +-- >>> pz @(14 % 3 ==! Fst Id -% Snd Id) (-10,7) +-- PresentT GT +-- +-- >>> pz @(Fst Id ==! Snd Id) (10,11) +-- PresentT LT +-- +-- >>> pz @(Snd Id ==! (Fst Id >> Snd Id >> Head Id)) (('x',[10,12,13]),10) +-- PresentT EQ +-- +-- >>> pz @(Snd Id ==! Head (Snd (Fst Id))) (('x',[10,12,13]),10) +-- PresentT EQ +-- + +data p ==! q +infix 4 ==! + +type OrdP p q = p ==! q + +instance (Ord (PP p a) + , PP p a ~ PP q a + , P p a + , Show (PP q a) + , P q a + ) => P (p ==! q) a where + type PP (p ==! q) a = Ordering + eval _ opts a = do + let msg0 = "(==!)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = compare p q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts p <> " " <> prettyOrd d <> " " <> showL opts q) [hh pp, hh qq] + +data OrdA p + +instance P (OrdA' p p) x => P (OrdA p) x where + type PP (OrdA p) x = PP (OrdA' p p) x + eval _ = eval (Proxy @(OrdA' p p)) + +data OrdA' p q +type OrdAT' p q = (Fst Id >> p) ==! (Snd Id >> q) + +instance P (OrdAT' p q) x => P (OrdA' p q) x where + type PP (OrdA' p q) x = PP (OrdAT' p q) x + eval _ = eval (Proxy @(OrdAT' p q)) + +-- | compare two strings ignoring case +-- +-- >>> pz @(Fst Id ===~ Snd Id) ("abC","aBc") +-- PresentT EQ +-- +-- >>> pz @(Fst Id ===~ Snd Id) ("abC","DaBc") +-- PresentT LT +-- +type OrdI p q = p ===~ q +data p ===~ q +infix 4 ===~ + +instance (PP p a ~ String + , PP p a ~ PP q a + , P p a + , P q a + ) => P (p ===~ q) a where + type PP (p ===~ q) a = Ordering + eval _ opts a = do + let msg0 = "(===~)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = on compare (map toLower) p q + in mkNode opts (PresentT d) (msg0 <> " " <> p <> " " <> prettyOrd d <> " " <> q) [hh pp, hh qq] + +-- | compare two values using the given ordering \'o\' +-- +-- >>> pl @(Lt 4) 123 +-- False (123 < 4) +-- FalseT +-- +-- >>> pl @(Lt 4) 1 +-- True (1 < 4) +-- TrueT +-- +-- >>> pl @(Negate 7 <..> 20) (-4) +-- True (-7 <= -4 <= 20) +-- TrueT +-- +-- >>> pl @(Negate 7 <..> 20) 21 +-- False (21 <= 20) +-- FalseT +-- +data Cmp (o :: OrderingP) p q + +instance (GetOrd o + , Ord (PP p a) + , Show (PP p a) + , PP p a ~ PP q a + , P p a + , P q a + ) => P (Cmp o p q) a where + type PP (Cmp o p q) a = Bool + eval _ opts a = do + let (sfn, fn) = getOrd @o + lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = fn p q + in mkNodeB opts b (showL opts p <> " " <> sfn <> " " <> showL opts q) [hh pp, hh qq] + +-- | compare two strings ignoring case using the given ordering \'o\' +data CmpI (o :: OrderingP) p q + +instance (PP p a ~ String + , GetOrd o + , PP p a ~ PP q a + , P p a + , P q a + ) => P (CmpI o p q) a where + type PP (CmpI o p q) a = Bool + eval _ opts a = do + let (sfn, fn) = getOrd @o + lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = on fn (map toLower) p q + in mkNodeB opts b ("CmpI " <> p <> " " <> sfn <> " " <> q) [hh pp, hh qq] + + +-- | similar to 'Control.Lens.itoList' +-- +-- >>> pz @(IToList _ Id) ("aBc" :: String) +-- PresentT [(0,'a'),(1,'B'),(2,'c')] +-- +data IToList' t p + +instance (Show x + , P p x + , Typeable (PP t (PP p x)) + , Show (PP t (PP p x)) + , FoldableWithIndex (PP t (PP p x)) f + , PP p x ~ f a + , Show a + ) => P (IToList' t p) x where + type PP (IToList' t p) x = [(PP t (PP p x), ExtractAFromTA (PP p x))] + eval _ opts x = do + let msg0 = "IToList" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = itoList p + t = showT @(PP t (PP p x)) + in mkNode opts (PresentT b) (msg0 <> "(" <> t <> ")" <> " " <> showL opts b <> showVerbose opts " | " x) [hh pp] + +data IToList (t :: Type) p +type IToListT (t :: Type) p = IToList' (Hole t) p + +instance P (IToListT t p) x => P (IToList t p) x where + type PP (IToList t p) x = PP (IToListT t p) x + eval _ = eval (Proxy @(IToListT t p)) + +-- | similar to 'toList' +-- +-- >>> pz @ToList ("aBc" :: String) +-- PresentT "aBc" +-- +-- >>> pz @ToList (Just 14) +-- PresentT [14] +-- +-- >>> pz @ToList Nothing +-- PresentT [] +-- +-- >>> pz @ToList (Left "xx") +-- PresentT [] +-- +-- >>> pz @ToList (These 12 "xx") +-- PresentT ["xx"] +-- +data ToList +instance (Show (t a) + , Foldable t + ) => P ToList (t a) where + type PP ToList (t a) = [a] + eval _ opts as = + let msg0 = "ToList" + z = toList as + in pure $ mkNode opts (PresentT z) (msg0 <> showVerbose opts " " as) [] + +-- | similar to 'toList' +-- +-- >>> pz @(ToList' Id) ("aBc" :: String) +-- PresentT "aBc" +-- +-- >>> pz @(ToList' Id) (Just 14) +-- PresentT [14] +-- +-- >>> pz @(ToList' Id) Nothing +-- PresentT [] +-- +-- >>> pz @(ToList' Id) (Left "xx") +-- PresentT [] +-- +-- >>> pz @(ToList' Id) (These 12 "xx") +-- PresentT ["xx"] +-- +data ToList' p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , Show a + ) => P (ToList' p) x where + type PP (ToList' p) x = [ExtractAFromTA (PP p x)] -- extra layer of indirection means pan (ToList' Id) "abc" won't work without setting the type of "abc" unlike ToList + eval _ opts x = do + let msg0 = "ToList'" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let hhs = [hh pp] + b = toList p + in mkNode opts (PresentT b) (show01 opts msg0 b p) hhs + +-- | invokes 'GE.toList' +-- +-- >>> pz @ToListExt (M.fromList [(1,'x'),(4,'y')]) +-- PresentT [(1,'x'),(4,'y')] +-- +-- >>> pz @ToListExt (T.pack "abc") +-- PresentT "abc" +-- +data ToListExt + +instance (Show l + , GE.IsList l + , Show (GE.Item l) + ) => P ToListExt l where + type PP ToListExt l = [GE.Item l] + eval _ opts as = + let msg0 = "ToListExt" + z = GE.toList as + in pure $ mkNode opts (PresentT z) (show01 opts msg0 z as) [] + +-- | invokes 'GE.fromList' +-- +-- >>> import qualified Data.Set as Set +-- >>> run @('OMsg "Fred" ':# 'OLite ':# 'OColorOff) @(FromList (Set.Set Int) << '[2,1,5,5,2,5,2]) () +-- Fred >>> Present fromList [1,2,5] ((>>) fromList [1,2,5] | {FromList fromList [1,2,5]}) +-- PresentT (fromList [1,2,5]) +-- +data FromList (t :: Type) -- doesnt work with OverloadedLists unless you cast to [a] explicitly + +instance (a ~ GE.Item t + , Show t + , GE.IsList t + , [a] ~ x + ) => P (FromList t) x where + type PP (FromList t) x = t + eval _ opts as = + let msg0 = "FromList" + z = GE.fromList (as :: [GE.Item t]) :: t + in pure $ mkNode opts (PresentT z) (msg0 <> " " <> showL opts z) [] + +-- | invokes 'GE.fromList' +-- +-- requires the OverloadedLists extension +-- +-- >>> :set -XOverloadedLists +-- >>> pz @(FromListExt (M.Map _ _)) [(4,"x"),(5,"dd")] +-- PresentT (fromList [(4,"x"),(5,"dd")]) +-- +data FromListExt (t :: Type) +-- l ~ l' is key +instance (Show l + , GE.IsList l + , l ~ l' + ) => P (FromListExt l') l where + type PP (FromListExt l') l = l' + eval _ opts as = + let msg0 = "FromListExt" + z = GE.fromList (GE.toList @l as) + in pure $ mkNode opts (PresentT z) (msg0 <> " " <> showL opts z) [] + +-- | predicate on 'These' +-- +-- >>> pz @(IsThis Id) (This "aBc") +-- TrueT +-- +-- >>> pz @(IsThis Id) (These 1 'a') +-- FalseT +-- +-- >>> pz @(IsThese Id) (These 1 'a') +-- TrueT +-- +-- >>> pl @(IsThat Id) (This 12) +-- False (IsThat | This 12) +-- FalseT +-- +-- >>> pl @(IsThis Id) (This 12) +-- True (IsThis | This 12) +-- TrueT +-- +-- >>> pl @(IsThese Id) (This 12) +-- False (IsThese | This 12) +-- FalseT +-- +-- >>> pl @(IsThese Id) (These 'x' 12) +-- True (IsThese | These 'x' 12) +-- TrueT +-- +data IsTh (th :: These x y) p -- x y can be anything + +-- trying to avoid show instance cos of ambiguities +instance (PP p x ~ These a b + , P p x + , Show a + , Show b + , GetThese th + ) => P (IsTh (th :: These x1 x2) p) x where + type PP (IsTh th p) x = Bool + eval _ opts x = do + let msg0 = "Is" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (t,f) = getThese @th + b = f p + in mkNodeB opts b (msg0 <> t <> showVerbose opts " | " p) [hh pp] + +data IsThis p +type IsThisT p = IsTh ('This '()) p + +instance P (IsThisT p) x => P (IsThis p) x where + type PP (IsThis p) x = PP (IsThisT p) x + eval _ = evalBool (Proxy @(IsThisT p)) + +data IsThat p +type IsThatT p = IsTh ('That '()) p + +instance P (IsThatT p) x => P (IsThat p) x where + type PP (IsThat p) x = PP (IsThatT p) x + eval _ = evalBool (Proxy @(IsThatT p)) + +data IsThese p +type IsTheseT p = IsTh ('These '() '()) p + +instance P (IsTheseT p) x => P (IsThese p) x where + type PP (IsThese p) x = PP (IsTheseT p) x + eval _ = evalBool (Proxy @(IsTheseT p)) + +-- | similar to 'Data.These.these' +-- +-- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (This 13) +-- PresentT 13 +-- +-- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (That "this is a long string") +-- PresentT 21 +-- +-- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (These 20 "somedata") +-- PresentT 28 +-- +-- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (That "this is a long string") +-- PresentT (Right "this is a long string") +-- +-- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 1 "this is a long string") +-- PresentT (Right "this is a long string") +-- +-- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 100 "this is a long string") +-- PresentT (Left 100) +-- +data TheseIn p q r + +instance (Show a + , Show b + , Show (PP p a) + , P p a + , P q b + , P r (a,b) + , PP p a ~ PP q b + , PP p a ~ PP r (a,b) + , PP q b ~ PP r (a,b) + ) => P (TheseIn p q r) (These a b) where + type PP (TheseIn p q r) (These a b) = PP p a + eval _ opts th = do + let msg0 = "TheseIn" + case th of + This a -> do + let msg1 = "This " + msg2 = msg0 <> msg1 + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts (msg2 <> "p failed") pp [] of + Left e -> e + Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 a) [hh pp] + That b -> do + let msg1 = "That " + msg2 = msg0 <> msg1 + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts (msg2 <> "q failed") qq [] of + Left e -> e + Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 b) [hh qq] + These a b -> do + let msg1 = "These " + msg2 = msg0 <> msg1 + rr <- eval (Proxy @r) opts (a,b) + pure $ case getValueLR opts (msg2 <> "r failed") rr [] of + Left e -> e + Right c -> mkNode opts (PresentT c) (show01 opts msg0 c (These a b)) [hh rr] + +data TheseId p q +type TheseIdT p q = TheseIn '(I, p) '(q, I) I + +instance P (TheseIdT p q) x => P (TheseId p q) x where + type PP (TheseId p q) x = PP (TheseIdT p q) x + eval _ = eval (Proxy @(TheseIdT p q)) +-- | creates an empty list of the given type +-- +-- >>> pz @(Id :+ EmptyList _) 99 +-- PresentT [99] +-- +data EmptyList' t + +instance P (EmptyList' t) x where + type PP (EmptyList' t) x = [PP t x] + eval _ opts _ = + pure $ mkNode opts (PresentT []) "EmptyList" [] + +data EmptyList (t :: Type) +type EmptyListT (t :: Type) = EmptyList' (Hole t) + +instance P (EmptyList t) x where + type PP (EmptyList t) x = PP (EmptyListT t) x + eval _ = eval (Proxy @(EmptyListT t)) + +-- | creates a singleton from a value +-- +-- >>> pz @(Singleton (Char1 "aBc")) () +-- PresentT "a" +-- +-- >>> pz @(Singleton Id) False +-- PresentT [False] +-- +-- >>> pz @(Singleton (Snd Id)) (False,"hello") +-- PresentT ["hello"] +-- +data Singleton p + +instance P p x => P (Singleton p) x where + type PP (Singleton p) x = [PP p x] + eval _ opts x = do + let msg0 = "Singleton" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> mkNode opts (PresentT [p]) msg0 [hh pp] + +--type Singleton p = p :+ EmptyT [] p + +-- | extracts the first character from a non empty 'Symbol' +-- +-- >>> pz @(Char1 "aBc") () +-- PresentT 'a' +-- +data Char1 (s :: Symbol) -- gets the first char from the Symbol [requires that Symbol is not empty] +instance ( KnownSymbol s + , GL.CmpSymbol s "" ~ 'GT + ) => P (Char1 s) a where + type PP (Char1 s) a = Char + eval _ opts _ = + case symb @s of + [] -> errorInProgram "Char1: found empty Symbol/string" + c:_ -> pure $ mkNode opts (PresentT c) ("Char1" <> " " <> showL opts c) [] + +-- | similar to 'Data.Align.align' thats pads with 'Data.These.This' or 'Data.These.That' if one list is shorter than the other +-- +-- the key is that all information about both lists are preserved +-- +-- >>> pz @(ZipThese (Fst Id) (Snd Id)) ("aBc", [1..5]) +-- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] +-- +-- >>> pz @(ZipThese (Fst Id) (Snd Id)) ("aBcDeF", [1..3]) +-- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] +-- +-- >>> pz @(ZipThese Id Reverse) "aBcDeF" +-- PresentT [These 'a' 'F',These 'B' 'e',These 'c' 'D',These 'D' 'c',These 'e' 'B',These 'F' 'a'] +-- +-- >>> pz @(ZipThese Id '[]) "aBcDeF" +-- PresentT [This 'a',This 'B',This 'c',This 'D',This 'e',This 'F'] +-- +-- >>> pz @(ZipThese '[] Id) "aBcDeF" +-- PresentT [That 'a',That 'B',That 'c',That 'D',That 'e',That 'F'] +-- +-- >>> pz @(ZipThese '[] '[]) "aBcDeF" +-- PresentT [] +-- +data ZipThese p q + +instance (PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (ZipThese p q) a where + type PP (ZipThese p q) a = [These (ExtractAFromList (PP p a)) (ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "ZipThese" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> e + Right () -> + let d = simpleAlign p q + in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs + +simpleAlign :: [a] -> [b] -> [These a b] +simpleAlign as [] = map This as +simpleAlign [] bs = map That bs +simpleAlign (a:as) (b:bs) = These a b : simpleAlign as bs + +type family ExtractAFromTA (ta :: Type) :: Type where + ExtractAFromTA (t a) = a + ExtractAFromTA z = GL.TypeError ( + 'GL.Text "ExtractAFromTA: expected (t a) but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType z) + +-- todo: get ExtractAFromList failure to fire if wrong Type +-- | extract \'a\' from \'[a]\' which I need for type PP +type family ExtractAFromList (as :: Type) :: Type where + ExtractAFromList [a] = a + ExtractAFromList z = GL.TypeError ( + 'GL.Text "ExtractAFromList: expected [a] but found something else" + ':$$: 'GL.Text "as = " + ':<>: 'GL.ShowType z) + + +-- | Zip two lists to their maximum length using padding if needed +-- +-- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abc", [1..5]) +-- PresentT [('a',1),('b',2),('c',3),('Z',4),('Z',5)] +-- +-- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcdefg", [1..5]) +-- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5),('f',99),('g',99)] +-- +-- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcde", [1..5]) +-- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5)] +-- +-- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("", [1..5]) +-- PresentT [('Z',1),('Z',2),('Z',3),('Z',4),('Z',5)] +-- +-- >>> pz @(ZipPad (Char1 "Z") 99 (Fst Id) (Snd Id)) ("abcde", []) +-- PresentT [('a',99),('b',99),('c',99),('d',99),('e',99)] +-- +data ZipPad l r p q + +instance (PP l a ~ x + , PP r a ~ y + , P l a + , P r a + , PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (ZipPad l r p q) a where + type PP (ZipPad l r p q) a = [(PP l a, PP r a)] + eval _ opts a = do + let msg0 = "ZipPad" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> pure e + Right () -> do + let lls = (length p,length q) + case uncurry compare lls of + LT -> do + ll <- eval (Proxy @l) opts a + pure $ case getValueLR opts (msg0 <> " l failed") ll hhs of + Left e -> e + Right l -> + let d = zip (p ++ repeat l) q + in mkNode opts (PresentT d) (show01' opts (msg0 <> " Left pad") d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh ll]) + GT -> do + rr <- eval (Proxy @r) opts a + pure $ case getValueLR opts (msg0 <> " r failed") rr hhs of + Left e -> e + Right r -> + let d =zip p (q ++ repeat r) + in mkNode opts (PresentT d) (show01' opts (msg0 <> " Right pad") d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh rr]) + EQ -> + let d = zip p q + in pure $ mkNode opts (PresentT d) (show01' opts (msg0 <> " No pad") d "p=" p <> showVerbose opts " | q=" q) hhs + + +-- | zip two lists padding the left hand side if needed +-- +-- >>> pl @(ZipL 99 '[1,2,3] "abc") () +-- Present [(1,'a'),(2,'b'),(3,'c')] (ZipL [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") +-- PresentT [(1,'a'),(2,'b'),(3,'c')] +-- +-- >>> pl @(ZipL 99 '[1,2] "abc") () +-- Present [(1,'a'),(2,'b'),(99,'c')] (ZipL [(1,'a'),(2,'b'),(99,'c')] | p=[1,2] | q="abc") +-- PresentT [(1,'a'),(2,'b'),(99,'c')] +-- +-- >>> pl @(ZipL 99 '[1] "abc") () +-- Present [(1,'a'),(99,'b'),(99,'c')] (ZipL [(1,'a'),(99,'b'),(99,'c')] | p=[1] | q="abc") +-- PresentT [(1,'a'),(99,'b'),(99,'c')] +-- +-- >>> pl @(ZipL 99 '[1,2,3] "ab") () +-- Error ZipL(3,2) rhs would be truncated (p=[1,2,3] | q="ab") +-- FailT "ZipL(3,2) rhs would be truncated" +-- +data ZipL l p q +instance (PP l a ~ x + , P l a + , PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (ZipL l p q) a where + type PP (ZipL l p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "ZipL" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> pure e + Right () -> do + let lls = (length p,length q) + case uncurry compare lls of + GT -> let msg1 = msg0 ++ show lls + in pure $ mkNode opts (FailT (msg1 ++ " rhs would be truncated")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + _ -> do + ll <- eval (Proxy @l) opts a + pure $ case getValueLR opts (msg0 <> " l failed") ll hhs of + Left e -> e + Right l -> + let d = zip (p ++ repeat l) q + in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh ll]) + +-- | zip two lists padding the right hand side if needed +-- +-- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "abc") () +-- Present [(1,'a'),(2,'b'),(3,'c')] (ZipR [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") +-- PresentT [(1,'a'),(2,'b'),(3,'c')] +-- +-- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "ab") () +-- Present [(1,'a'),(2,'b'),(3,'Z')] (ZipR [(1,'a'),(2,'b'),(3,'Z')] | p=[1,2,3] | q="ab") +-- PresentT [(1,'a'),(2,'b'),(3,'Z')] +-- +-- >>> pl @(ZipR (Char1 "Z") '[1,2,3] "a") () +-- Present [(1,'a'),(2,'Z'),(3,'Z')] (ZipR [(1,'a'),(2,'Z'),(3,'Z')] | p=[1,2,3] | q="a") +-- PresentT [(1,'a'),(2,'Z'),(3,'Z')] +-- +-- >>> pl @(ZipR (Char1 "Z") '[1,2] "abc") () +-- Error ZipR(2,3) rhs would be truncated (p=[1,2] | q="abc") +-- FailT "ZipR(2,3) rhs would be truncated" +-- +data ZipR r p q +instance (PP r a ~ y + , P r a + , PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (ZipR r p q) a where + type PP (ZipR r p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "ZipR" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> pure e + Right () -> do + let lls = (length p,length q) + case uncurry compare lls of + LT -> let msg1 = msg0 ++ show lls + in pure $ mkNode opts (FailT (msg1 ++ " rhs would be truncated")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + _ -> do + rr <- eval (Proxy @r) opts a + pure $ case getValueLR opts (msg0 <> " l failed") rr hhs of + Left e -> e + Right r -> + let d = zip p (q ++ repeat r) + in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh rr]) + +-- | zip two lists with the same length +-- +-- >>> pl @(Zip '[1,2,3] "abc") () +-- Present [(1,'a'),(2,'b'),(3,'c')] (Zip [(1,'a'),(2,'b'),(3,'c')] | p=[1,2,3] | q="abc") +-- PresentT [(1,'a'),(2,'b'),(3,'c')] +-- +-- >>> pl @(Zip '[1,2,3] "ab") () +-- Error Zip(3,2) length mismatch (p=[1,2,3] | q="ab") +-- FailT "Zip(3,2) length mismatch" +-- +-- >>> pl @(Zip '[1,2] "abc") () +-- Error Zip(2,3) length mismatch (p=[1,2] | q="abc") +-- FailT "Zip(2,3) length mismatch" +-- +data Zip p q +instance (PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (Zip p q) a where + type PP (Zip p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "Zip" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> e + Right () -> + let lls = (length p, length q) + in case uncurry compare lls of + EQ -> let d = zip p q + in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs + _ -> let msg1 = msg0 ++ show lls + in mkNode opts (FailT (msg1 <> " length mismatch")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + +-- | Luhn predicate check on last digit +-- +-- >>> pz @(Luhn Id) [1,2,3,0] +-- TrueT +-- +-- >>> pz @(Luhn Id) [1,2,3,4] +-- FalseT +-- +-- >>> pz @(GuardSimple (Luhn Id)) [15,4,3,1,99] +-- FailT "(Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99])" +-- +-- >>> pl @(Luhn Id) [15,4,3,1,99] +-- False (Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99]) +-- FalseT +-- +data Luhn p + +instance (PP p x ~ [Int] + , P p x + ) => P (Luhn p) x where + type PP (Luhn p) x = Bool + eval _ opts x = do + let msg0 = "Luhn" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let xs = zipWith (*) (reverse p) (cycle [1,2]) + ys = map (\w -> if w>=10 then w-9 else w) xs + z = sum ys + ret = z `mod` 10 + hhs = [hh pp] + in if ret == 0 then mkNodeB opts True (msg0 <> " | " <> showL opts p) hhs + else mkNodeB opts False (msg0 <> " map=" <> showL opts ys <> " sum=" <> showL opts z <> " ret=" <> showL opts ret <> showVerbose opts " | " p) hhs + +-- | Read a number using base 2 through a maximum of 36 +-- +-- >>> pz @(ReadBase Int 16 Id) "00feD" +-- PresentT 4077 +-- +-- >>> pz @(ReadBase Int 16 Id) "-ff" +-- PresentT (-255) +-- +-- >>> pz @(ReadBase Int 2 Id) "10010011" +-- PresentT 147 +-- +-- >>> pz @(ReadBase Int 8 Id) "Abff" +-- FailT "invalid base 8" +-- +-- >>> pl @(ReadBase Int 16 Id >> GuardSimple (Id > 0xffff) >> ShowBase 16 Id) "12344" +-- Present "12344" ((>>) "12344" | {ShowBase(16) 12344 | 74564}) +-- PresentT "12344" +-- +-- >>> :set -XBinaryLiterals +-- >>> pz @(ReadBase Int 16 Id >> GuardSimple (Id > 0b10011111) >> ShowBase 16 Id) "7f" +-- FailT "(127 > 159)" +-- + +-- supports negative numbers unlike readInt +data ReadBase' t (n :: Nat) p + +instance (Typeable (PP t x) + , ZwischenT 2 36 n + , Show (PP t x) + , Num (PP t x) + , KnownNat n + , PP p x ~ String + , P p x + ) => P (ReadBase' t n p) x where + type PP (ReadBase' t n p) x = PP t x + eval _ opts x = do + let n = nat @n + xs = getValidBase n + msg0 = "ReadBase(" <> t <> "," <> show n <> ")" + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (ff,p1) = case p of + '-':q -> (negate,q) + _ -> (id,p) + in case Numeric.readInt (fromIntegral n) + ((`elem` xs) . toLower) + (fromJust . (`elemIndex` xs) . toLower) + p1 of + [(b,"")] -> mkNode opts (PresentT (ff b)) (msg0 <> " " <> showL opts (ff b) <> showVerbose opts " | " p) [hh pp] + o -> mkNode opts (FailT ("invalid base " <> show n)) (msg0 <> " as=" <> p <> " err=" <> showL opts o) [hh pp] + +data ReadBase (t :: Type) (n :: Nat) p +type ReadBaseT (t :: Type) (n :: Nat) p = ReadBase' (Hole t) n p + +instance P (ReadBaseT t n p) x => P (ReadBase t n p) x where + type PP (ReadBase t n p) x = PP (ReadBaseT t n p) x + eval _ = eval (Proxy @(ReadBaseT t n p)) + +getValidBase :: Int -> String +getValidBase n = + let xs = ['0'..'9'] <> ['a'..'z'] + len = length xs + in if n > len || n < 2 then errorInProgram $ "getValidBase: oops invalid base valid is 2 thru " ++ show len ++ " found " ++ show n + else take n xs + +-- | Display a number at base 2 to 36, similar to 'showIntAtBase' but supports signed numbers +-- +-- >>> pz @(ShowBase 16 Id) 4077 +-- PresentT "fed" +-- +-- >>> pz @(ShowBase 16 Id) (-255) +-- PresentT "-ff" +-- +-- >>> pz @(ShowBase 2 Id) 147 +-- PresentT "10010011" +-- +-- >>> pz @(ShowBase 2 (Negate 147)) "whatever" +-- PresentT "-10010011" +-- +data ShowBase (n :: Nat) p + +instance (PP p x ~ a + , P p x + , Show a + , 2 GL.<= n + , n GL.<= 36 + , KnownNat n + , Integral a + ) => P (ShowBase n p) x where + type PP (ShowBase n p) x = String + eval _ opts x = do + let n = nat @n + xs = getValidBase n + msg0 = "ShowBase(" <> show n <> ")" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (ff,a') = if p < 0 then (('-':), abs p) else (id,p) + b = Numeric.showIntAtBase (fromIntegral n) (xs !!) a' "" + in mkNode opts (PresentT (ff b)) (msg0 <> " " <> litL opts (ff b) <> showVerbose opts " | " p) [hh pp] + +-- | intercalate two lists +-- +-- >>> pz @(Intercalate '["aB"] '["xxxx","yz","z","www","xyz"]) () +-- PresentT ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] +-- +-- >>> pz @(Intercalate '[W 99,Negate 98] Id) [1..5] +-- PresentT [1,99,-98,2,99,-98,3,99,-98,4,99,-98,5] +-- +-- >>> pz @(Intercalate '[99,100] Id) [1..5] +--PresentT [1,99,100,2,99,100,3,99,100,4,99,100,5] +-- +data Intercalate p q + +instance (PP p x ~ [a] + , PP q x ~ PP p x + , P p x + , P q x + , Show a + ) => P (Intercalate p q) x where + type PP (Intercalate p q) x = PP p x + eval _ opts x = do + let msg0 = "Intercalate" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case chkSize opts msg0 p hhs <* chkSize opts msg0 q hhs of + Left e -> e + Right () -> + let d = intercalate p (map pure q) + in mkNode opts (PresentT d) (show01 opts msg0 d p <> showVerbose opts " | " q) hhs + +-- | uses PrintF to format output for a single value +-- +-- >>> pz @(PrintF "value=%03d" Id) 12 +-- PresentT "value=012" +-- +-- >>> pz @(PrintF "%s" (Fst Id)) ("abc",'x') +-- PresentT "abc" +-- +-- >>> pz @(PrintF "%d" (Fst Id)) ("abc",'x') +-- FailT "PrintF (IO e=printf: bad formatting char 'd')" +-- +data PrintF s p + +instance (PrintfArg (PP p x) + , Show (PP p x) + , PP s x ~ String + , P s x + , P p x + ) => P (PrintF s p) x where + type PP (PrintF s p) x = String + eval _ opts x = do + let msg0 = "PrintF" + lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] + case lrx of + Left e -> pure e + Right (s,p,ss,pp) -> do + lr <- catchitNF @_ @E.SomeException (printf s p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " (" <> e <> ")")) (" " <> showL opts p <> " s=" <> s) [hh ss, hh pp] + Right ret -> mkNode opts (PresentT ret) (msg0 <> " [" <> "" <> litL opts ret <> "]" <> showVerbose opts " | p=" p <> litVerbose opts " | s=" s) [hh ss, hh pp] + +type family GuardsT (ps :: [k]) where + GuardsT '[] = '[] + GuardsT (p ': ps) = Guard "fromGuardsT" p ': GuardsT ps + +--type Guards' (ps :: [k]) = Para (GuardsT ps) + +--type ToGuards (prt :: k) (os :: [k1]) = Proxy (Guards (ToGuardsT prt os)) + +type family ToGuardsT (prt :: k) (os :: [k1]) :: [(k,k1)] where + ToGuardsT prt '[] = GL.TypeError ('GL.Text "ToGuardsT cannot be empty") + ToGuardsT prt '[p] = '(prt,p) : '[] + ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps + +-- | runs values in parallel unlike 'Do' which is serial +-- +-- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30] +-- PresentT [10,21,120] +-- +-- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30,40] +-- FailT "Para:invalid length(4) expected 3" +-- +data ParaImpl (n :: Nat) (os :: [k]) + +data Para (ps :: [k]) + +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out +instance ([a] ~ x + , GetLen ps + , P (ParaImpl (LenT ps) ps) x + ) => P (Para ps) x where + type PP (Para ps) x = PP (ParaImpl (LenT ps) ps) x + eval _ opts as = do + let msg0 = "Para" + n = getLen @ps + if n /= length as then + let msg1 = msg0 <> badLength as n + in pure $ mkNode opts (FailT msg1) "" [] + else eval (Proxy @(ParaImpl (LenT ps) ps)) opts as + +-- only allow non empty lists -- might need [a] ~ x but it seems fine +instance GL.TypeError ('GL.Text "ParaImpl '[] invalid: requires at least one value in the list") + => P (ParaImpl n ('[] :: [k])) x where + type PP (ParaImpl n ('[] :: [k])) x = Void + eval _ _ _ = errorInProgram "ParaImpl empty list" + +instance (Show (PP p a) + , KnownNat n + , Show a + , P p a + ) => P (ParaImpl n '[p]) [a] where + type PP (ParaImpl n '[p]) [a] = [PP p a] + eval _ opts as' = do + let msgbase0 = "Para" + msgbase1 = msgbase0 <> "(" <> show n <> ")" + n :: Int + n = nat @n + case as' of + [a] -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msgbase1 pp [] of + Left e -> e + -- showVerbose opts " " [b] fails but using 'b' is ok and (b : []) also works! + -- GE.List problem + Right b -> mkNode opts (PresentT [b]) (msgbase1 <> " " <> showL opts [b] <> showVerbose opts " | " a) [hh pp] + _ -> errorInProgram $ "ParaImpl base case should have exactly one element but found " ++ show as' + +instance (KnownNat n + , GetLen ps + , P p a + , P (ParaImpl n (p1 ': ps)) [a] + , PP (ParaImpl n (p1 ': ps)) [a] ~ [PP p a] + , Show a + , Show (PP p a) + ) + => P (ParaImpl n (p ': p1 ': ps)) [a] where + type PP (ParaImpl n (p ': p1 ': ps)) [a] = [PP p a] + eval _ opts as' = do + let cpos = n-pos-1 + msgbase0 = msgbase2 <> "(" <> showIndex cpos <> " of " <> show n <> ")" + msgbase1 = msgbase2 <> "(" <> showIndex cpos <> ")" + msgbase2 = "Para" + n = nat @n + pos = 1 + getLen @ps -- cos p1! + case as' of + a:as -> do + pp <- eval (Proxy @p) opts a + case getValueLR opts msgbase0 pp [] of + Left e -> pure e + Right b -> do + qq <- eval (Proxy @(ParaImpl n (p1 ': ps))) opts as + pure $ case getValueLR opts (msgbase1 <> " rhs failed " <> show b) qq [hh pp] of + Left e -> e + Right bs -> mkNode opts (PresentT (b:bs)) (msgbase1 <> " " <> showL opts (b:bs) <> showVerbose opts " | " as') [hh pp, hh qq] + _ -> errorInProgram "ParaImpl n+1 case has no data left" + +-- | leverages 'Para' for repeating predicates (passthrough method) +-- +-- >>> pz @(ParaN 4 (Succ Id)) [1..4] +-- PresentT [2,3,4,5] +-- +-- >>> pz @(ParaN 4 (Succ Id)) "azwxm" +-- FailT "Para:invalid length(5) expected 4" +-- +-- >>> pz @(ParaN 4 (Succ Id)) "azwx" +-- PresentT "b{xy" +-- +data ParaN (n :: Nat) p + +instance ( P (ParaImpl (LenT (RepeatT n p)) (RepeatT n p)) x + , GetLen (RepeatT n p) + , x ~ [a] + ) => P (ParaN n p) x where + type PP (ParaN n p) x = PP (Para (RepeatT n p)) x + eval _ = eval (Proxy @(Para (RepeatT n p))) + +-- | tries each predicate ps and on the first match runs the corresponding qs but if there is no match on ps then runs the fail case e +-- +-- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 50 +-- PresentT "50 is same50" +-- +-- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 9 +-- PresentT "9 is lt10" +-- +-- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 3 +-- PresentT "3 is lt4" +-- +-- >>> pz @(Case (Failt _ "asdf") '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 99 +-- FailT "asdf" +-- +-- >>> pz @(Case (FailS "asdf" >> Snd Id >> Unproxy) '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 99 +-- FailT "asdf" +-- +-- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "b" +-- PresentT "there" +-- +-- >>> pz @(Case (Failt _ "x") '[Id == "a",Id == "b"] '["hey","there"] Id) "a" +-- PresentT "hey" +-- +-- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "c" +-- FailT "x" +-- +data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +-- ps = conditions +-- qs = what to do [one to one +-- r = the value +-- e = otherwise -- leave til later +data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +data Case' (ps :: [k]) (qs :: [k1]) (r :: k2) +data Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) + +type CaseT' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd Id >> Failp "Case:no match") ps qs r +type CaseT'' s (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (FailCaseT s) ps qs r -- eg s= PrintF "%s" (ShowP Id) + +instance P (CaseT'' s ps qs r) x => P (Case'' s ps qs r) x where + type PP (Case'' s ps qs r) x = PP (CaseT'' s ps qs r) x + eval _ = eval (Proxy @(CaseT'' s ps qs r)) + +instance P (CaseT' ps qs r) x => P (Case' ps qs r) x where + type PP (Case' ps qs r) x = PP (CaseT' ps qs r) x + eval _ = eval (Proxy @(CaseT' ps qs r)) + +type FailCaseT p = Fail (Snd Id >> Unproxy) (Fst Id >> p) + +type CaseImplT e ps qs r = CaseImpl (LenT ps) e ps qs r + +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out +instance (FailUnlessT (LenT ps DE.== LenT qs) + ('GL.Text "lengths are not the same " + ':<>: 'GL.ShowType (LenT ps) + ':<>: 'GL.Text " vs " + ':<>: 'GL.ShowType (LenT qs)) + , P (CaseImplT e ps qs r) x + ) => P (Case e ps qs r) x where + type PP (Case e ps qs r) x = PP (CaseImplT e ps qs r) x + eval _ = eval (Proxy @(CaseImplT e ps qs r)) + +-- only allow non empty lists! +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lhs requires at least one value in the list")) + => P (CaseImpl n e ('[] :: [k]) (q ': qs) r) x where + type PP (CaseImpl n e ('[] :: [k]) (q ': qs) r) x = Void + eval _ _ _ = errorInProgram "CaseImpl lhs empty" + +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: rhs requires at least one value in the list")) + => P (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x where + type PP (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x = Void + eval _ _ _ = errorInProgram "CaseImpl rhs empty" + +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lists are both empty")) + => P (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x where + type PP (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x = Void + eval _ _ _ = errorInProgram "CaseImpl both lists empty" + +instance (P r x + , P q (PP r x) + , Show (PP q (PP r x)) + , P p (PP r x) + , PP p (PP r x) ~ Bool + , KnownNat n + , Show (PP r x) + , P e (PP r x, Proxy (PP q (PP r x))) + , PP e (PP r x, Proxy (PP q (PP r x))) ~ PP q (PP r x) + ) => P (CaseImpl n e '[p] '[q] r) x where + type PP (CaseImpl n e '[p] '[q] r) x = PP q (PP r x) + eval _ opts z = do + let msgbase0 = "Case(" <> show n <> ")" + n :: Int = nat @n + rr <- eval (Proxy @r) opts z + case getValueLR opts msgbase0 rr [] of + Left e -> pure e + Right a -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msgbase0 pp [hh rr] of + Left e -> pure e + Right True -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msgbase0 qq [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) (hh rr : hh pp : [hh qq | isVerbose opts]) + Right False -> do + ee <- eval (Proxy @e) opts (a, Proxy @(PP q (PP r x))) + pure $ case getValueLR opts (msgbase0 <> " otherwise failed") ee [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) [hh rr, hh pp, hh ee] + +instance (KnownNat n + , GetLen ps + , P r x + , P p (PP r x) + , P q (PP r x) + , PP p (PP r x) ~ Bool + , Show (PP q (PP r x)) + , Show (PP r x) + , P (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x + , PP (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x ~ PP q (PP r x) + ) + => P (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x where + type PP (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x = PP q (PP r x) + eval _ opts z = do + let cpos = n-pos-1 + msgbase0 = msgbase2 <> "(" <> showIndex cpos <> " of " <> show n <> ")" + msgbase1 = msgbase2 <> "(" <> showIndex cpos <> ")" + msgbase2 = "Case" + n = nat @n + pos = 1 + getLen @ps -- cos p1! + rr <- eval (Proxy @r) opts z + case getValueLR opts msgbase0 rr [] of + Left e -> pure e + Right a -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msgbase0 pp [hh rr] of + Left e -> pure e + Right True -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msgbase0 qq [hh pp, hh rr] of + Left e -> e + Right b -> mkNode opts (PresentT b) (show01 opts msgbase0 b a) (hh rr : hh pp : [hh qq | isVerbose opts]) + Right False -> do + ww <- eval (Proxy @(CaseImpl n e (p1 ': ps) (q1 ': qs) r)) opts z + pure $ case getValueLR opts (msgbase1 <> " failed rhs") ww [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) (show01 opts msgbase1 b a) [hh rr, hh pp, hh ww] + +-- | similar to 'sequenceA' +-- +-- >>> pz @Sequence [Just 10, Just 20, Just 30] +-- PresentT (Just [10,20,30]) +-- +-- >>> pz @Sequence [Just 10, Just 20, Just 30, Nothing, Just 40] +-- PresentT Nothing +-- +data Sequence + +instance (Show (f (t a)) + , Show (t (f a)) + , Traversable t + , Applicative f + ) => P Sequence (t (f a)) where + type PP Sequence (t (f a)) = f (t a) + eval _ opts tfa = + let d = sequenceA tfa + in pure $ mkNode opts (PresentT d) ("Sequence" <> " " <> showL opts d <> showVerbose opts " | " tfa) [] + +data Traverse p q +type TraverseT p q = Map p q >> Sequence + +instance P (TraverseT p q) x => P (Traverse p q) x where + type PP (Traverse p q) x = PP (TraverseT p q) x + eval _ = eval (Proxy @(TraverseT p q)) + +-- | similar to 'readFile' +-- +-- >>> pz @(ReadFile "LICENSE" >> 'Just Id >> Len > 0) () +-- TrueT +-- +-- >>> pz @(FileExists "xyzzy") () +-- FalseT +-- +data ReadFile p + +data FileExists p +type FileExistsT p = IsJust (ReadFile p) + +instance P (FileExistsT p) x => P (FileExists p) x where + type PP (FileExists p) x = PP (FileExistsT p) x + eval _ = evalBool (Proxy @(FileExistsT p)) + +instance ( PP p x ~ String + , P p x + ) => P (ReadFile p) x where + type PP (ReadFile p) x = Maybe String + eval _ opts x = do + let msg0 = "ReadFile" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ do + b <- doesFileExist p + if b then Just <$> readFile p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (FailT msg1) "" [hh pp] + Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> litL opts b) [hh pp] + +-- | does the directory exists +-- +-- >>> pz @(DirExists ".") () +-- TrueT +-- +data ReadDir p +data DirExists p +type DirExistsT p = IsJust (ReadDir p) + +instance P (DirExistsT p) x => P (DirExists p) x where + type PP (DirExists p) x = PP (DirExistsT p) x + eval _ = evalBool (Proxy @(DirExistsT p)) + + +instance ( PP p x ~ String + , P p x + ) => P (ReadDir p) x where + type PP (ReadDir p) x = Maybe [FilePath] + eval _ opts x = do + let msg0 = "ReadDir" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ do + b <- doesDirectoryExist p + if b then Just <$> listDirectory p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (FailT msg1) "" [hh pp] + Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> showL opts b) [hh pp] + +-- | read an environment variable +-- +-- >>> pz @(ReadEnv "PATH" >> 'Just Id >> 'True) () +-- TrueT +-- +data ReadEnv p + +instance ( PP p x ~ String + , P p x + ) => P (ReadEnv p) x where + type PP (ReadEnv p) x = Maybe String + eval _ opts x = do + let msg0 = "ReadEnv" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ lookupEnv p + pure $ case mb of + Nothing -> mkNode opts (FailT msg1) "" [hh pp] + Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just v) -> mkNode opts (PresentT (Just v)) (msg1 <> " " <> litL opts v) [hh pp] + +-- | read all the environment variables as key value pairs +data ReadEnvAll + +instance P ReadEnvAll a where + type PP ReadEnvAll a = [(String,String)] + eval _ opts _ = do + let msg0 = "ReadEnvAll" + mb <- runIO getEnvironment + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (PresentT v) (msg0 <> " count=" <> show (length v)) [] + +-- | get the current time using 'UTCTime' +data TimeUtc + +instance P TimeUtc a where + type PP TimeUtc a = UTCTime + eval _ opts _a = do + let msg0 = "TimeUtc" + mb <- runIO getCurrentTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (PresentT v) (msg0 <> " " <> showL opts v) [] + +-- | get the current time using 'ZonedTime' +data TimeZt + +instance P TimeZt a where + type PP TimeZt a = ZonedTime + eval _ opts _a = do + let msg0 = "TimeZt" + mb <- runIO getZonedTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (PresentT v) (msg0 <> " " <> showL opts v) [] + +data FHandle s = FStdout | FStderr | FOther !s !WFMode deriving Show + +class GetFHandle (x :: FHandle Symbol) where getFHandle :: FHandle String +instance GetFHandle 'FStdout where getFHandle = FStdout +instance GetFHandle 'FStderr where getFHandle = FStderr +instance (GetMode w, KnownSymbol s) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w) + +data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq) + +class GetMode (x :: WFMode) where getMode :: WFMode +instance GetMode 'WFAppend where getMode = WFAppend +instance GetMode 'WFWriteForce where getMode = WFWriteForce +instance GetMode 'WFWrite where getMode = WFWrite + +data WriteFileImpl (hh :: FHandle Symbol) p + +-- | append to a file +data AppendFile (s :: Symbol) p +type AppendFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFAppend) p + +instance P (AppendFileT s p) x => P (AppendFile s p) x where + type PP (AppendFile s p) x = PP (AppendFileT s p) x + eval _ = eval (Proxy @(AppendFileT s p)) + + +-- | write to file, overwriting if needed +data WriteFile' (s :: Symbol) p +type WriteFileT' (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWriteForce) p + +instance P (WriteFileT' s p) x => P (WriteFile' s p) x where + type PP (WriteFile' s p) x = PP (WriteFileT' s p) x + eval _ = eval (Proxy @(WriteFileT' s p)) + +-- | write to file, without overwriting +data WriteFile (s :: Symbol) p +type WriteFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWrite) p + +instance P (WriteFileT s p) x => P (WriteFile s p) x where + type PP (WriteFile s p) x = PP (WriteFileT s p) x + eval _ = eval (Proxy @(WriteFileT s p)) + +-- | write a string value to stdout +data Stdout p +type StdoutT p = WriteFileImpl 'FStdout p + +instance P (StdoutT p) x => P (Stdout p) x where + type PP (Stdout p) x = PP (StdoutT p) x + eval _ = eval (Proxy @(StdoutT p)) + +-- | write a string value to stderr +data Stderr p +type StderrT p = WriteFileImpl 'FStderr p + +instance P (StderrT p) x => P (Stderr p) x where + type PP (Stderr p) x = PP (StderrT p) x + eval _ = eval (Proxy @(StderrT p)) + +instance (GetFHandle fh + , P p a + , PP p a ~ String + ) => P (WriteFileImpl fh p) a where + type PP (WriteFileImpl fh p) a = () + eval _ opts a = do + let fh = getFHandle @fh + msg0 = case fh of + FStdout -> "Stdout" + FStderr -> "Stderr" + FOther s w -> (<>("[" <> s <> "]")) $ case w of + WFAppend -> "AppendFile" + WFWrite -> "WriteFile" + WFWriteForce -> "WriteFile'" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right ss -> do + mb <- runIO $ case fh of + FStdout -> fmap (left show) $ E.try @E.SomeException $ putStr ss + FStderr -> fmap (left show) $ E.try @E.SomeException $ putStr ss + FOther s w -> do + b <- doesFileExist s + if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists" + else do + let md = case w of + WFAppend -> AppendMode + _ -> WriteMode + fmap (left show) $ E.try @E.SomeException $ withFile s md (`hPutStr` ss) + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [hh pp] + Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) [hh pp] + Just (Right ()) -> mkNode opts (PresentT ()) msg0 [hh pp] + +-- | read in a value of a given type from stdin with a prompt: similar to 'System.IO.readIO' +type ReadIO (t :: Type) = ReadIO' t "Enter value" +type ReadIO' (t :: Type) s = Stdout (s <> ":") >> Stdin >> ReadP t Id +-- eg pa @(ReadIO Int + ReadIO Int) () + +-- | read a value from stdin +data Stdin + +instance P Stdin x where + type PP Stdin x = String + eval _ opts _x = do + let msg0 = "Stdin" + mb <- runIO $ do + lr <- E.try getLine + pure $ case lr of + Left (e :: E.SomeException) -> Left $ show e + Right ss -> Right ss + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [] + Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) [] + Just (Right ss) -> mkNode opts (PresentT ss) (msg0 <> "[" <> litVerbose opts "" ss <> "]") [] + +--type Just' = JustFail "expected Just" Id +--type Nothing' = Guard "expected Nothing" IsNothing + +-- | similar to 'isInfixOf' 'isPrefixOf' 'isSuffixOf' for strings only. +-- +-- The \'I\' suffixed versions work are case insensitive. +-- +-- >>> pz @(IsInfixI "abc" "axAbCd") () +-- TrueT +-- +-- >>> pz @(IsPrefixI "abc" "aBcbCd") () +-- TrueT +-- +-- >>> pz @(IsPrefix "abc" "aBcbCd") () +-- FalseT +-- +-- >>> pz @(IsSuffix "bCd" "aBcbCd") () +-- TrueT +-- +data IsFixImpl (cmp :: Ordering) (ignore :: Bool) p q + +instance (GetBool ignore + , P p x + , P q x + , PP p x ~ String + , PP q x ~ String + , GetOrdering cmp + ) => P (IsFixImpl cmp ignore p q) x where + type PP (IsFixImpl cmp ignore p q) x = Bool + eval _ opts x = do + let cmp = getOrdering @cmp + ignore = getBool @ignore + lwr = if ignore then map toLower else id + (ff,msg0) = case cmp of + LT -> (isPrefixOf, "IsPrefix") + EQ -> (isInfixOf, "IsInfix") + GT -> (isSuffixOf, "IsSuffix") + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right s0 -> do + let msg1 = msg0 <> (if ignore then "I" else "") <> "(" <> s0 <> ")" + qq <- eval (Proxy @q) opts x + pure $ case getValueLR opts (msg1 <> " q failed") qq [hh pp] of + Left e -> e + Right s1 -> mkNodeB opts (on ff lwr s0 s1) (msg1 <> " " <> litL opts s1) [hh pp, hh qq] + +data IsPrefix p q +type IsPrefixT p q = IsFixImpl 'LT 'False p q + +instance P (IsPrefixT p q) x => P (IsPrefix p q) x where + type PP (IsPrefix p q) x = PP (IsPrefixT p q) x + eval _ = evalBool (Proxy @(IsPrefixT p q)) + +data IsInfix p q +type IsInfixT p q = IsFixImpl 'EQ 'False p q + +instance P (IsInfixT p q) x => P (IsInfix p q) x where + type PP (IsInfix p q) x = PP (IsInfixT p q) x + eval _ = evalBool (Proxy @(IsInfixT p q)) + +data IsSuffix p q +type IsSuffixT p q = IsFixImpl 'GT 'False p q + +instance P (IsSuffixT p q) x => P (IsSuffix p q) x where + type PP (IsSuffix p q) x = PP (IsSuffixT p q) x + eval _ = evalBool (Proxy @(IsSuffixT p q)) + +data IsPrefixI p q +type IsPrefixIT p q = IsFixImpl 'LT 'True p q + +instance P (IsPrefixIT p q) x => P (IsPrefixI p q) x where + type PP (IsPrefixI p q) x = PP (IsPrefixIT p q) x + eval _ = evalBool (Proxy @(IsPrefixIT p q)) + +data IsInfixI p q +type IsInfixIT p q = IsFixImpl 'EQ 'True p q + +instance P (IsInfixIT p q) x => P (IsInfixI p q) x where + type PP (IsInfixI p q) x = PP (IsInfixIT p q) x + eval _ = evalBool (Proxy @(IsInfixIT p q)) + +data IsSuffixI p q +type IsSuffixIT p q = IsFixImpl 'GT 'True p q + +instance P (IsSuffixIT p q) x => P (IsSuffixI p q) x where + type PP (IsSuffixI p q) x = PP (IsSuffixIT p q) x + eval _ = evalBool (Proxy @(IsSuffixIT p q)) + +-- | similar to 'SG.<>' +-- +-- >>> pz @(Fst Id <> Snd Id) ("abc","def") +-- PresentT "abcdef" +-- +-- >>> pz @("abcd" <> "ef" <> Id) "ghi" +-- PresentT "abcdefghi" +-- +-- >>> pz @("abcd" <> "ef" <> Id) "ghi" +-- PresentT "abcdefghi" +-- +-- >>> pz @(Wrap (SG.Sum _) Id <> FromInteger _ 10) 13 +-- PresentT (Sum {getSum = 23}) +-- +-- >>> pz @(Wrap (SG.Product _) Id <> FromInteger _ 10) 13 +-- PresentT (Product {getProduct = 130}) +-- +-- >>> pz @('(FromInteger _ 10,"def") <> Id) (SG.Sum 12, "_XYZ") +-- PresentT (Sum {getSum = 22},"def_XYZ") +-- +-- >>> pz @(SapA' (SG.Max _)) (10,12) +-- PresentT (Max {getMax = 12}) +-- +-- >>> pz @(SapA' (SG.Sum _)) (10,12) +-- PresentT (Sum {getSum = 22}) +-- +data p <> q +infixr 6 <> + +instance (Semigroup (PP p x) + , PP p x ~ PP q x + , P p x + , Show (PP q x) + ,P q x + ) => P (p <> q) x where + type PP (p <> q) x = PP p x + eval _ opts x = do + let msg0 = "<>" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <> q + in mkNode opts (PresentT d) (showL opts p <> " <> " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +data SapA' (t :: Type) +type SapAT' (t :: Type) = Wrap t (Fst Id) <> Wrap t (Snd Id) + +instance P (SapAT' t) x => P (SapA' t) x where + type PP (SapA' t) x = PP (SapAT' t) x + eval _ = eval (Proxy @(SapAT' t)) + +data SapA +type SapAT = Fst Id <> Snd Id + +instance P SapAT x => P SapA x where + type PP SapA x = PP SapAT x + eval _ = eval (Proxy @SapAT) + +-- | uses inductive tuples to replace variable arguments +-- +class PrintC x where + prtC :: (PrintfArg a, PrintfType r) => String -> (a,x) -> r +instance PrintC () where + prtC s (a,()) = printf s a +instance ( PrintfArg a + , PrintC rs + ) => PrintC (a,rs) where + prtC s (a,rs) = prtC s rs a + +-- | print for flat n-tuples of size two or larger +-- +-- >>> pl @(PrintT "%d %s %s %s" '(Fst Id, Snd Id, Snd Id,Snd Id)) (10,"Asdf") +-- Present "10 Asdf Asdf Asdf" (PrintT [10 Asdf Asdf Asdf] | s=%d %s %s %s) +-- PresentT "10 Asdf Asdf Asdf" +-- +-- >>> pl @(PrintT "%c %d %s" Id) ('x', 10,"Asdf") +-- Present "x 10 Asdf" (PrintT [x 10 Asdf] | s=%c %d %s) +-- PresentT "x 10 Asdf" +-- +-- >>> pz @(PrintT "fst=%s snd=%03d" Id) ("ab",123) +-- PresentT "fst=ab snd=123" +-- +-- >>> pz @(PrintT "fst=%s snd=%03d thd=%s" Id) ("ab",123,"xx") +-- PresentT "fst=ab snd=123 thd=xx" +-- +-- >>> pl @(PrintT "%s %d %c %s" '(W "xyz", Fst Id, Snd Id, Thd Id)) (123,'x',"ab") +-- Present "xyz 123 x ab" (PrintT [xyz 123 x ab] | s=%s %d %c %s) +-- PresentT "xyz 123 x ab" +-- +-- >>> pl @(PrintT "%d %c %s" Id) (123,'x') +-- Error PrintT(IO e=printf: argument list ended prematurely) (PrintT %d %c %s) +-- FailT "PrintT(IO e=printf: argument list ended prematurely)" +-- +-- >>> pl @(PrintT "%d %c %s" Id) (123,'x',"abc",11) +-- Error PrintT(IO e=printf: formatting string ended prematurely) (PrintT %d %c %s) +-- FailT "PrintT(IO e=printf: formatting string ended prematurely)" +-- +data PrintT s p +instance (PrintC bs + , (b,bs) ~ InductTupleP y + , InductTupleC y + , PrintfArg b + , PP s x ~ String + , PP p x ~ y + , P s x + , P p x + , CheckT (PP p x) ~ 'True + ) => P (PrintT s p) x where + type PP (PrintT s p) x = String + eval _ opts x = do + let msg0 = "PrintT" + lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] + case lrx of + Left e -> pure e + Right (s,y,ss,pp) -> do + let hhs = [hh ss, hh pp] + lr <- catchitNF @_ @E.SomeException (prtC @bs s (inductTupleC y)) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> "(" <> e <> ")")) (msg0 <> " " <> s) hhs + Right ret -> mkNode opts (PresentT ret) (msg0 <> " [" <> litL opts ret <> "]" <> " | s=" <> litL opts s) hhs + +-- | print for lists -- use 'PrintT' as it is safer than 'PrintL' +-- +-- >>> pl @(PrintL 4 "%s %s %s %s" '[W "xyz", ShowP (Fst Id), ShowP (Snd Id), Thd Id]) (123,'x',"ab") +-- Present "xyz 123 'x' ab" (PrintL(4) [xyz 123 'x' ab] | s=%s %s %s %s) +-- PresentT "xyz 123 'x' ab" +-- +-- >>> pz @(PrintL 1 "%05d" '[Id]) 123 -- tick is required for a one element list (use 'PrintF') +-- PresentT "00123" +-- +-- >>> pz @(PrintL 2 "%d %05d" [Fst Id,Snd Id]) (29,123) +-- PresentT "29 00123" +-- +-- >>> pl @(PrintL 3 "first=%d second=%d third=%d" Id) [10,11,12] +-- Present "first=10 second=11 third=12" (PrintL(3) [first=10 second=11 third=12] | s=first=%d second=%d third=%d) +-- PresentT "first=10 second=11 third=12" +-- +-- >>> pl @(PrintL 2 "first=%d second=%d third=%d" Id) [10,11,12] +-- Error PrintL(2) arg count=3 (wrong length 3) +-- FailT "PrintL(2) arg count=3" +-- +-- >>> pl @(PrintL 4 "first=%d second=%d third=%d" Id) [10,11,12] +-- Error PrintL(4) arg count=3 (wrong length 3) +-- FailT "PrintL(4) arg count=3" +-- +data PrintL (n :: Nat) s p + +instance (KnownNat n + , PrintC bs + , (b,bs) ~ InductListP n a + , InductListC n a + , PrintfArg b + , PP s x ~ String + , PP p x ~ [a] + , P s x + , P p x + ) => P (PrintL n s p) x where + type PP (PrintL n s p) x = String + eval _ opts x = do + let msg0 = "PrintL(" ++ show n ++ ")" + n = nat @n + lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] + case lrx of + Left e -> pure e + Right (s,p,ss,pp) -> do + let hhs = [hh ss, hh pp] + if length p /= n then pure $ mkNode opts (FailT (msg0 <> " arg count=" ++ show (length p))) ("wrong length " ++ show (length p)) hhs + else do + lr <- catchitNF @_ @E.SomeException (prtC @bs s (inductListC @n @a p)) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> "(" <> e <> ")")) ("s=" <> s) hhs + Right ret -> mkNode opts (PresentT ret) (msg0 <> " [" <> litL opts ret <> "]" <> " | s=" <> litL opts s) hhs + +type family CheckT (tp :: Type) :: Bool where + CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") + CheckT o = 'True + +type family ApplyConstT (ta :: Type) (b :: Type) :: Type where +--type family ApplyConstT ta b where -- less restrictive so allows ('Just Int) Bool through! + ApplyConstT (t a) b = t b + ApplyConstT ta b = GL.TypeError ( + 'GL.Text "ApplyConstT: (t a) b but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType ta + ':$$: 'GL.Text "b = " + ':<>: 'GL.ShowType b) + +-- | similar to 'Control.Applicative.<$' +-- +-- >>> pz @(Fst Id <$ Snd Id) ("abc",Just 20) +-- PresentT (Just "abc") +-- +data p <$ q +infixl 4 <$ + +instance (P p x + , P q x + , Show (PP p x) + , Functor t + , PP q x ~ t c + , ApplyConstT (PP q x) (PP p x) ~ t (PP p x) + ) => P (p <$ q) x where + type PP (p <$ q) x = ApplyConstT (PP q x) (PP p x) + eval _ opts x = do + let msg0 = "(<$)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <$ q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts p) [hh pp, hh qq] + +data p <* q +infixl 4 <* + +-- | similar to 'Control.Applicative.<*' +-- +-- >>> pz @(Fst Id <* Snd Id) (Just "abc",Just 20) +-- PresentT (Just "abc") +-- +type ArrowRT p q = q <* p +data p *> q +infixl 4 *> + +instance P (ArrowRT p q) x => P (p *> q) x where + type PP (p *> q) x = PP (ArrowRT p q) x + eval _ = eval (Proxy @(ArrowRT p q)) + +instance (Show (t c) + , P p x + , P q x + , Show (t b) + , Applicative t + , t b ~ PP p x + , PP q x ~ t c + ) => P (p <* q) x where + type PP (p <* q) x = PP p x + eval _ opts x = do + let msg0 = "(<*)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <* q + in mkNode opts (PresentT d) (show01' opts msg0 p "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to 'Control.Applicative.<|>' +-- +-- >>> pz @(Fst Id <|> Snd Id) (Nothing,Just 20) +-- PresentT (Just 20) +-- +-- >>> pz @(Fst Id <|> Snd Id) (Just 10,Just 20) +-- PresentT (Just 10) +-- +-- >>> pz @(Fst Id <|> Snd Id) (Nothing,Nothing) +-- PresentT Nothing +-- +data p <|> q +infixl 3 <|> + +instance (P p x + , P q x + , Show (t b) + , Alternative t + , t b ~ PP p x + , PP q x ~ t b + ) => P (p <|> q) x where + type PP (p <|> q) x = PP p x + eval _ opts x = do + let msg0 = "(<|>)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <|> q + in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + + +-- | similar to 'Control.Comonad.extract' +-- +-- >>> pz @Extract (Nothing,Just 20) +-- PresentT (Just 20) +-- +-- >>> pz @Extract (Identity 20) +-- PresentT 20 +-- +data Extract +instance (Show (t a) + , Show a + , Comonad t + ) => P Extract (t a) where + type PP Extract (t a) = a + eval _ opts ta = + let msg0 = "Extract" + d = extract ta + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d ta) [] + +-- | similar to 'Control.Comonad.duplicate' +-- +-- >>> pz @Duplicate (20,"abc") +-- PresentT (20,(20,"abc")) +-- +data Duplicate + +instance (Show (t a) + , Show (t (t a)) + , Comonad t + ) => P Duplicate (t a) where + type PP Duplicate (t a) = t (t a) + eval _ opts ta = + let msg0 = "Duplicate" + d = duplicate ta + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d ta) [] + +-- | similar to 'Control.Monad.join' +-- +-- >>> pz @Join (Just (Just 20)) +-- PresentT (Just 20) +-- +-- >>> pz @Join ["ab","cd","","ef"] +-- PresentT "abcdef" +-- +data Join + +instance (Show (t (t a)) + , Show (t a) + , Monad t + ) => P Join (t (t a)) where + type PP Join (t (t a)) = t a + eval _ opts tta = + let msg0 = "Join" + d = join tta + in pure $ mkNode opts (PresentT d) (show01 opts msg0 d tta) [] + +-- | function application for expressions: similar to 'GHC.Base.$' +-- +-- pz @(Fst Id $$ Snd Id) ((*16),4) +-- PresentT 64 +-- +-- pz @(Id $$ "def") ("abc"<>) +-- PresentT "abcdef" +-- +data p $$ q +infixl 0 $$ + +instance (P p x + , P q x + , PP p x ~ (a -> b) + , FnT (PP p x) ~ b + , PP q x ~ a + , Show a + , Show b + ) => P (p $$ q) x where + type PP (p $$ q) x = FnT (PP p x) + eval _ opts x = do + let msg0 = "($$)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- reify this so we can combine (type synonyms dont work as well) + +-- | flipped function application for expressions: similar to 'Control.Lens.&' +-- +-- pz @(Snd Id $& Fst Id) ((*16),4) +-- PresentT 64 +-- +-- pz @("def" $& Id) ("abc"<>) +-- PresentT "abcdef" +-- +data q $& p -- flips the args eg a & b & (,) = (b,a) +infixr 1 $& + +instance (P p x + , P q x + , PP p x ~ (a -> b) + , FnT (PP p x) ~ b + , PP q x ~ a + , Show a + , Show b + ) => P (q $& p) x where + type PP (q $& p) x = FnT (PP p x) + eval _ opts x = do + let msg0 = "($&)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p q + in mkNode opts (PresentT d) (msg0 <> " " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +type family FnT ab :: Type where + FnT (a -> b) = b + FnT ab = GL.TypeError ( + 'GL.Text "FnT: expected Type -> Type but found a simple Type?" + ':$$: 'GL.Text "ab = " + ':<>: 'GL.ShowType ab) + +-- | similar to 'T.strip' 'T.stripStart' 'T.stripEnd' +-- +-- >>> pz @(TrimBoth (Snd Id)) (20," abc " :: String) +-- PresentT "abc" +-- +-- >>> pz @(TrimBoth (Snd Id)) (20,T.pack " abc ") +-- PresentT "abc" +-- +-- >>> pz @(TrimL (Snd Id)) (20," abc ") +-- PresentT "abc " +-- +-- >>> pz @(TrimR (Snd Id)) (20," abc ") +-- PresentT " abc" +-- +-- >>> pz @(TrimR " abc ") () +-- PresentT " abc" +-- +-- >>> pz @(TrimR "") () +-- PresentT "" +-- +-- >>> pz @(TrimBoth " ") () +-- PresentT "" +-- +-- >>> pz @(TrimBoth "") () +-- PresentT "" +-- +data TrimImpl (left :: Bool) (right :: Bool) p + +instance (FailUnlessT (OrT l r) + ('GL.Text "TrimImpl: left and right cannot both be False") + , GetBool l + , GetBool r + , DTL.IsText (PP p x) + , P p x + ) => P (TrimImpl l r p) x where + type PP (TrimImpl l r p) x = PP p x + eval _ opts x = do + let msg0 = "Trim" ++ (if l && r then "Both" else if l then "L" else "R") + l = getBool @l + r = getBool @r + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (view DTL.unpacked -> p) -> + let fl = if l then dropWhile isSpace else id + fr = if r then dropWhileEnd isSpace else id + b = (fl . fr) p + in mkNode opts (PresentT (b ^. DTL.packed)) (msg0 <> litL opts b <> litVerbose opts " | " p) [hh pp] + +data TrimL p +type TrimLT p = TrimImpl 'True 'False p + +instance P (TrimLT p) x => P (TrimL p) x where + type PP (TrimL p) x = PP (TrimLT p) x + eval _ = eval (Proxy @(TrimLT p)) + +data TrimR p +type TrimRT p = TrimImpl 'False 'True p + +instance P (TrimRT p) x => P (TrimR p) x where + type PP (TrimR p) x = PP (TrimRT p) x + eval _ = eval (Proxy @(TrimRT p)) + +data TrimBoth p +type TrimBothT p = TrimImpl 'True 'True p + +instance P (TrimBothT p) x => P (TrimBoth p) x where + type PP (TrimBoth p) x = PP (TrimBothT p) x + eval _ = eval (Proxy @(TrimBothT p)) + +-- | similar to 'T.stripLeft' 'T.stripRight' +-- +-- >>> pz @(StripL "xyz" Id) ("xyzHello" :: String) +-- PresentT (Just "Hello") +-- +-- >>> pz @(StripL "xyz" Id) (T.pack "xyzHello") +-- PresentT (Just "Hello") +-- +-- >>> pz @(StripL "xyz" Id) "xywHello" +-- PresentT Nothing +-- +-- >>> pz @(StripR "xyz" Id) "Hello xyz" +-- PresentT (Just "Hello ") +-- +-- >>> pz @(StripR "xyz" Id) "xyzHelloxyw" +-- PresentT Nothing +-- +-- >>> pz @(StripR "xyz" Id) "" +-- PresentT Nothing +-- +-- >>> pz @(StripR "xyz" "xyz") () +-- PresentT (Just "") +-- +data StripImpl(left :: Bool) p q + +instance (GetBool l + , PP p x ~ String + , P p x + , DTL.IsText (PP q x) + , P q x + ) => P (StripImpl l p q) x where + type PP (StripImpl l p q) x = Maybe (PP q x) + eval _ opts x = do + let msg0 = "Strip" ++ if l then "L" else "R" + l = getBool @l + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,view DTL.unpacked -> q,pp,qq) -> + let b = if l then + let (before,after) = splitAt (length p) q + in if before == p then Just after else Nothing + else + let (before,after) = splitAt (length q - length p) q + in if after == p then Just before else Nothing + in mkNode opts (PresentT (fmap (view DTL.packed) b)) (msg0 <> showL opts b <> litVerbose opts " | p=" p <> litVerbose opts " | q=" q) [hh pp, hh qq] + +data StripL p q +type StripLT p q = StripImpl 'True p q + +instance P (StripLT p q) x => P (StripL p q) x where + type PP (StripL p q) x = PP (StripLT p q) x + eval _ = eval (Proxy @(StripLT p q)) + +data StripR p q +type StripRT p q = StripImpl 'False p q + +instance P (StripRT p q) x => P (StripR p q) x where + type PP (StripR p q) x = PP (StripRT p q) x + eval _ = eval (Proxy @(StripRT p q)) + +-- | creates a promoted list of predicates and then evaluates them into a list. see PP instance for '[k] +-- +-- >>> pz @(Repeat 4 (Succ Id)) 'c' +-- PresentT "dddd" +-- +-- >>> pz @(Repeat 4 "abc") () +-- PresentT ["abc","abc","abc","abc"] +-- +data Repeat (n :: Nat) p +instance P (RepeatT n p) a => P (Repeat n p) a where + type PP (Repeat n p) a = PP (RepeatT n p) a + eval _ = eval (Proxy @(RepeatT n p)) + +-- | leverages 'Do' for repeating predicates (passthrough method) +-- same as @DoN n p == FoldN n p Id@ but more efficient +-- +-- >>> pz @(DoN 4 (Succ Id)) 'c' +-- PresentT 'g' +-- +-- >>> pz @(DoN 4 (Id <> " | ")) "abc" +-- PresentT "abc | | | | " +-- +-- >>> pz @(DoN 4 (Id <> "|" <> Id)) "abc" +-- PresentT "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" +-- +data DoN (n :: Nat) p +type DoNT (n :: Nat) p = Do (RepeatT n p) +instance P (DoNT n p) a => P (DoN n p) a where + type PP (DoN n p) a = PP (DoNT n p) a + eval _ = eval (Proxy @(DoNT n p)) + +-- | extract the value from a 'Maybe' otherwise use the default value +-- +-- >>> pz @(JustDef (1 % 4) Id) (Just 20.4) +-- PresentT (102 % 5) +-- +-- >>> pz @(JustDef (1 % 4) Id) Nothing +-- PresentT (1 % 4) +-- +-- >>> pz @(JustDef (MEmptyT _) Id) (Just "xy") +-- PresentT "xy" +-- +-- >>> pz @(JustDef (MEmptyT _) Id) Nothing +-- PresentT () +-- +-- >>> pz @(JustDef (MEmptyT (SG.Sum _)) Id) Nothing +-- PresentT (Sum {getSum = 0}) +-- +data JustDef p q + +instance ( PP p x ~ a + , PP q x ~ Maybe a + , P p x + , P q x) + => P (JustDef p q) x where + type PP (JustDef p q) x = MaybeT (PP q x) + eval _ opts x = do + let msg0 = "JustDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] + Nothing -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right b -> mkNode opts (PresentT b) (msg0 <> " Nothing") [hh qq, hh pp] + + +type family MaybeT mb where + MaybeT (Maybe a) = a + MaybeT o = GL.TypeError ( + 'GL.Text "MaybeT: expected 'Maybe a' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +-- | extract the value from a 'Maybe' or fail +-- +-- >>> pz @(JustFail "nope" Id) (Just 99) +-- PresentT 99 +-- +-- >>> pz @(JustFail "nope" Id) Nothing +-- FailT "nope" +-- +-- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Nothing, 123) +-- FailT "oops=123" +-- +-- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Just 'x', 123) +-- PresentT 'x' +-- +data JustFail p q + +instance ( PP p x ~ String + , PP q x ~ Maybe a + , P p x + , P q x) + => P (JustFail p q) x where + type PP (JustFail p q) x = MaybeT (PP q x) + eval _ opts x = do + let msg0 = "JustFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] + Nothing -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " Nothing") [hh qq, hh pp] + +-- | extract the Left value from an 'Either' otherwise use the default value +-- +-- if there is no Left value then \p\ is passed the Right value and the whole context +-- +-- >>> pz @(LeftDef (1 % 4) Id) (Left 20.4) +-- PresentT (102 % 5) +-- +-- >>> pz @(LeftDef (1 % 4) Id) (Right "aa") +-- PresentT (1 % 4) +-- +-- >>> pz @(LeftDef (PrintT "found right=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Right "xy") +-- PresentT "found right=xy fst=123" +-- +-- >>> pz @(LeftDef (MEmptyT _) Id) (Right 222) +-- PresentT () +-- +-- >>> pz @(LeftDef (MEmptyT (SG.Sum _)) Id) (Right 222) +-- PresentT (Sum {getSum = 0}) +-- +data LeftDef p q + +instance ( PP q x ~ Either a b + , PP p (b,x) ~ a + , P q x + , P p (b,x) + ) => P (LeftDef p q) x where + type PP (LeftDef p q) x = LeftT (PP q x) + eval _ opts x = do + let msg0 = "LeftDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Left a -> pure $ mkNode opts (PresentT a) (msg0 <> " Left") [hh qq] + Right b -> do + pp <- eval (Proxy @p) opts (b,x) + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (PresentT p) (msg0 <> " Right") [hh qq, hh pp] + +type family LeftT lr where + LeftT (Either a b) = a + LeftT o = GL.TypeError ( + 'GL.Text "LeftT: expected 'Either a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +type family RightT lr where + RightT (Either a b) = b + RightT o = GL.TypeError ( + 'GL.Text "RightT: expected 'Either a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +-- | extract the Right value from an 'Either' +-- +-- if there is no Right value then \p\ is passed the Left value and the whole context +-- +-- >>> pz @(RightDef (1 % 4) Id) (Right 20.4) +-- PresentT (102 % 5) +-- +-- >>> pz @(RightDef (1 % 4) Id) (Left "aa") +-- PresentT (1 % 4) +-- +-- >>> pz @(RightDef (PrintT "found left=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Left "xy") +-- PresentT "found left=xy fst=123" +-- +-- >>> pz @(RightDef (MEmptyT _) Id) (Left 222) +-- PresentT () +-- +-- >>> pz @(RightDef (MEmptyT (SG.Sum _)) Id) (Left 222) +-- PresentT (Sum {getSum = 0}) +-- +data RightDef p q + +instance ( PP q x ~ Either a b + , PP p (a,x) ~ b + , P q x + , P p (a,x) + ) => P (RightDef p q) x where + type PP (RightDef p q) x = RightT (PP q x) + eval _ opts x = do + let msg0 = "RightDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Right b -> pure $ mkNode opts (PresentT b) (msg0 <> " Right") [hh qq] + Left a -> do + pp <- eval (Proxy @p) opts (a,x) + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (PresentT p) (msg0 <> " Left") [hh qq, hh pp] + + +-- | extract the Left value from an 'Either' otherwise fail with a message +-- +-- if there is no Left value then \p\ is passed the Right value and the whole context +-- +-- >>> pz @(LeftFail "oops" Id) (Left 20.4) +-- PresentT 20.4 +-- +-- >>> pz @(LeftFail "oops" Id) (Right "aa") +-- FailT "oops" +-- +-- >>> pz @(LeftFail (PrintT "found right=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Right "xy") +-- FailT "found right=xy fst=123" +-- +-- >>> pz @(LeftFail (MEmptyT _) Id) (Right 222) +-- FailT "" +-- +data LeftFail p q + +instance ( PP p (b,x) ~ String + , PP q x ~ Either a b + , P p (b,x) + , P q x) + => P (LeftFail p q) x where + type PP (LeftFail p q) x = LeftT (PP q x) + eval _ opts x = do + let msg0 = "LeftFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Left a -> pure $ mkNode opts (PresentT a) (msg0 <> " Left") [hh qq] + Right b -> do + pp <- eval (Proxy @p) opts (b,x) + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " Right") [hh qq, hh pp] + + +-- | extract the Right value from an 'Either' otherwise fail with a message +-- +-- if there is no Right value then \p\ is passed the Left value and the whole context +-- +-- >>> pz @(RightFail "oops" Id) (Right 20.4) +-- PresentT 20.4 +-- +-- >>> pz @(RightFail "oops" Id) (Left "aa") +-- FailT "oops" +-- +-- >>> pz @(RightFail (PrintT "found left=%s fst=%d" '(Fst Id,Fst (Snd Id))) (Snd Id)) (123,Left "xy") +-- FailT "found left=xy fst=123" +-- +-- >>> pz @(RightFail (MEmptyT _) Id) (Left 222) +-- FailT "" +-- +data RightFail p q + +instance ( PP p (a,x) ~ String + , PP q x ~ Either a b + , P p (a,x) + , P q x) + => P (RightFail p q) x where + type PP (RightFail p q) x = RightT (PP q x) + eval _ opts x = do + let msg0 = "RightFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + Right b -> pure $ mkNode opts (PresentT b) (msg0 <> " Right") [hh qq] + Left a -> do + pp <- eval (Proxy @p) opts (a,x) + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " Left") [hh qq, hh pp] + + + +-- | extract the This value from an 'These' otherwise use the default value +-- +-- if there is no This value then \p\ is passed the whole context only +-- +-- >>> pz @(ThisDef (1 % 4) Id) (This 20.4) +-- PresentT (102 % 5) +-- +-- >>> pz @(ThisDef (1 % 4) Id) (That "aa") +-- PresentT (1 % 4) +-- +-- >>> pz @(ThisDef (1 % 4) Id) (These 2.3 "aa") +-- PresentT (1 % 4) +-- +-- >>> pz @(ThisDef (PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id)) (Snd Id)) (123,That "xy") +-- PresentT "found That \"xy\" fst=123" +-- +-- >>> pz @(ThisDef (MEmptyT _) Id) (That 222) +-- PresentT () +-- +-- >>> pz @(ThisDef (MEmptyT (SG.Sum _)) Id) (These 222 'x') +-- PresentT (Sum {getSum = 0}) +-- +data ThisDef p q + +instance ( PP q x ~ These a b + , PP p x ~ a + , P q x + , P p x + ) => P (ThisDef p q) x where + type PP (ThisDef p q) x = ThisT (PP q x) + eval _ opts x = do + let msg0 = "ThisDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + This a -> pure $ mkNode opts (PresentT a) (msg0 <> " This") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + +type family ThisT lr where + ThisT (These a b) = a + ThisT o = GL.TypeError ( + 'GL.Text "ThisT: expected 'These a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +type family ThatT lr where + ThatT (These a b) = b + ThatT o = GL.TypeError ( + 'GL.Text "ThatT: expected 'These a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + +type family TheseT lr where + TheseT (These a b) = (a,b) + TheseT o = GL.TypeError ( + 'GL.Text "TheseT: expected 'These a b' " + ':$$: 'GL.Text "o = " + ':<>: 'GL.ShowType o) + + +-- | extract the That value from an 'These' otherwise use the default value +-- +-- if there is no That value then \p\ is passed the whole context only +-- +-- >>> pz @(ThatDef (1 % 4) Id) (That 20.4) +-- PresentT (102 % 5) +-- +-- >>> pz @(ThatDef (1 % 4) Id) (This "aa") +-- PresentT (1 % 4) +-- +-- >>> pz @(ThatDef (1 % 4) Id) (These "aa" 2.3) +-- PresentT (1 % 4) +-- +-- >>> pz @(ThatDef (PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id)) (Snd Id)) (123,This "xy") +-- PresentT "found This \"xy\" fst=123" +-- +-- >>> pz @(ThatDef (MEmptyT _) Id) (This 222) +-- PresentT () +-- +-- >>> pz @(ThatDef (MEmptyT (SG.Sum _)) Id) (These 'x' 1120) +-- PresentT (Sum {getSum = 0}) +-- +data ThatDef p q + +instance ( PP q x ~ These a b + , PP p x ~ b + , P q x + , P p x + ) => P (ThatDef p q) x where + type PP (ThatDef p q) x = ThatT (PP q x) + eval _ opts x = do + let msg0 = "ThatDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + That a -> pure $ mkNode opts (PresentT a) (msg0 <> " That") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + +-- | extract the These value from an 'These' otherwise use the default value +-- +-- if there is no These value then \p\ is passed the whole context only +-- +-- >>> pz @(TheseDef '(1 % 4,"zz") Id) (These 20.4 "x") +-- PresentT (102 % 5,"x") +-- +-- >>> pz @(TheseDef '(1 % 4,"zz") Id) (This 20.4) +-- PresentT (1 % 4,"zz") +-- +-- >>> pz @(TheseDef '(1 % 4,"zz") Id) (That "x") +-- PresentT (1 % 4,"zz") +-- +-- >>> pz @(TheseDef '(PrintT "found %s fst=%d" '(ShowP (Snd Id), Fst Id),999) (Snd Id)) (123,This "xy") +-- PresentT ("found This \"xy\" fst=123",999) +-- +-- >>> pz @(TheseDef (MEmptyT (SG.Sum _, String)) Id) (This 222) +-- PresentT (Sum {getSum = 0},"") +-- +-- >>> pz @(TheseDef (MEmptyT _) Id) (These (222 :: SG.Sum Int) "aa") +-- PresentT (Sum {getSum = 222},"aa") +-- +data TheseDef p q + +instance ( PP q x ~ These a b + , PP p x ~ (a,b) + , P q x + , P p x + ) => P (TheseDef p q) x where + type PP (TheseDef p q) x = TheseT (PP q x) + eval _ opts x = do + let msg0 = "TheseDef" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + These a b -> pure $ mkNode opts (PresentT (a,b)) (msg0 <> " These") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + + +-- | extract the This value from a 'These' otherwise fail with a message +-- +-- if there is no This value then \p\ is passed the whole context only +-- +-- >>> pz @(ThisFail "oops" Id) (This 20.4) +-- PresentT 20.4 +-- +-- >>> pz @(ThisFail "oops" Id) (That "aa") +-- FailT "oops" +-- +-- >>> pz @(ThisFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,That "xy") +-- FailT "found That \"xy\" fst=123" +-- +-- >>> pz @(ThisFail (MEmptyT _) Id) (That 222) +-- FailT "" +-- +data ThisFail p q + +instance ( PP p x ~ String + , PP q x ~ These a b + , P p x + , P q x) + => P (ThisFail p q) x where + type PP (ThisFail p q) x = ThisT (PP q x) + eval _ opts x = do + let msg0 = "ThisFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + This a -> pure $ mkNode opts (PresentT a) (msg0 <> " This") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + + +-- | extract the That value from a 'These' otherwise fail with a message +-- +-- if there is no That value then \p\ is passed the whole context only +-- +-- >>> pz @(ThatFail "oops" Id) (That 20.4) +-- PresentT 20.4 +-- +-- >>> pz @(ThatFail "oops" Id) (This "aa") +-- FailT "oops" +-- +-- >>> pz @(ThatFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,This "xy") +-- FailT "found This \"xy\" fst=123" +-- +-- >>> pz @(ThatFail (MEmptyT _) Id) (This 222) +-- FailT "" +-- +data ThatFail p q + +instance ( PP p x ~ String + , PP q x ~ These a b + , P p x + , P q x) + => P (ThatFail p q) x where + type PP (ThatFail p q) x = ThatT (PP q x) + eval _ opts x = do + let msg0 = "ThatFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + That a -> pure $ mkNode opts (PresentT a) (msg0 <> " That") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + + + + +-- | extract the These value from a 'These' otherwise fail with a message +-- +-- if there is no These value then \p\ is passed the whole context only +-- +-- >>> pz @(TheseFail "oops" Id) (These "abc" 20.4) +-- PresentT ("abc",20.4) +-- +-- >>> pz @(TheseFail "oops" Id) (That "aa") +-- FailT "oops" +-- +-- >>> pz @(TheseFail (PrintT "found %s fst=%d" '(ShowP (Snd Id),Fst Id)) (Snd Id)) (123,That "xy") +-- FailT "found That \"xy\" fst=123" +-- +-- >>> pz @(TheseFail (MEmptyT _) Id) (That 222) +-- FailT "" +-- +data TheseFail p q + +instance ( PP p x ~ String + , PP q x ~ These a b + , P p x + , P q x) + => P (TheseFail p q) x where + type PP (TheseFail p q) x = TheseT (PP q x) + eval _ opts x = do + let msg0 = "TheseFail" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> + case q of + These a b -> pure $ mkNode opts (PresentT (a,b)) (msg0 <> " These") [hh qq] + _ -> do + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [hh qq] of + Left e -> e + Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + +-- | takes the head of a list like container +-- +-- >>> pz @(Head Id) "abcd" +-- PresentT 'a' +-- +-- >>> pz @(Head Id) [] +-- FailT "Head(empty)" +-- +data Head p + +instance (Show (ConsT s) + , Show s + , Cons s s (ConsT s) (ConsT s) + , PP p x ~ s + , P p x + ) => P (Head p) x where + type PP (Head p) x = ConsT (PP p x) + eval _ opts x = do + let msg0 = "Head" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case p ^? _Cons of + Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) "" [hh pp] + Just (a,_) -> mkNode opts (PresentT a) (show01 opts msg0 a p) [hh pp] + +-- | takes the tail of a list like container +-- +-- >>> pz @(Tail Id) "abcd" +-- PresentT "bcd" +-- +-- >>> pz @(Tail Id) [] +-- FailT "Tail(empty)" +-- +data Tail p + +instance (Show s + , Cons s s (ConsT s) (ConsT s) + , PP p x ~ s + , P p x + ) => P (Tail p) x where + type PP (Tail p) x = PP p x + eval _ opts x = do + let msg0 = "Tail" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case p ^? _Cons of + Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) "" [hh pp] + Just (_,as) -> mkNode opts (PresentT as) (show01 opts msg0 as p) [hh pp] + + +-- | takes the last of a list like container +-- +-- >>> pz @(Last Id) "abcd" +-- PresentT 'd' +-- +-- >>> pz @(Last Id) [] +-- FailT "Last(empty)" +-- + +data Last p + +instance (Show (ConsT s) + , Show s + , Snoc s s (ConsT s) (ConsT s) + , PP p x ~ s + , P p x + ) => P (Last p) x where + type PP (Last p) x = ConsT (PP p x) + eval _ opts x = do + let msg0 = "Last" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case p ^? _Snoc of + Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) "" [hh pp] + Just (_,a) -> mkNode opts (PresentT a) (show01 opts msg0 a p) [hh pp] + +-- | takes the init of a list like container +-- +-- >>> pz @(Init Id) "abcd" +-- PresentT "abc" +-- +-- >>> pz @(Init Id) (T.pack "abcd") +-- PresentT "abc" +-- +-- >>> pz @(Init Id) [] +-- FailT "Init(empty)" +-- + +data Init p + +instance (Show s + , Snoc s s (ConsT s) (ConsT s) + , PP p x ~ s + , P p x + ) => P (Init p) x where + type PP (Init p) x = PP p x + eval _ opts x = do + let msg0 = "Init" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case p ^? _Snoc of + Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) "" [hh pp] + Just (as,_) -> mkNode opts (PresentT as) (show01 opts msg0 as p) [hh pp] + + +-- | tries to extract @a@ from @Maybe a@ otherwise it fails +-- +-- >>> pz @(Just Id) (Just "abc") +-- PresentT "abc" +-- +-- >>> pz @(Just Id) Nothing +-- FailT "Just(empty)" +-- +data Just p + +instance (Show a + , PP p x ~ Maybe a + , P p x + ) => P (Just p) x where + type PP (Just p) x = MaybeT (PP p x) + eval _ opts x = do + let msg0 = "Just" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + case p of + Nothing -> mkNode opts (FailT (msg0 <> "(empty)")) "found Nothing" [hh pp] + Just d -> mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] + + +-- | compose simple functions +-- +-- >>> pl @(Dot '[Thd,Snd,Fst] Id) ((1,(2,9,10)),(3,4)) +-- Present 10 (Thd 10 | (2,9,10)) +-- PresentT 10 +-- +data Dot (ps :: [Type -> Type]) (q :: Type) +instance (P (DotExpandT ps q) a) => P (Dot ps q) a where + type PP (Dot ps q) a = PP (DotExpandT ps q) a + eval _ = eval (Proxy @(DotExpandT ps q)) + +type family DotExpandT (ps :: [Type -> Type]) (q :: Type) :: Type where + DotExpandT '[] _ = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") + DotExpandT '[p] q = p $ q + DotExpandT (p ': p1 ': ps) q = p $ DotExpandT (p1 ': ps) q + +-- | reversed dot +-- +-- >>> pl @(RDot '[Fst,Snd,Thd] Id) ((1,(2,9,10)),(3,4)) +-- Present 10 (Thd 10 | (2,9,10)) +-- PresentT 10 +-- +-- >>> pl @(RDot '[Fst,Snd] Id) (('a',2),(True,"zy")) +-- Present 2 (Snd 2 | ('a',2)) +-- PresentT 2 +-- +data RDot (ps :: [Type -> Type]) (q :: Type) +instance P (RDotExpandT ps q) a => P (RDot ps q) a where + type PP (RDot ps q) a = PP (RDotExpandT ps q) a + eval _ = eval (Proxy @(RDotExpandT ps q)) + +type family RDotExpandT (ps :: [Type -> Type]) (q :: Type) :: Type where + RDotExpandT '[] _ = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") + RDotExpandT '[p] q = p $ q + RDotExpandT (p ': p1 ': ps) q = RDotExpandT (p1 ': ps) (p $ q) + +-- | like 'GHC.Base.$' for expressions +-- +-- >>> pl @(Fst $ Snd $ Id) ((1,2),(3,4)) +-- Present 3 (Fst 3 | (3,4)) +-- PresentT 3 +-- +-- >>> pl @((<=) 4 $ Fst $ Snd $ Id) ((1,2),(3,4)) +-- False (4 <= 3) +-- FalseT +-- +data (p :: k -> k1) $ (q :: k) +infixr 0 $ + +instance P (p q) a => P (p $ q) a where + type PP (p $ q) a = PP (p q) a + eval _ = eval (Proxy @(p q)) + +-- | similar to 'Control.Lens.&' +-- +-- >>> pl @(Id & Fst & Singleton & Length) (13,"xyzw") +-- Present 1 (Length 1 | [13]) +-- PresentT 1 +-- +-- >>> pl @(2 & (&&&) "abc") () +-- Present ("abc",2) (W '(,)) +-- PresentT ("abc",2) +-- +-- >>> pl @(2 & '(,) "abc") () +-- Present ("abc",2) ('(,)) +-- PresentT ("abc",2) +-- +-- >>> pl @('(,) 4 $ '(,) 7 $ "aa") () +-- Present (4,(7,"aa")) ('(,)) +-- PresentT (4,(7,"aa")) +-- +-- >>> pl @(Thd $ Snd $ Fst Id) ((1,("W",9,'a')),(3,4)) +-- Present 'a' (Thd 'a' | ("W",9,'a')) +-- PresentT 'a' +-- +data (q :: k) & (p :: k -> k1) +infixl 1 & + +instance P (p q) a => P (q & p) a where + type PP (q & p) a = PP (p q) a + eval _ = eval (Proxy @(p q)) + +-- | creates a constant expression ignoring the second argument +-- +-- >>> pl @(RDot '[Fst,Snd,Thd,K "xxx"] Id) ((1,(2,9,10)),(3,4)) +-- Present "xxx" (K '"xxx") +-- PresentT "xxx" +-- +-- >>> pl @(RDot '[Fst,Snd,Thd,K '("abc",Id)] Id) ((1,(2,9,10)),(3,4)) +-- Present ("abc",((1,(2,9,10)),(3,4))) (K '(,)) +-- PresentT ("abc",((1,(2,9,10)),(3,4))) +-- +-- >>> pl @(Thd $ Snd $ Fst $ K Id "dud") ((1,("W",9,'a')),(3,4)) +-- Present 'a' (Thd 'a' | ("W",9,'a')) +-- PresentT 'a' +-- +-- >>> pl @((Thd $ Snd $ Fst $ K Id "dud") >> Pred Id) ((1,("W",9,'a')),(3,4)) +-- Present '`' ((>>) '`' | {Pred '`' | 'a'}) +-- PresentT '`' +-- +data K (p :: k) (q :: k1) +instance P p a => P (K p q) a where + type PP (K p q) a = PP p a + eval _ = eval (Proxy @(Msg "K " p)) + +-- | applies \'p\' to the first and second slot of an n-tuple +-- +-- >>> pl @(Both Len (Fst Id)) (("abc",[10..17],1,2,3),True) +-- Present (3,8) (Both) +-- PresentT (3,8) +-- +-- >>> pl @(Both (Pred Id) $ Fst Id) ((12,'z',[10..17]),True) +-- Present (11,'y') (Both) +-- PresentT (11,'y') +-- +-- >>> pl @(Both (Succ Id) Id) (4,'a') +-- Present (5,'b') (Both) +-- PresentT (5,'b') +-- +-- >>> pl @(Both Len (Fst Id)) (("abc",[10..17]),True) +-- Present (3,8) (Both) +-- PresentT (3,8) +-- +-- >>> pl @(Both (ReadP Day Id) Id) ("1999-01-01","2001-02-12") +-- Present (1999-01-01,2001-02-12) (Both) +-- PresentT (1999-01-01,2001-02-12) +-- +data Both p q +instance ( ExtractL1C (PP q x) + , ExtractL2C (PP q x) + , P p (ExtractL1T (PP q x)) + , P p (ExtractL2T (PP q x)) + , P q x + ) => P (Both p q) x where + type PP (Both p q) x = (PP p (ExtractL1T (PP q x)), PP p (ExtractL2T (PP q x))) + eval _ opts x = do + let msg0 = "Both" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + let (a,a') = (extractL1C q, extractL2C q) + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [hh qq] of + Left e -> pure e + Right b -> do + pp' <- eval (Proxy @p) opts a' + pure $ case getValueLR opts msg0 pp' [hh qq, hh pp] of + Left e -> e + Right b' -> + mkNode opts (PresentT (b,b')) msg0 [hh qq, hh pp, hh pp'] + +-- | gets the singleton value from a foldable +-- +-- >>> pl @(OneP Id) [10..15] +-- Error OneP 6 elements (expected one element) +-- FailT "OneP 6 elements" +-- +-- >>> pl @(OneP Id) [10] +-- Present 10 (OneP) +-- PresentT 10 +-- +-- >>> pl @(OneP Id) [] +-- Error OneP empty (expected one element) +-- FailT "OneP empty" +-- +-- >>> pl @(OneP Id) (Just 10) +-- Present 10 (OneP) +-- PresentT 10 +-- +-- >>> pl @(OneP Id) Nothing +-- Error OneP empty (expected one element) +-- FailT "OneP empty" +-- +data OneP p +instance (Foldable t + , PP p x ~ t a + , P p x + ) => P (OneP p) x where + type PP (OneP p) x = ExtractAFromTA (PP p x) + eval _ opts x = do + let msg0 = "OneP" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> case toList p of + [] -> mkNode opts (FailT (msg0 <> " empty")) "expected one element" [hh pp] + [a] -> mkNode opts (PresentT a) msg0 [hh pp] + as -> let n = length as + in mkNode opts (FailT (msg0 <> " " <> show n <> " elements")) "expected one element" [hh pp] + +-- | parse json data +-- +-- >>> pl @(ParseJson (Int,String) Id) "[10,\"abc\"]" +-- Present (10,"abc") (ParseJson (Int,[Char]) (10,"abc")) +-- PresentT (10,"abc") +-- +-- >>> pl @(ParseJson (Int,String) Id) "[10,\"abc\",99]" +-- Error ParseJson (Int,[Char])([10,"abc",...) Error in $ (Error in $: cannot unpack array of length 3 into a tuple of length 2 | [10,"abc",99]) +-- FailT "ParseJson (Int,[Char])([10,\"abc\",...) Error in $" +-- +-- >>> pl @(ParseJson (Int,Bool) (FromString _ Id)) ("[1,true]" :: String) +-- Present (1,True) (ParseJson (Int,Bool) (1,True)) +-- PresentT (1,True) +-- +-- >>> pl @(ParseJson (Int,Bool) Id) (A.encode (1,True)) +-- Present (1,True) (ParseJson (Int,Bool) (1,True)) +-- PresentT (1,True) +-- +-- >>> pl @(ParseJson () Id) "[1,true]" +-- Error ParseJson ()([1,true]) Error in $ (Error in $: parsing () failed, expected an empty array | [1,true]) +-- FailT "ParseJson ()([1,true]) Error in $" +-- +data ParseJson' t p + +instance (P p x + , PP p x ~ BL8.ByteString + , Typeable (PP t x) + , Show (PP t x) + , A.FromJSON (PP t x) + ) => P (ParseJson' t p) x where + type PP (ParseJson' t p) x = PP t x + eval _ opts x = do + let msg0 = "ParseJson " <> t + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> + let hhs = [hh pp] + msg1 = msg0 <> "(" ++ litBL opts { oWidth = oWidth opts `div` 3 } s ++ ")" + in case A.eitherDecode' s of + Right b -> mkNode opts (PresentT b) (msg0 <> " " ++ showL opts { oWidth = oWidth opts `div` 2 } b) hhs + Left e -> mkNode opts (FailT (msg1 <> " " <> takeWhile (/=':') e) ) (e <> " | " <> litBL opts s) hhs + +data ParseJson (t :: Type) p +type ParseJsonT (t :: Type) p = ParseJson' (Hole t) p + +instance P (ParseJsonT t p) x => P (ParseJson t p) x where + type PP (ParseJson t p) x = PP (ParseJsonT t p) x + eval _ = eval (Proxy @(ParseJsonT t p)) + +-- | parse a json file +-- +-- >>> pz @(ParseJsonFile [A.Value] "test1.json" >> Id !! 2) () +-- PresentT (Object (fromList [("lastName",String "Doe"),("age",Number 45.0),("firstName",String "John"),("likesPizza",Bool False)])) +-- +data ParseJsonFile' t p + +instance (P p x + , PP p x ~ String + , Typeable (PP t x) + , Show (PP t x) + , A.FromJSON (PP t x) + ) => P (ParseJsonFile' t p) x where + type PP (ParseJsonFile' t p) x = PP t x + eval _ opts x = do + let msg0 = "ParseJsonFile " <> t + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let hhs = [hh pp] + msg1 = msg0 <> "(" <> p <> ")" + mb <- runIO $ do + b <- doesFileExist p + if b then Just <$> BS8.readFile p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (FailT msg1) "" hhs + Just Nothing -> mkNode opts (FailT (msg1 <> " file does not exist")) "" hhs + Just (Just s) -> + case A.eitherDecodeStrict' s of + Right b -> mkNode opts (PresentT b) (msg1 <> " " ++ showL opts b) hhs + Left e -> mkNode opts (FailT (msg1 <> " " <> takeWhile (/=':') e)) (e <> " | " <> litBS opts s) hhs + +data ParseJsonFile (t :: Type) p +type ParseJsonFileT (t :: Type) p = ParseJsonFile' (Hole t) p + +instance P (ParseJsonFileT t p) x => P (ParseJsonFile t p) x where + type PP (ParseJsonFile t p) x = PP (ParseJsonFileT t p) x + eval _ = eval (Proxy @(ParseJsonFileT t p)) + +-- | encode json +-- +-- >>> pl @(EncodeJson Id) (10,"def") +-- Present "[10,\"def\"]" (EncodeJson [10,"def"]) +-- PresentT "[10,\"def\"]" +-- +-- >>> pl @(EncodeJson Id >> ParseJson (Int,Bool) Id) (1,True) +-- Present (1,True) ((>>) (1,True) | {ParseJson (Int,Bool) (1,True)}) +-- PresentT (1,True) +-- +data EncodeJson p + +instance ( A.ToJSON (PP p x) + , P p x + ) => P (EncodeJson p) x where + type PP (EncodeJson p) x = BL8.ByteString + eval _ opts x = do + let msg0 = "EncodeJson" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = A.encode p + in mkNode opts (PresentT d) (msg0 <> " " <> litL opts (litBL opts d)) [hh pp] + +-- | encode a json file +data EncodeJsonFile p q + +instance (PP p x ~ String + , P p x + , A.ToJSON (PP q x) + , P q x + ) => P (EncodeJsonFile p q) x where + type PP (EncodeJsonFile p q) x = () + eval _ opts x = do + let msg0 = "EncodeJsonFile" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let d = A.encode q + hhs = [hh pp, hh qq] + mb <- runIO $ BL8.writeFile p d + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" hhs + Just () -> mkNode opts (PresentT ()) (msg0 <> " " <> litL opts (litBL opts d)) hhs + +-- | uncurry experiment +-- +-- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2019-10-12" +-- False (Uncurry (2019-10-12 <= 2018-12-30)) +-- FalseT +-- +-- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2017-10-12" +-- True (Uncurry (2017-04-11 <= 2017-10-12 <= 2018-12-30)) +-- TrueT +-- +-- >>> pl @(Uncurry Between (ReadP (Day,Day) "(2017-04-11,2018-12-30)") (ReadP Day Id)) "2016-10-12" +-- False (Uncurry (2017-04-11 <= 2016-10-12)) +-- FalseT +-- +data Uncurry (p :: Type -> Type -> Type -> Type) q r + +instance (PP q x ~ (a,b) + , PP (p a b (PP r x)) x ~ PP (p (Fst Id) (Snd Id) (Thd Id)) (a, b, PP r x) + , P q x + , P r x + , P (p (Fst Id) (Snd Id) (Thd Id)) (a,b,PP r x) + ) => P (Uncurry p q r) x where + type PP (Uncurry p q r) x = PP (p (ExtractL1T (PP q x)) (ExtractL2T (PP q x)) (PP r x)) x + eval _ opts x = do + let msg0 = "Uncurry" + lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts x [] + case lr of + Left e -> pure e + Right ((q1,q2),r,qq,rr) -> do + let hhs0 = [hh qq, hh rr] + pp <- eval (Proxy @(p (Fst Id) (Snd Id) (Thd Id))) opts (q1,q2,r) + pure $ case getValueLR opts msg0 pp hhs0 of + Left e -> e + Right _ -> + let hhs = hhs0 ++ [hh pp] + in mkNode opts (_tBool pp) (msg0 <> litVerbose opts " " (topMessage pp)) hhs + +-- | like 'Predicate.Prelude.&&' but for a tuple +-- +-- >>> pl @(SplitAt 4 "abcdefg" >> Len > 4 &* Len < 5) () +-- False ((>>) False | {False (&*) True | (4 > 4)}) +-- FalseT +-- +data AndA p q r +instance (PP r x ~ (a,b) + , PP p a ~ Bool + , PP q b ~ Bool + , P p a + , P q b + , P r x + ) => P (AndA p q r) x where + type PP (AndA p q r) x = Bool + eval _ opts x = do + let msg0 = "(&*)" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right (r1,r2) -> do + pp <- evalBool (Proxy @p) opts r1 + case getValueLR opts msg0 pp [hh rr] of + Left e -> pure e + Right p -> do + qq <- evalBool (Proxy @q) opts r2 + pure $ case getValueLR opts msg0 qq [hh rr, hh pp] of + Left e -> e + Right q -> + let zz = case (p,q) of + (True, True) -> "" + (False, True) -> topMessage pp + (True, False) -> topMessage qq + (False, False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + in mkNodeB opts (p&&q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> (if null zz then zz else " | " <> zz)) [hh rr, hh pp, hh qq] + +data p &* q +type AndAT p q = AndA p q Id +infixr 3 &* + +instance P (AndAT p q) x => P (p &* q) x where + type PP (p &* q) x = PP (AndAT p q) x + eval _ = evalBool (Proxy @(AndAT p q)) + +{- +data p &&! q +type AndAT' p q = (Fst Id >> p) && (Snd Id >> q) +infixr 3 &&! + +instance (P (AndAT' p q) x + ) => P (p &&! q) x where + type PP (p &&! q) x = PP (AndAT' p q) x + eval _ = evalBool (Proxy @(AndAT' p q)) +-} + +-- | like 'Predicate.Prelude.||' but for a tuple +-- +-- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,8,14,44],9) +-- True (True (|+) False) +-- TrueT +-- +-- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],9) +-- False (False (|+) False | (32 > 44) (|+) (9 < 2)) +-- FalseT +-- +-- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],1) +-- True (False (|+) True) +-- TrueT +-- +data OrA p q r +instance (PP r x ~ (a,b) + , PP p a ~ Bool + , PP q b ~ Bool + , P p a + , P q b + , P r x + ) => P (OrA p q r) x where + type PP (OrA p q r) x = Bool + eval _ opts x = do + let msg0 = "(|+)" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right (r1,r2) -> do + pp <- evalBool (Proxy @p) opts r1 + case getValueLR opts msg0 pp [hh rr] of + Left e -> pure e + Right p -> do + qq <- evalBool (Proxy @q) opts r2 + pure $ case getValueLR opts msg0 qq [hh rr, hh pp] of + Left e -> e + Right q -> + let zz = case (p,q) of + (False,False) -> topMessage pp <> " " <> msg0 <> " " <> topMessage qq + _ -> "" + in mkNodeB opts (p||q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> (if null zz then zz else " | " <> zz)) [hh rr, hh pp, hh qq] + +data p |+ q +type OrAT p q = OrA p q Id +infixr 3 |+ + +instance P (OrAT p q) x => P (p |+ q) x where + type PP (p |+ q) x = PP (OrAT p q) x + eval _ = evalBool (Proxy @(OrAT p q)) + +-- | very simple conversion to a string +data ToString p +instance ( ToStringC (PP p x) + , P p x + ) => P (ToString p) x where + type PP (ToString p) x = String + eval _ opts x = do + let msg0 = "ToString" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = toStringC p + in mkNode opts (PresentT d) msg0 [hh pp] + +class ToStringC a where + toStringC :: a -> String +instance ToStringC String where + toStringC = id +instance ToStringC T.Text where + toStringC = T.unpack +instance ToStringC TL.Text where + toStringC = TL.unpack +instance ToStringC BL8.ByteString where + toStringC = BL8.unpack +instance ToStringC BS8.ByteString where + toStringC = BS8.unpack + +-- | splits a list pointed to by \'p\' into lists of size \'n\' +-- +-- >>> pz @(ChunksOf 2 Id) "abcdef" +-- PresentT ["ab","cd","ef"] +-- +-- >>> pz @(ChunksOf 2 Id) "abcdefg" +-- PresentT ["ab","cd","ef","g"] +-- +-- >>> pz @(ChunksOf 2 Id) "" +-- PresentT [] +-- +-- >>> pz @(ChunksOf 2 Id) "a" +-- PresentT ["a"] +-- +data ChunksOf n p + +instance (PP p a ~ [b] + , P n a + , P p a + , Show b + , Integral (PP n a) + ) => P (ChunksOf n p) a where + type PP (ChunksOf n p) a = [PP p a] + eval _ opts a = do + let msg0 = "ChunksOf" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> n,p,pp,qq) -> + let hhs = [hh pp, hh qq] + msg1 = msg0 <> " " <> showL opts n <> " " <> showL opts p + in if n <= 0 then mkNode opts (FailT (msg0 <> " n<1")) "" hhs + else let ret = unfoldr (\s -> if null s then Nothing else Just $ splitAt n s) p + in mkNode opts (PresentT ret) (show01' opts msg1 ret "n=" n <> showVerbose opts " | " p) hhs data Rotate n p type RotateT n p = SplitAt n p >> Swap >> First Reverse >> SapA diff --git a/src/Predicate/Refined.hs b/src/Predicate/Refined.hs --- a/src/Predicate/Refined.hs +++ b/src/Predicate/Refined.hs @@ -52,7 +52,6 @@ , convertRefinedT , unRavelT , rapply - , rapply0 , rapplyLift -- ** unsafe create methods @@ -94,49 +93,49 @@ -- | a simple refinement type that ensures the predicate \'p\' holds for the type \'a\' -- --- >>> prtRefinedIO @'OZ @(Between 10 14 Id) 13 +-- >>> prtRefinedIO @OZ @(Between 10 14 Id) 13 -- Right (Refined 13) -- --- >>> prtRefinedIO @'OZ @(Between 10 14 Id) 99 +-- >>> prtRefinedIO @OZ @(Between 10 14 Id) 99 -- Left FalseT -- --- >>> prtRefinedIO @'OZ @(Last Id >> Len == 4) ["one","two","three","four"] +-- >>> prtRefinedIO @OZ @(Last Id >> Len == 4) ["one","two","three","four"] -- Right (Refined ["one","two","three","four"]) -- --- >>> prtRefinedIO @'OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) "141.213.1.99" +-- >>> prtRefinedIO @OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) "141.213.1.99" -- Right (Refined "141.213.1.99") -- --- >>> prtRefinedIO @'OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) "141.213.1" +-- >>> prtRefinedIO @OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) "141.213.1" -- Left FalseT -- --- >>> prtRefinedIO @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> 'True) "141.213.1" +-- >>> prtRefinedIO @OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> 'True) "141.213.1" -- Left (FailT "bad length: found 3") -- --- >>> prtRefinedIO @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> GuardsN (PrintT "octet %d out of range %d" Id) 4 (Between 0 255 Id) >> 'True) "141.213.1.444" +-- >>> prtRefinedIO @OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> GuardsN (PrintT "octet %d out of range %d" Id) 4 (Between 0 255 Id) >> 'True) "141.213.1.444" -- Left (FailT "octet 3 out of range 444") -- --- >>> prtRefinedIO @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> GuardsN (PrintT "octet %d out of range %d" Id) 4 (Between 0 255 Id) >> 'True) "141.213.1x34.444" +-- >>> prtRefinedIO @OZ @(Map (ReadP Int Id) (Resplit "\\." Id) >> Guard (PrintF "bad length: found %d" Len) (Len == 4) >> GuardsN (PrintT "octet %d out of range %d" Id) 4 (Between 0 255 Id) >> 'True) "141.213.1x34.444" -- Left (FailT "ReadP Int (1x34)") -- --- >>> prtRefinedIO @'OZ @(Map ('[Id] >> ReadP Int Id) Id >> Luhn Id) "12344" +-- >>> prtRefinedIO @OZ @(Map ('[Id] >> ReadP Int Id) Id >> Luhn Id) "12344" -- Right (Refined "12344") -- --- >>> prtRefinedIO @'OZ @(Map ('[Id] >> ReadP Int Id) Id >> Luhn Id) "12340" +-- >>> prtRefinedIO @OZ @(Map ('[Id] >> ReadP Int Id) Id >> Luhn Id) "12340" -- Left FalseT -- --- >>> prtRefinedIO @'OZ @(Any (Prime Id) Id) [11,13,17,18] +-- >>> prtRefinedIO @OZ @(Any (Prime Id) Id) [11,13,17,18] -- Right (Refined [11,13,17,18]) -- --- >>> prtRefinedIO @'OZ @(All (Prime Id) Id) [11,13,17,18] +-- >>> prtRefinedIO @OZ @(All (Prime Id) Id) [11,13,17,18] -- Left FalseT -- --- >>> prtRefinedIO @'OZ @(Snd Id !! Fst Id >> Len > 5) (2,["abc","defghij","xyzxyazsfd"]) +-- >>> prtRefinedIO @OZ @(Snd Id !! Fst Id >> Len > 5) (2,["abc","defghij","xyzxyazsfd"]) -- Right (Refined (2,["abc","defghij","xyzxyazsfd"])) -- --- >>> prtRefinedIO @'OZ @(Snd Id !! Fst Id >> Len > 5) (27,["abc","defghij","xyzxyazsfd"]) +-- >>> prtRefinedIO @OZ @(Snd Id !! Fst Id >> Len > 5) (27,["abc","defghij","xyzxyazsfd"]) -- Left (FailT "(!!) index not found") -- --- >>> prtRefinedIO @'OZ @(Snd Id !! Fst Id >> Len <= 5) (2,["abc","defghij","xyzxyazsfd"]) +-- >>> prtRefinedIO @OZ @(Snd Id !! Fst Id >> Len <= 5) (2,["abc","defghij","xyzxyazsfd"]) -- Left FalseT -- newtype Refined (opts :: OptT) p a = Refined a deriving (Show, Eq, Generic, TH.Lift) @@ -149,10 +148,10 @@ -- | 'IsString' instance for Refined -- --- >>> pureTryTest $ fromString @(Refined 'OL (ReadP Int Id >> Id > 244) String) "523" +-- >>> pureTryTest $ fromString @(Refined OL (ReadP Int Id >> Id > 244) String) "523" -- Right (Refined "523") -- --- >>> pureTryTest $ fromString @(Refined 'OL (ReadP Int Id >> Id > 244) String) "52" +-- >>> pureTryTest $ fromString @(Refined OL (ReadP Int Id >> Id > 244) String) "52" -- Left () -- instance RefinedC opts p String => IsString (Refined opts p String) where @@ -168,13 +167,13 @@ -- | 'Read' instance for 'Refined' -- --- >>> reads @(Refined 'OZ (Between 0 255 Id) Int) "Refined 254" +-- >>> reads @(Refined OZ (Between 0 255 Id) Int) "Refined 254" -- [(Refined 254,"")] -- --- >>> reads @(Refined 'OZ (Between 0 255 Id) Int) "Refined 300" +-- >>> reads @(Refined OZ (Between 0 255 Id) Int) "Refined 300" -- [] -- --- >>> reads @(Refined 'OZ 'True Int) "Refined (-123)xyz" +-- >>> reads @(Refined OZ 'True Int) "Refined (-123)xyz" -- [(Refined (-123),"xyz")] -- instance (RefinedC opts p a, Read a) => Read (Refined opts p a) where @@ -202,10 +201,10 @@ -- -- >>> :set -XOverloadedStrings -- >>> import qualified Data.Aeson as A --- >>> A.eitherDecode' @(Refined 'OZ (Between 10 14 Id) Int) "13" +-- >>> A.eitherDecode' @(Refined OZ (Between 10 14 Id) Int) "13" -- Right (Refined 13) -- --- >>> removeAnsi $ A.eitherDecode' @(Refined 'OAN (Between 10 14 Id) Int) "16" +-- >>> removeAnsi $ A.eitherDecode' @(Refined OAN (Between 10 14 Id) Int) "16" -- Error in $: Refined(FromJSON:parseJSON):FalseT (16 <= 14) -- False 16 <= 14 -- | @@ -229,9 +228,9 @@ -- >>> import Data.Time -- >>> import Control.Lens -- >>> import Control.Arrow ((+++)) --- >>> type K1 = Refined 'OZ (ReadP Day Id >> 'True) String --- >>> type K2 = Refined 'OAN (Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") (ReadP Day Id)) String --- >>> r = unsafeRefined' @'OZ "2019-04-23" :: K1 +-- >>> type K1 = Refined OZ (ReadP Day Id >> 'True) String +-- >>> type K2 = Refined OAN (Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") (ReadP Day Id)) String +-- >>> r = unsafeRefined' @OZ "2019-04-23" :: K1 -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) -- Refined "2019-04-23" -- @@ -245,11 +244,11 @@ -- | -- +- P ReadP Day 2019-05-30 -- | | --- | `- P '2019-05-30 +-- | `- P '"2019-05-30" -- | -- `- P ReadP Day 2019-06-01 -- | --- `- P '2019-06-01 +-- `- P '"2019-06-01" -- -- instance (RefinedC opts p a, Binary a) => Binary (Refined opts p a) where @@ -269,11 +268,11 @@ -- | 'Arbitrary' instance for 'Refined' -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined 'OU (Id /= 0) Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OU (Id /= 0) Int))) -- >>> all ((/=0) . unRefined) xs -- True -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined 'OU (Prime Id) Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OU (Prime Id) Int))) -- >>> all (isPrime . unRefined) xs -- True -- @@ -301,27 +300,98 @@ in f 0 -- | binary operation applied to two 'RefinedT' values -rapply :: forall m opts p a . (RefinedC opts p a, Monad m) +-- +-- >>> x = newRefinedT @_ @OAN @(Between 4 12 Id) 4 +-- >>> y = newRefinedT @_ @OAN @(Between 4 12 Id) 5 +-- >>> prtRefinedTIO (rapply (+) x y) +-- === a === +-- True 4 <= 4 <= 12 +-- | +-- +- P Id 4 +-- | +-- +- P '4 +-- | +-- `- P '12 +-- +-- === b === +-- True 4 <= 5 <= 12 +-- | +-- +- P Id 5 +-- | +-- +- P '4 +-- | +-- `- P '12 +-- +-- === a `op` b === +-- True 4 <= 9 <= 12 +-- | +-- +- P Id 9 +-- | +-- +- P '4 +-- | +-- `- P '12 +-- +-- Refined 9 +-- +-- >>> x = newRefinedT @_ @OAN @(Prime Id || Id < 3) 3 +-- >>> y = newRefinedT @_ @OAN @(Prime Id || Id < 3) 5 +-- >>> prtRefinedTIO (rapply (+) x y) +-- === a === +-- True True || False +-- | +-- +- True Prime +-- | | +-- | `- P Id 3 +-- | +-- `- False 3 < 3 +-- | +-- +- P Id 3 +-- | +-- `- P '3 +-- +-- === b === +-- True True || False +-- | +-- +- True Prime +-- | | +-- | `- P Id 5 +-- | +-- `- False 5 < 3 +-- | +-- +- P Id 5 +-- | +-- `- P '3 +-- +-- === a `op` b === +-- False False || False | (Prime) || (8 < 3) +-- | +-- +- False Prime +-- | | +-- | `- P Id 8 +-- | +-- `- False 8 < 3 +-- | +-- +- P Id 8 +-- | +-- `- P '3 +-- +-- failure msg[FalseT] +-- +rapply :: forall m opts p a opts1 z . (z ~ (opts ':# opts1), OptTC opts1, RefinedC opts p a, Monad m) => (a -> a -> a) -> RefinedT m (Refined opts p a) - -> RefinedT m (Refined opts p a) - -> RefinedT m (Refined opts p a) + -> RefinedT m (Refined opts1 p a) + -> RefinedT m (Refined z p a) rapply f ma mb = do let opts = getOptT @opts tell [setOtherEffects opts "=== a ==="] Refined x <- ma - tell [setOtherEffects opts "=== b ==="] + let opts1 = getOptT @opts1 + tell [setOtherEffects opts1 "=== b ==="] Refined y <- mb - tell [setOtherEffects opts "=== a `op` b ==="] - newRefinedT @m @opts @p (f x y) - --- | takes two values and lifts them into 'RefinedT' and then applies the binary operation -rapply0 :: forall opts p a m . (RefinedC opts p a, Monad m) - => (a -> a -> a) - -> a - -> a - -> RefinedT m (Refined opts p a) -rapply0 f a b = rapply f (newRefinedT a) (newRefinedT b) + let opts2 = getOptT @z + tell [setOtherEffects opts2 "=== a `op` b ==="] + newRefinedT @_ @_ @p (f x y) -- | same as 'rapply' except we already have valid 'Refined' values as input rapplyLift :: forall m opts p a . (RefinedC opts p a, Monad m) @@ -382,10 +452,10 @@ -- | returns a 'Refined' value if \'a\' is valid for the predicate \'p\' -- --- >>> newRefined @'OL @(ReadP Int Id > 99) "123" +-- >>> newRefined @OL @(ReadP Int Id > 99) "123" -- Right (Refined "123") -- --- >>> newRefined @'OL @(ReadP Int Id > 99) "12" +-- >>> newRefined @OL @(ReadP Int Id > 99) "12" -- Left "FalseT (12 > 99)" -- newRefined :: forall opts p a @@ -471,7 +541,11 @@ unRavelT :: RefinedT m a -> m (Either String a, [String]) unRavelT = runWriterT . runExceptT . unRefinedT -prtRefinedTImpl :: forall n m a . (MonadIO n, Show a) => (forall x . m x -> n x) -> RefinedT m a -> n () +prtRefinedTImpl :: forall n m a + . (MonadIO n, Show a) + => (forall x . m x -> n x) + -> RefinedT m a + -> n () prtRefinedTImpl f rt = do (lr,ws) <- f $ unRavelT rt liftIO $ do diff --git a/src/Predicate/Refined1.hs b/src/Predicate/Refined1.hs --- a/src/Predicate/Refined1.hs +++ b/src/Predicate/Refined1.hs @@ -147,35 +147,35 @@ -- -- Although a common scenario is String as input, you are free to choose any input type you like -- --- >>> newRefined1 @'OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fe" +-- >>> newRefined1 @OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fe" -- Right (Refined1 254) -- --- >>> newRefined1 @'OZ @(ReadBase Int 16 Id) @(Lt 253) @(PrintF "%x" Id) "00fe" +-- >>> newRefined1 @OZ @(ReadBase Int 16 Id) @(Lt 253) @(PrintF "%x" Id) "00fe" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined1 @'OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fg" +-- >>> newRefined1 @OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fg" -- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" -- --- >>> newRefined1 @'OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" +-- >>> newRefined1 @OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" -- Left "Step 2. False Boolean Check(op) | {length invalid:5 == 4}" -- --- >>> newRefined1 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" +-- >>> newRefined1 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" -- Left "Step 2. Failed Boolean Check(op) | found length=5" -- --- >>> newRefined1 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1" +-- >>> newRefined1 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1" -- Right (Refined1 [198,162,3,1]) -- -- >>> :m + Data.Time.Calendar.WeekDate --- >>> newRefined1 @'OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,13) +-- >>> newRefined1 @OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,13) -- Right (Refined1 (2019-10-13,41,7)) -- --- >>> newRefined1 @'OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) @(UnMkDay (Fst Id)) (2019,10,12) +-- >>> newRefined1 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) @(UnMkDay (Fst Id)) (2019,10,12) -- Left "Step 2. False Boolean Check(op) | {expected a Sunday:6 == 7}" -- --- >>> newRefined1 @'OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,12) +-- >>> newRefined1 @OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,12) -- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" -- --- >>> type T4 k = '( 'OZ, MkDayExtra Id >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) +-- >>> type T4 k = '( OZ, MkDayExtra Id >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) -- >>> newRefined1P (Proxy @(T4 _)) (2019,10,12) -- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" -- @@ -216,16 +216,24 @@ , PP fmt (PP ip i) ~ i -- the output type must match the original input type ) -deriving instance (Show i, Show (PP ip i), Show (PP fmt (PP ip i))) => Show (Refined1 opts ip op fmt i) -deriving instance (Eq i, Eq (PP ip i), Eq (PP fmt (PP ip i))) => Eq (Refined1 opts ip op fmt i) -deriving instance (TH.Lift (PP ip i), TH.Lift (PP fmt (PP ip i))) => TH.Lift (Refined1 opts ip op fmt i) +deriving instance ( Show i + , Show (PP ip i) + , Show (PP fmt (PP ip i)) + ) => Show (Refined1 opts ip op fmt i) +deriving instance ( Eq i + , Eq (PP ip i) + , Eq (PP fmt (PP ip i)) + ) => Eq (Refined1 opts ip op fmt i) +deriving instance ( TH.Lift (PP ip i) + , TH.Lift (PP fmt (PP ip i)) + ) => TH.Lift (Refined1 opts ip op fmt i) -- | 'IsString' instance for Refined1 -- --- >>> pureTryTest $ fromString @(Refined1 'OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "523" +-- >>> pureTryTest $ fromString @(Refined1 OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "523" -- Right (Refined1 523) -- --- >>> pureTryTest $ fromString @(Refined1 'OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "2" +-- >>> pureTryTest $ fromString @(Refined1 OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "2" -- Left () -- instance (Refined1C opts ip op fmt String, Show (PP ip String)) => IsString (Refined1 opts ip op fmt String) where @@ -236,19 +244,19 @@ -- read instance from -ddump-deriv -- | 'Read' instance for 'Refined1' -- --- >>> reads @(Refined1 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined1 254" +-- >>> reads @(Refined1 OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined1 254" -- [(Refined1 254,"")] -- --- >>> reads @(Refined1 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined1 300" +-- >>> reads @(Refined1 OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined1 300" -- [] -- --- >>> reads @(Refined1 'OZ (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined1 (-1234)" +-- >>> reads @(Refined1 OZ (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined1 (-1234)" -- [(Refined1 (-1234),"")] -- --- >>> reads @(Refined1 'OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (PrintL 4 "%d.%d.%d.%d" Id) String) "Refined1 [192,168,0,1]" +-- >>> reads @(Refined1 OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (PrintL 4 "%d.%d.%d.%d" Id) String) "Refined1 [192,168,0,1]" -- [(Refined1 [192,168,0,1],"")] -- --- >>> reads @(Refined1 'OZ Id 'True Id Int) "Refined1 (-123)xyz" +-- >>> reads @(Refined1 OZ Id 'True Id Int) "Refined1 (-123)xyz" -- [(Refined1 (-123),"xyz")] -- @@ -281,10 +289,10 @@ -- | 'ToJSON' instance for 'Refined1' -- -- >>> import qualified Data.Aeson as A --- >>> A.encode (unsafeRefined1 @'OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) @(ShowBase 16 Id) 254) +-- >>> A.encode (unsafeRefined1 @OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) @(ShowBase 16 Id) 254) -- "\"fe\"" -- --- >>> A.encode (unsafeRefined1 @'OZ @Id @'True @Id 123) +-- >>> A.encode (unsafeRefined1 @OZ @Id @'True @Id 123) -- "123" -- instance ( OptTC opts @@ -302,15 +310,15 @@ -- | 'FromJSON' instance for 'Refined1' -- -- >>> import qualified Data.Aeson as A --- >>> A.eitherDecode' @(Refined1 'OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe\"" +-- >>> A.eitherDecode' @(Refined1 OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe\"" -- Right (Refined1 254) -- --- >>> removeAnsi $ A.eitherDecode' @(Refined1 'OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe443a\"" +-- >>> removeAnsi $ A.eitherDecode' @(Refined1 OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe443a\"" -- Error in $: Refined1:Step 2. False Boolean Check(op) | {True && False | (16663610 < 256)} -- --- *** Step 1. Success Initial Conversion(ip) [16663610] *** +-- *** Step 1. Success Initial Conversion(ip) (16663610) *** -- --- P ReadBase(Int,16) 16663610 | "00fe443a" +-- P ReadBase(Int,16) 16663610 -- | -- `- P Id "00fe443a" -- @@ -344,11 +352,11 @@ Just r -> return r -- | 'Arbitrary' instance for 'Refined1' -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined1 'OU (ReadP Int Id) (1 <..> 120 && Even) (ShowP Id) String))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined1 OU (ReadP Int Id) (1 <..> 120 && Even) (ShowP Id) String))) -- >>> all ((/=0) . unRefined1) xs -- True -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined1 'OU Id (Prime Id) Id Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined1 OU Id (Prime Id) Id Int))) -- >>> all (isPrime . unRefined1) xs -- True -- @@ -359,7 +367,7 @@ -- | create a 'Refined1' generator -- --- >>> g = genRefined1 @'OU @(ReadP Int Id) @(Between 10 100 Id && Even) @(ShowP Id) (choose (10,100)) +-- >>> g = genRefined1 @OU @(ReadP Int Id) @(Between 10 100 Id && Even) @(ShowP Id) (choose (10,100)) -- >>> xs <- generate (vectorOf 10 g) -- >>> all (\x -> let y = unRefined1 x in y >= 0 && y <= 100 && even y) xs -- True @@ -396,8 +404,8 @@ -- >>> import Control.Arrow ((+++)) -- >>> import Control.Lens -- >>> import Data.Time --- >>> type K1 = MakeR1 '( 'OAN, ReadP Day Id, 'True, ShowP Id, String) --- >>> type K2 = MakeR1 '( 'OAN, ReadP Day Id, Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id, ShowP Id, String) +-- >>> type K1 = MakeR1 '( OAN, ReadP Day Id, 'True, ShowP Id, String) +-- >>> type K2 = MakeR1 '( OAN, ReadP Day Id, Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id, ShowP Id, String) -- >>> r = unsafeRefined1' "2019-04-23" :: K1 -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) -- Refined1 2019-04-23 @@ -405,7 +413,7 @@ -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) -- Refined1:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} -- --- *** Step 1. Success Initial Conversion(ip) [2019-04-23] *** +-- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** -- -- P ReadP Day 2019-04-23 -- | @@ -419,11 +427,11 @@ -- | -- +- P ReadP Day 2019-05-30 -- | | --- | `- P '2019-05-30 +-- | `- P '"2019-05-30" -- | -- `- P ReadP Day 2019-06-01 -- | --- `- P '2019-06-01 +-- `- P '"2019-06-01" -- -- @@ -456,17 +464,20 @@ -- -- set the 5-tuple directly -- --- >>> eg1 = mkProxy1 @'( 'OL, ReadP Int Id, Gt 10, ShowP Id, String) +-- >>> eg1 = mkProxy1 @'( OL, ReadP Int Id, Gt 10, ShowP Id, String) -- >>> newRefined1P eg1 "24" -- Right (Refined1 24) -- -- skip the 5-tuple and set each parameter individually using type application -- --- >>> eg2 = mkProxy1 @_ @'OL @(ReadP Int Id) @(Gt 10) @(ShowP Id) +-- >>> eg2 = mkProxy1 @_ @OL @(ReadP Int Id) @(Gt 10) @(ShowP Id) -- >>> newRefined1P eg2 "24" -- Right (Refined1 24) -- -mkProxy1 :: forall z opts ip op fmt i . z ~ '(opts,ip,op,fmt,i) => Proxy '(opts,ip,op,fmt,i) +mkProxy1 :: + forall z opts ip op fmt i + . z ~ '(opts,ip,op,fmt,i) + => Proxy '(opts,ip,op,fmt,i) mkProxy1 = Proxy -- | same as 'mkProxy1' but checks to make sure the proxy is consistent with the 'Refined1C' constraint @@ -500,16 +511,16 @@ -- >>> :set -XRankNTypes -- >>> b16 :: forall opts . Proxy '( opts, ReadBase Int 16 Id, Between 100 200 Id, ShowBase 16 Id, String); b16 = Proxy -- >>> b2 :: forall opts . Proxy '( opts, ReadBase Int 2 Id, 'True, ShowBase 2 Id, String); b2 = Proxy --- >>> prtRefinedTIO $ withRefined1TP (b16 @'OZ) "a3" $ \x -> withRefined1TP (b2 @'OZ) "1001110111" $ \y -> pure (unRefined1 x + unRefined1 y) +-- >>> prtRefinedTIO $ withRefined1TP (b16 @OZ) "a3" $ \x -> withRefined1TP (b2 @OZ) "1001110111" $ \y -> pure (unRefined1 x + unRefined1 y) -- 794 -- -- this example fails as the the hex value is out of range -- --- >>> prtRefinedTIO $ withRefined1TP (b16 @'OAN) "a388" $ \x -> withRefined1TP (b2 @'OAN) "1001110111" $ \y -> pure (x,y) +-- >>> prtRefinedTIO $ withRefined1TP (b16 @OAN) "a388" $ \x -> withRefined1TP (b2 @OAN) "1001110111" $ \y -> pure (x,y) -- --- *** Step 1. Success Initial Conversion(ip) [41864] *** +-- *** Step 1. Success Initial Conversion(ip) (41864) *** -- --- P ReadBase(Int,16) 41864 | "a388" +-- P ReadBase(Int,16) 41864 -- | -- `- P Id "a388" -- @@ -549,13 +560,13 @@ -- | pure version for extracting Refined1 -- --- >>> newRefined1 @'OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:15:7" +-- >>> newRefined1 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:15:7" -- Right (Refined1 01:15:07) -- --- >>> newRefined1 @'OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:2:x" +-- >>> newRefined1 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:2:x" -- Left "Step 1. Initial Conversion(ip) Failed | ParseTimeP TimeOfDay (%-H:%-M:%-S) failed to parse" -- --- >>> newRefined1 @'OL @(Rescan "^(\\d{1,2}):(\\d{1,2}):(\\d{1,2})$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) @(All (0 <..> 59) Id && Len == 3) @(PrintL 3 "%02d:%02d:%02d" Id) "1:2:3" +-- >>> newRefined1 @OL @(Rescan "^(\\d{1,2}):(\\d{1,2}):(\\d{1,2})$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) @(All (0 <..> 59) Id && Len == 3) @(PrintL 3 "%02d:%02d:%02d" Id) "1:2:3" -- Right (Refined1 [1,2,3]) -- newRefined1 :: forall opts ip op fmt i @@ -591,13 +602,13 @@ -- | create a wrapped 'Refined1' type -- --- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( 'OZ, MkDayExtra Id >> Just Id, GuardSimple (Thd Id == 5) >> 'True, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,1) +-- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( OZ, MkDayExtra Id >> Just Id, GuardSimple (Thd Id == 5) >> 'True, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,1) -- Refined1 (2019-11-01,44,5) -- --- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( 'OL, MkDayExtra Id >> Just Id, Thd Id == 5, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( OL, MkDayExtra Id >> Just Id, Thd Id == 5, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {6 == 5}] -- --- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( 'OL, MkDayExtra Id >> Just Id, Msg "wrong day:" (Thd Id == 5), UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined1TP (Proxy @'( OL, MkDayExtra Id >> Just Id, Msg "wrong day:" (Thd Id == 5), UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {wrong day:6 == 5}] -- newRefined1TP :: forall m opts ip op fmt i proxy @@ -707,8 +718,7 @@ Refined1 y <- mb -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call tell [setOtherEffects opts "=== a `op` b ==="] - Refined1 a <- newRefined1TPSkipIPImpl (return . runIdentity) p (f x y) - return (Refined1 a) + newRefined1TPSkipIPImpl (return . runIdentity) p (f x y) -- | An ADT that summarises the results of evaluating Refined1 representing all possible states data RResults1 a b = @@ -833,7 +843,7 @@ -> Msg1 prt1Impl opts v = let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) [" ++ show a ++ "]") + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) (" ++ show a ++ ")") mkMsg1 m n r | hasNoTree opts = Msg1 m n "" | otherwise = Msg1 m n r in case v of diff --git a/src/Predicate/Refined2.hs b/src/Predicate/Refined2.hs --- a/src/Predicate/Refined2.hs +++ b/src/Predicate/Refined2.hs @@ -117,32 +117,32 @@ -- -- Although a common scenario is String as input, you are free to choose any input type you like -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @(Lt 255) "00fe" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(Lt 255) "00fe" -- Right (Refined2 {r2In = 254, r2Out = "00fe"}) -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @(Lt 253) "00fe" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(Lt 253) "00fe" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined2 @'OZ @(ReadBase Int 16 Id) @(Lt 255) "00fg" +-- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(Lt 255) "00fg" -- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" -- --- >>> newRefined2 @'OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) "198.162.3.1.5" +-- >>> newRefined2 @OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) "198.162.3.1.5" -- Left "Step 2. False Boolean Check(op) | {length invalid:5 == 4}" -- --- >>> newRefined2 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) "198.162.3.1.5" +-- >>> newRefined2 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) "198.162.3.1.5" -- Left "Step 2. Failed Boolean Check(op) | found length=5" -- --- >>> newRefined2 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) "198.162.3.1" +-- >>> newRefined2 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) "198.162.3.1" -- Right (Refined2 {r2In = [198,162,3,1], r2Out = "198.162.3.1"}) -- -- >>> :m + Data.Time.Calendar.WeekDate --- >>> newRefined2 @'OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) (2019,10,13) +-- >>> newRefined2 @OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) (2019,10,13) -- Right (Refined2 {r2In = (2019-10-13,41,7), r2Out = (2019,10,13)}) -- --- >>> newRefined2 @'OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) (2019,10,12) +-- >>> newRefined2 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) (2019,10,12) -- Left "Step 2. False Boolean Check(op) | {expected a Sunday:6 == 7}" -- --- >>> newRefined2 @'OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) (2019,10,12) +-- >>> newRefined2 @OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) (2019,10,12) -- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" -- data Refined2 (opts :: OptT) ip op i = Refined2 { r2In :: !(PP ip i), r2Out :: !i } @@ -162,7 +162,10 @@ in fromMaybe (error $ show (prt2Impl (getOptT @opts) ret)) mr -- | directly load values into 'Refined2' without any checking -unsafeRefined2 :: forall opts ip op i . PP ip i -> i -> Refined2 opts ip op i +unsafeRefined2 :: forall opts ip op i + . PP ip i + -> i + -> Refined2 opts ip op i unsafeRefined2 = Refined2 -- | Provides the constraints on Refined2 @@ -179,10 +182,10 @@ -- | 'IsString' instance for Refined2 -- --- >>> pureTryTest $ fromString @(Refined2 'OL (ReadP Int Id) (Id > 12) String) "523" +-- >>> pureTryTest $ fromString @(Refined2 OL (ReadP Int Id) (Id > 12) String) "523" -- Right (Refined2 {r2In = 523, r2Out = "523"}) -- --- >>> pureTryTest $ fromString @(Refined2 'OL (ReadP Int Id) (Id > 12) String) "2" +-- >>> pureTryTest $ fromString @(Refined2 OL (ReadP Int Id) (Id > 12) String) "2" -- Left () -- instance ( s ~ String @@ -196,16 +199,16 @@ -- read instance from -ddump-deriv -- | 'Read' instance for 'Refined2' -- --- >>> reads @(Refined2 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 254, r2Out = \"fe\"}" +-- >>> reads @(Refined2 OZ (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 254, r2Out = \"fe\"}" -- [(Refined2 {r2In = 254, r2Out = "fe"},"")] -- --- >>> reads @(Refined2 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 300, r2Out = \"12c\"}" +-- >>> reads @(Refined2 OZ (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 300, r2Out = \"12c\"}" -- [] -- --- >>> reads @(Refined2 'OZ (ReadBase Int 16 Id) (Id < 0) String) "Refined2 {r2In = -1234, r2Out = \"-4d2\"}" +-- >>> reads @(Refined2 OZ (ReadBase Int 16 Id) (Id < 0) String) "Refined2 {r2In = -1234, r2Out = \"-4d2\"}" -- [(Refined2 {r2In = -1234, r2Out = "-4d2"},"")] -- --- >>> reads @(Refined2 'OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) String) "Refined2 {r2In = [192,168,0,1], r2Out = \"192.168.0.1\"}" +-- >>> reads @(Refined2 OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) String) "Refined2 {r2In = [192,168,0,1], r2Out = \"192.168.0.1\"}" -- [(Refined2 {r2In = [192,168,0,1], r2Out = "192.168.0.1"},"")] -- instance ( Eq i @@ -240,10 +243,10 @@ -- | 'ToJSON' instance for 'Refined2' -- -- >>> import qualified Data.Aeson as A --- >>> A.encode (unsafeRefined2 @'OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) 254 "fe") +-- >>> A.encode (unsafeRefined2 @OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) 254 "fe") -- "\"fe\"" -- --- >>> A.encode (unsafeRefined2 @'OZ @Id @'True @Int 123 123) +-- >>> A.encode (unsafeRefined2 @OZ @Id @'True @Int 123 123) -- "123" -- instance ToJSON i => ToJSON (Refined2 opts ip op i) where @@ -253,15 +256,15 @@ -- | 'FromJSON' instance for 'Refined2' -- -- >>> import qualified Data.Aeson as A --- >>> A.eitherDecode' @(Refined2 'OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) String) "\"00fe\"" +-- >>> A.eitherDecode' @(Refined2 OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) String) "\"00fe\"" -- Right (Refined2 {r2In = 254, r2Out = "00fe"}) -- --- >>> removeAnsi $ A.eitherDecode' @(Refined2 'OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) String) "\"00fe443a\"" +-- >>> removeAnsi $ A.eitherDecode' @(Refined2 OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) String) "\"00fe443a\"" -- Error in $: Refined2:Step 2. False Boolean Check(op) | {True && False | (16663610 < 256)} -- --- *** Step 1. Success Initial Conversion(ip) [16663610] *** +-- *** Step 1. Success Initial Conversion(ip) (16663610) *** -- --- P ReadBase(Int,16) 16663610 | "00fe443a" +-- P ReadBase(Int,16) 16663610 -- | -- `- P Id "00fe443a" -- @@ -297,7 +300,7 @@ -- | 'Arbitrary' instance for 'Refined2' -- -- >>> :m + Data.Time.Calendar.WeekDate --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined2 'OU (ToEnum Day Id) (Snd (ToWeekDate Id) == "Tuesday") Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined2 OU (ToEnum Day Id) (Snd (ToWeekDate Id) == "Tuesday") Int))) -- >>> all (\x -> let y = toEnum @Day (r2Out x) in view _3 (toWeekDate y) == 2 && r2In x == y) xs -- True -- @@ -309,7 +312,7 @@ -- | create a 'Refined2' generator using a generator to restrict the values (so it completes) -- --- >>> g = genRefined2 @'OU @(ToEnum Day Id) @(UnMkDay Id >> Snd Id == 10) arbitrary +-- >>> g = genRefined2 @OU @(ToEnum Day Id) @(UnMkDay Id >> Snd Id == 10) arbitrary -- >>> xs <- generate (vectorOf 10 g) -- >>> all (\x -> let y = toEnum @Day (fromIntegral (r2Out x)) in view _2 (toGregorian y) == 10 && y == r2In x) xs -- True @@ -353,8 +356,8 @@ -- -- >>> import Control.Arrow ((+++)) -- >>> import Data.Time --- >>> type K1 = Refined2 'OAN (ReadP Day Id) 'True String --- >>> type K2 = Refined2 'OAN (ReadP Day Id) (Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id) String +-- >>> type K1 = Refined2 OAN (ReadP Day Id) 'True String +-- >>> type K2 = Refined2 OAN (ReadP Day Id) (Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id) String -- >>> r = unsafeRefined2' "2019-04-23" :: K1 -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) -- Refined2 {r2In = 2019-04-23, r2Out = "2019-04-23"} @@ -362,7 +365,7 @@ -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) -- Refined2:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} -- --- *** Step 1. Success Initial Conversion(ip) [2019-04-23] *** +-- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** -- -- P ReadP Day 2019-04-23 -- | @@ -376,11 +379,11 @@ -- | -- +- P ReadP Day 2019-05-30 -- | | --- | `- P '2019-05-30 +-- | `- P '"2019-05-30" -- | -- `- P ReadP Day 2019-06-01 -- | --- `- P '2019-06-01 +-- `- P '"2019-06-01" -- -- instance ( Show i @@ -419,16 +422,16 @@ -- reads a binary string and adds the values together -- -- >>> :set -XPolyKinds --- >>> prtRefinedTIO $ withRefined2T @'OZ @(ReadBase Int 16 Id) @(Between 100 200 Id) "a3" $ \x -> withRefined2T @'OZ @(ReadBase Int 2 Id) @'True "1001110111" $ \y -> pure (r2In x + r2In y) +-- >>> prtRefinedTIO $ withRefined2T @OZ @(ReadBase Int 16 Id) @(Between 100 200 Id) "a3" $ \x -> withRefined2T @OZ @(ReadBase Int 2 Id) @'True "1001110111" $ \y -> pure (r2In x + r2In y) -- 794 -- -- this example fails as the the hex value is out of range -- --- >>> prtRefinedTIO $ withRefined2T @'OAN @(ReadBase Int 16 Id) @(Between 100 200 Id) "a388" $ \x -> withRefined2T @'OAN @(ReadBase Int 2 Id) @'True "1001110111" $ \y -> pure (x,y) +-- >>> prtRefinedTIO $ withRefined2T @OAN @(ReadBase Int 16 Id) @(Between 100 200 Id) "a388" $ \x -> withRefined2T @OAN @(ReadBase Int 2 Id) @'True "1001110111" $ \y -> pure (x,y) -- --- *** Step 1. Success Initial Conversion(ip) [41864] *** +-- *** Step 1. Success Initial Conversion(ip) (41864) *** -- --- P ReadBase(Int,16) 41864 | "a388" +-- P ReadBase(Int,16) 41864 -- | -- `- P Id "a388" -- @@ -467,13 +470,13 @@ -- | pure version for extracting Refined2 -- --- >>> newRefined2 @'OL @Id @'True 22 +-- >>> newRefined2 @OL @Id @'True 22 -- Right (Refined2 {r2In = 22, r2Out = 22}) -- --- >>> newRefined2 @'OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust (ToDay Id))) "2020-05-04 12:13:14Z" +-- >>> newRefined2 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust (ToDay Id))) "2020-05-04 12:13:14Z" -- Right (Refined2 {r2In = 2020-05-04 12:13:14 UTC, r2Out = "2020-05-04 12:13:14Z"}) -- --- >>> newRefined2 @'OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust (ToDay Id))) "2020-05-08 12:13:14Z" +-- >>> newRefined2 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust (ToDay Id))) "2020-05-08 12:13:14Z" -- Left "Step 2. False Boolean Check(op) | {Just 2020-05-08 <= Just 2020-05-07}" -- newRefined2 :: forall opts ip op i @@ -495,13 +498,13 @@ -- | create a wrapped 'Refined2' type -- --- >>> prtRefinedTIO $ newRefined2T @_ @'OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) (2019,11,1) +-- >>> prtRefinedTIO $ newRefined2T @_ @OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) (2019,11,1) -- Refined2 {r2In = (2019-11-01,44,5), r2Out = (2019,11,1)} -- --- >>> prtRefinedTIO $ newRefined2T @_ @'OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined2T @_ @OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {6 == 5}] -- --- >>> prtRefinedTIO $ newRefined2T @_ @'OL @(MkDayExtra Id >> Just Id) @(Msg "wrong day:" (Thd Id == 5)) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined2T @_ @OL @(MkDayExtra Id >> Just Id) @(Msg "wrong day:" (Thd Id == 5)) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {wrong day:6 == 5}] -- newRefined2T :: forall m opts ip op i @@ -645,7 +648,7 @@ -> Msg2 prt2Impl opts v = let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) [" ++ show a ++ "]") + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) (" ++ show a ++ ")") mkMsg2 m n r | hasNoTree opts = Msg2 m n "" | otherwise = Msg2 m n r in case v of @@ -684,13 +687,13 @@ -- -- set the 4-tuple directly -- --- >>> eg1 = mkProxy2 @'( 'OL, ReadP Int Id, Gt 10, String) +-- >>> eg1 = mkProxy2 @'( OL, ReadP Int Id, Gt 10, String) -- >>> newRefined2P eg1 "24" -- Right (Refined2 {r2In = 24, r2Out = "24"}) -- -- skip the 4-tuple and set each parameter individually using type application -- --- >>> eg2 = mkProxy2 @_ @'OL @(ReadP Int Id) @(Gt 10) +-- >>> eg2 = mkProxy2 @_ @OL @(ReadP Int Id) @(Gt 10) -- >>> newRefined2P eg2 "24" -- Right (Refined2 {r2In = 24, r2Out = "24"}) -- diff --git a/src/Predicate/Refined3.hs b/src/Predicate/Refined3.hs --- a/src/Predicate/Refined3.hs +++ b/src/Predicate/Refined3.hs @@ -145,35 +145,35 @@ -- -- Although a common scenario is String as input, you are free to choose any input type you like -- --- >>> newRefined3 @'OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fe" +-- >>> newRefined3 @OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fe" -- Right (Refined3 {r3In = 254, r3Out = "fe"}) -- --- >>> newRefined3 @'OZ @(ReadBase Int 16 Id) @(Lt 253) @(PrintF "%x" Id) "00fe" +-- >>> newRefined3 @OZ @(ReadBase Int 16 Id) @(Lt 253) @(PrintF "%x" Id) "00fe" -- Left "Step 2. False Boolean Check(op) | FalseP" -- --- >>> newRefined3 @'OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fg" +-- >>> newRefined3 @OZ @(ReadBase Int 16 Id) @(Lt 255) @(PrintF "%x" Id) "00fg" -- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" -- --- >>> newRefined3 @'OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" +-- >>> newRefined3 @OL @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Msg "length invalid:" (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" -- Left "Step 2. False Boolean Check(op) | {length invalid:5 == 4}" -- --- >>> newRefined3 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" +-- >>> newRefined3 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" -- Left "Step 2. Failed Boolean Check(op) | found length=5" -- --- >>> newRefined3 @'OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1" +-- >>> newRefined3 @OZ @(Map (ReadP Int Id) (Resplit "\\." Id)) @(Guard (PrintF "found length=%d" Len) (Len == 4) >> 'True) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1" -- Right (Refined3 {r3In = [198,162,3,1], r3Out = "198.162.003.001"}) -- -- >>> :m + Data.Time.Calendar.WeekDate --- >>> newRefined3 @'OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,13) +-- >>> newRefined3 @OZ @(MkDayExtra Id >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,13) -- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) -- --- >>> newRefined3 @'OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) @(UnMkDay (Fst Id)) (2019,10,12) +-- >>> newRefined3 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd Id == 7)) @(UnMkDay (Fst Id)) (2019,10,12) -- Left "Step 2. False Boolean Check(op) | {expected a Sunday:6 == 7}" -- --- >>> newRefined3 @'OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,12) +-- >>> newRefined3 @OZ @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) (2019,10,12) -- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" -- --- >>> type T4 k = '( 'OZ, MkDayExtra Id >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) +-- >>> type T4 k = '( OZ, MkDayExtra Id >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) -- >>> newRefined3P (Proxy @(T4 _)) (2019,10,12) -- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" -- @@ -199,7 +199,11 @@ Just r -> r -- | directly load values into 'Refined3' without any checking -unsafeRefined3 :: forall opts ip op fmt i . PP ip i -> PP fmt (PP ip i) -> Refined3 opts ip op fmt i +unsafeRefined3 :: + forall opts ip op fmt i + . PP ip i + -> PP fmt (PP ip i) + -> Refined3 opts ip op fmt i unsafeRefined3 = Refined3 @@ -213,16 +217,24 @@ , PP fmt (PP ip i) ~ i -- the output type must match the original input type ) -deriving instance (Show i, Show (PP ip i), Show (PP fmt (PP ip i))) => Show (Refined3 opts ip op fmt i) -deriving instance (Eq i, Eq (PP ip i), Eq (PP fmt (PP ip i))) => Eq (Refined3 opts ip op fmt i) -deriving instance (TH.Lift (PP ip i), TH.Lift (PP fmt (PP ip i))) => TH.Lift (Refined3 opts ip op fmt i) +deriving instance ( Show i + , Show (PP ip i) + , Show (PP fmt (PP ip i)) + ) => Show (Refined3 opts ip op fmt i) +deriving instance ( Eq i + , Eq (PP ip i) + , Eq (PP fmt (PP ip i)) + ) => Eq (Refined3 opts ip op fmt i) +deriving instance ( TH.Lift (PP ip i) + , TH.Lift (PP fmt (PP ip i)) + ) => TH.Lift (Refined3 opts ip op fmt i) -- | 'IsString' instance for Refined3 -- --- >>> pureTryTest $ fromString @(Refined3 'OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "523" +-- >>> pureTryTest $ fromString @(Refined3 OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "523" -- Right (Refined3 {r3In = 523, r3Out = "523"}) -- --- >>> pureTryTest $ fromString @(Refined3 'OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "2" +-- >>> pureTryTest $ fromString @(Refined3 OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "2" -- Left () -- instance (Refined3C opts ip op fmt String, Show (PP ip String)) @@ -236,16 +248,16 @@ -- read instance from -ddump-deriv -- | 'Read' instance for 'Refined3' -- --- >>> reads @(Refined3 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 254, r3Out = \"fe\"}" +-- >>> reads @(Refined3 OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 254, r3Out = \"fe\"}" -- [(Refined3 {r3In = 254, r3Out = "fe"},"")] -- --- >>> reads @(Refined3 'OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 300, r3Out = \"12c\"}" +-- >>> reads @(Refined3 OZ (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 300, r3Out = \"12c\"}" -- [] -- --- >>> reads @(Refined3 'OZ (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}" +-- >>> reads @(Refined3 OZ (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}" -- [(Refined3 {r3In = -1234, r3Out = "-4d2"},"")] -- --- >>> reads @(Refined3 'OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (PrintL 4 "%d.%d.%d.%d" Id) String) "Refined3 {r3In = [192,168,0,1], r3Out = \"192.168.0.1\"}" +-- >>> reads @(Refined3 OZ (Map (ReadP Int Id) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (PrintL 4 "%d.%d.%d.%d" Id) String) "Refined3 {r3In = [192,168,0,1], r3Out = \"192.168.0.1\"}" -- [(Refined3 {r3In = [192,168,0,1], r3Out = "192.168.0.1"},"")] -- instance ( Eq i @@ -281,10 +293,10 @@ -- | 'ToJSON' instance for 'Refined3' -- -- >>> import qualified Data.Aeson as A --- >>> A.encode (unsafeRefined3 @'OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) @(ShowBase 16 Id) 254 "fe") +-- >>> A.encode (unsafeRefined3 @OZ @(ReadBase Int 16 Id) @(Between 0 255 Id) @(ShowBase 16 Id) 254 "fe") -- "\"fe\"" -- --- >>> A.encode (unsafeRefined3 @'OZ @Id @'True @Id 123 123) +-- >>> A.encode (unsafeRefined3 @OZ @Id @'True @Id 123 123) -- "123" -- instance ToJSON (PP fmt (PP ip i)) => ToJSON (Refined3 opts ip op fmt i) where @@ -294,15 +306,15 @@ -- | 'FromJSON' instance for 'Refined3' -- -- >>> import qualified Data.Aeson as A --- >>> A.eitherDecode' @(Refined3 'OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe\"" +-- >>> A.eitherDecode' @(Refined3 OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe\"" -- Right (Refined3 {r3In = 254, r3Out = "fe"}) -- --- >>> removeAnsi $ A.eitherDecode' @(Refined3 'OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe443a\"" +-- >>> removeAnsi $ A.eitherDecode' @(Refined3 OAN (ReadBase Int 16 Id) (Id > 10 && Id < 256) (ShowBase 16 Id) String) "\"00fe443a\"" -- Error in $: Refined3:Step 2. False Boolean Check(op) | {True && False | (16663610 < 256)} -- --- *** Step 1. Success Initial Conversion(ip) [16663610] *** +-- *** Step 1. Success Initial Conversion(ip) (16663610) *** -- --- P ReadBase(Int,16) 16663610 | "00fe443a" +-- P ReadBase(Int,16) 16663610 -- | -- `- P Id "00fe443a" -- @@ -337,7 +349,7 @@ -- | 'Arbitrary' instance for 'Refined3' -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined3 'OU (ReadP Int Id) (1 <..> 120 && Even) (ShowP Id) String))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined3 OU (ReadP Int Id) (1 <..> 120 && Even) (ShowP Id) String))) -- >>> all (\x -> let y = r3In x in y /= 0 && r3Out x == show y) xs -- True -- @@ -348,7 +360,7 @@ -- | create a 'Refined3' generator using a generator to restrict the values (so it completes) -- --- >>> g = genRefined3 @'OU @(ReadP Int Id) @(Between 10 100 Id && Even) @(ShowP Id) (choose (10,100)) +-- >>> g = genRefined3 @OU @(ReadP Int Id) @(Between 10 100 Id && Even) @(ShowP Id) (choose (10,100)) -- >>> xs <- generate (vectorOf 10 g) -- >>> all (\x -> let y = r3In x in y >= 0 && y <= 100 && even y) xs -- True @@ -388,8 +400,8 @@ -- >>> import Control.Arrow ((+++)) -- >>> import Control.Lens -- >>> import Data.Time --- >>> type K1 = MakeR3 '( 'OAN, ReadP Day Id, 'True, ShowP Id, String) --- >>> type K2 = MakeR3 '( 'OAN, ReadP Day Id, Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id, ShowP Id, String) +-- >>> type K1 = MakeR3 '( OAN, ReadP Day Id, 'True, ShowP Id, String) +-- >>> type K2 = MakeR3 '( OAN, ReadP Day Id, Between (ReadP Day "2019-05-30") (ReadP Day "2019-06-01") Id, ShowP Id, String) -- >>> r = unsafeRefined3' "2019-04-23" :: K1 -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) -- Refined3 {r3In = 2019-04-23, r3Out = "2019-04-23"} @@ -397,7 +409,7 @@ -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) -- Refined3:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} -- --- *** Step 1. Success Initial Conversion(ip) [2019-04-23] *** +-- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** -- -- P ReadP Day 2019-04-23 -- | @@ -411,11 +423,11 @@ -- | -- +- P ReadP Day 2019-05-30 -- | | --- | `- P '2019-05-30 +-- | `- P '"2019-05-30" -- | -- `- P ReadP Day 2019-06-01 -- | --- `- P '2019-06-01 +-- `- P '"2019-06-01" -- -- instance ( Show (PP fmt (PP ip i)) @@ -443,17 +455,20 @@ -- -- set the 5-tuple directly -- --- >>> eg1 = mkProxy3 @'( 'OL, ReadP Int Id, Gt 10, ShowP Id, String) +-- >>> eg1 = mkProxy3 @'( OL, ReadP Int Id, Gt 10, ShowP Id, String) -- >>> newRefined3P eg1 "24" -- Right (Refined3 {r3In = 24, r3Out = "24"}) -- -- skip the 5-tuple and set each parameter individually using type application -- --- >>> eg2 = mkProxy3 @_ @'OL @(ReadP Int Id) @(Gt 10) @(ShowP Id) +-- >>> eg2 = mkProxy3 @_ @OL @(ReadP Int Id) @(Gt 10) @(ShowP Id) -- >>> newRefined3P eg2 "24" -- Right (Refined3 {r3In = 24, r3Out = "24"}) -- -mkProxy3 :: forall z opts ip op fmt i . z ~ '(opts,ip,op,fmt,i) => Proxy '(opts,ip,op,fmt,i) +mkProxy3 :: + forall z opts ip op fmt i + . z ~ '(opts,ip,op,fmt,i) + => Proxy '(opts,ip,op,fmt,i) mkProxy3 = Proxy -- | same as 'mkProxy3' but checks to make sure the proxy is consistent with the 'Refined3C' constraint @@ -487,16 +502,16 @@ -- >>> :set -XRankNTypes -- >>> b16 :: forall opts . Proxy '( opts, ReadBase Int 16 Id, Between 100 200 Id, ShowBase 16 Id, String); b16 = Proxy -- >>> b2 :: forall opts . Proxy '( opts, ReadBase Int 2 Id, 'True, ShowBase 2 Id, String); b2 = Proxy --- >>> prtRefinedTIO $ withRefined3TP (b16 @'OZ) "a3" $ \x -> withRefined3TP (b2 @'OZ) "1001110111" $ \y -> pure (r3In x + r3In y) +-- >>> prtRefinedTIO $ withRefined3TP (b16 @OZ) "a3" $ \x -> withRefined3TP (b2 @OZ) "1001110111" $ \y -> pure (r3In x + r3In y) -- 794 -- -- this example fails as the the hex value is out of range -- --- >>> prtRefinedTIO $ withRefined3TP (b16 @'OAN) "a388" $ \x -> withRefined3TP (b2 @'OAN) "1001110111" $ \y -> pure (x,y) +-- >>> prtRefinedTIO $ withRefined3TP (b16 @OAN) "a388" $ \x -> withRefined3TP (b2 @OAN) "1001110111" $ \y -> pure (x,y) -- --- *** Step 1. Success Initial Conversion(ip) [41864] *** +-- *** Step 1. Success Initial Conversion(ip) (41864) *** -- --- P ReadBase(Int,16) 41864 | "a388" +-- P ReadBase(Int,16) 41864 -- | -- `- P Id "a388" -- @@ -537,13 +552,13 @@ -- | pure version for extracting Refined3 -- --- >>> newRefined3 @'OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:15:7" +-- >>> newRefined3 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:15:7" -- Right (Refined3 {r3In = 01:15:07, r3Out = "01:15:07"}) -- --- >>> newRefined3 @'OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:2:x" +-- >>> newRefined3 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S" Id) @'True @(FormatTimeP "%H:%M:%S" Id) "1:2:x" -- Left "Step 1. Initial Conversion(ip) Failed | ParseTimeP TimeOfDay (%-H:%-M:%-S) failed to parse" -- --- >>> newRefined3 @'OL @(Rescan "^(\\d{1,2}):(\\d{1,2}):(\\d{1,2})$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) @(All (0 <..> 59) Id && Len == 3) @(PrintL 3 "%02d:%02d:%02d" Id) "1:2:3" +-- >>> newRefined3 @OL @(Rescan "^(\\d{1,2}):(\\d{1,2}):(\\d{1,2})$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) @(All (0 <..> 59) Id && Len == 3) @(PrintL 3 "%02d:%02d:%02d" Id) "1:2:3" -- Right (Refined3 {r3In = [1,2,3], r3Out = "01:02:03"}) -- newRefined3 :: forall opts ip op fmt i @@ -569,13 +584,13 @@ -- | create a wrapped 'Refined3' type -- --- >>> prtRefinedTIO $ newRefined3T @_ @'OZ @(MkDayExtra Id >> Just Id) @(GuardSimple (Thd Id == 5) >> 'True) @(UnMkDay (Fst Id)) (2019,11,1) +-- >>> prtRefinedTIO $ newRefined3T @_ @OZ @(MkDayExtra Id >> Just Id) @(GuardSimple (Thd Id == 5) >> 'True) @(UnMkDay (Fst Id)) (2019,11,1) -- Refined3 {r3In = (2019-11-01,44,5), r3Out = (2019,11,1)} -- --- >>> prtRefinedTIO $ newRefined3T @_ @'OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) @(UnMkDay (Fst Id)) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined3T @_ @OL @(MkDayExtra Id >> Just Id) @(Thd Id == 5) @(UnMkDay (Fst Id)) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {6 == 5}] -- --- >>> prtRefinedTIO $ newRefined3T @_ @'OL @(MkDayExtra Id >> Just Id) @(Msg "wrong day:" (Thd Id == 5)) @(UnMkDay (Fst Id)) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined3T @_ @OL @(MkDayExtra Id >> Just Id) @(Msg "wrong day:" (Thd Id == 5)) @(UnMkDay (Fst Id)) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {wrong day:6 == 5}] -- newRefined3T :: forall m opts ip op fmt i @@ -590,13 +605,13 @@ -- | create a wrapped 'Refined3' type -- --- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( 'OZ, MkDayExtra Id >> Just Id, GuardSimple (Thd Id == 5) >> 'True, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,1) +-- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( OZ, MkDayExtra Id >> Just Id, GuardSimple (Thd Id == 5) >> 'True, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,1) -- Refined3 {r3In = (2019-11-01,44,5), r3Out = (2019,11,1)} -- --- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( 'OL, MkDayExtra Id >> Just Id, Thd Id == 5, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( OL, MkDayExtra Id >> Just Id, Thd Id == 5, UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {6 == 5}] -- --- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( 'OL, MkDayExtra Id >> Just Id, Msg "wrong day:" (Thd Id == 5), UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) +-- >>> prtRefinedTIO $ newRefined3TP (Proxy @'( OL, MkDayExtra Id >> Just Id, Msg "wrong day:" (Thd Id == 5), UnMkDay (Fst Id), (Int,Int,Int))) (2019,11,2) -- failure msg[Step 2. False Boolean Check(op) | {wrong day:6 == 5}] -- newRefined3TP :: forall m opts ip op fmt i proxy @@ -708,8 +723,7 @@ Refined3 y _ <- mb -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call tell [setOtherEffects opts "=== a `op` b ==="] - Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) p (f x y) - return (Refined3 a b) + newRefined3TPSkipIPImpl (return . runIdentity) p (f x y) -- | An ADT that summarises the results of evaluating Refined3 representing all possible states data RResults3 a b = @@ -846,7 +860,7 @@ -> Msg3 prt3Impl opts v = let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) [" ++ show a ++ "]") + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) (" ++ show a ++ ")") mkMsg3 m n r | hasNoTree opts = Msg3 m n "" | otherwise = Msg3 m n r in case v of diff --git a/src/Predicate/Util.hs b/src/Predicate/Util.hs --- a/src/Predicate/Util.hs +++ b/src/Predicate/Util.hs @@ -43,7 +43,7 @@ , _FalseT , _TrueT - -- ** BoolP + -- ** PE , PE , pString @@ -57,7 +57,6 @@ , getValLRFromTT , fromTT , getValueLR - , getValueLRHide , fixLite , fixit , prefixMsg @@ -69,7 +68,6 @@ , Debug(..) , Disp(..) , Color(..) - , colorMe , isVerbose , colorBoolT , colorBoolT' @@ -81,23 +79,30 @@ , type Color5 , type Other1 , type Other2 + , type OZ + , type OL + , type OAN + , type OANV + , type OA + , type OAB + , type OU + , type OUB + , type OUV + , type OAV , HOpts(..) , OptT(..) - , OptTC() + , OptTC(..) + , type OptTT , getOptT , subopts -- ** formatting functions , show01 - , lit01 , show01' - , lit01' - , showLit0 - , showLit1 - , show0 - , show3 - , show1 + , lit01 + , litVerbose + , showVerbose , showL , litL , litBL @@ -110,6 +115,7 @@ , RReplace(..) , GetReplaceFnSub(..) , ReplaceFnSub(..) + , displayROpts -- ** useful type families , ZwischenT @@ -168,6 +174,7 @@ , Holder , hh , showT + , showTK , prettyOrd , removeAnsi , MonadEval(..) @@ -178,6 +185,7 @@ , pureTryTest , pureTryTestPred , isPrime + , unlessNull ) where import qualified GHC.TypeNats as GN @@ -222,6 +230,7 @@ import Data.Maybe import Data.Coerce import Data.Foldable (toList) +import Data.Containers.ListUtils (nubOrd) -- $setup -- >>> :set -XDataKinds @@ -252,7 +261,7 @@ TrueT <> TrueT = TrueT TrueT <> PresentT a = PresentT a PresentT a <> TrueT = PresentT a - PresentT a <> PresentT _ = PresentT a + PresentT _ <> PresentT a = PresentT a deriving instance Show a => Show (BoolT a) deriving instance Eq a => Eq (BoolT a) @@ -302,16 +311,20 @@ , _pString :: !String -- ^ optional strings to include in the results } deriving Show --- | prism for accessing '_pBool' +-- | lens for accessing '_pBool' pBool :: Lens' PE BoolP -pBool afb (PE x y) = flip PE y <$> afb x +pBool afb s = (\b -> s { _pBool = b }) <$> afb (_pBool s) --- | prism for accessing 'PE' +-- | lens for accessing 'PE' pString :: Lens' PE String pString afb s = (\b -> s { _pString = b }) <$> afb (_pString s) -- | creates a Node for the evaluation tree -mkNode :: POpts -> BoolT a -> String -> [Holder] -> TT a +mkNode :: POpts + -> BoolT a + -> String + -> [Holder] + -> TT a mkNode opts bt ss hs = case oDebug opts of DZero -> TT bt [] [] @@ -319,7 +332,11 @@ _ -> TT bt ss (map fromTTH hs) -- | creates a Boolean node for a predicate type -mkNodeB :: POpts -> Bool -> String -> [Holder] -> TT Bool +mkNodeB :: POpts + -> Bool + -> String + -> [Holder] + -> TT Bool mkNodeB opts b = mkNode opts (bool FalseT TrueT b) mkNodeSkipP :: Tree PE @@ -355,23 +372,17 @@ hh = Holder -- | see 'getValueLRImpl' : add more detail to the tree if there are errors -getValueLR :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLR = getValueLRImpl True - --- | see 'getValueLRImpl' : add less detail to the tree if there are errors -getValueLRHide :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLRHide = getValueLRImpl False - --- elide FailT msg in tString[0] if showError is False --- | a helper method to add extra context on failure to the tree or extract the value at the root of the tree -getValueLRImpl :: Bool -> POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLRImpl showError opts msg0 tt hs = +getValueLR :: POpts + -> String + -> TT a + -> [Holder] + -> Either (TT x) a +getValueLR opts msg0 tt hs = let tt' = hs ++ [hh tt] in left (\e -> mkNode opts (FailT e) - (msg0 <> if showError || isVerbose opts then (if null msg0 then "" else " ") <> "[" <> e <> "]" - else "") + msg0 tt' ) (getValLRFromTT tt) @@ -452,7 +463,10 @@ setRecursion i = mempty { oRecursion = pure i } -- | set color of title message -setOther :: Bool -> Color -> Color -> POptsL +setOther :: Bool + -> Color + -> Color + -> POptsL setOther b c1 c2 = mempty { oOther = pure $ coerce (b, c1, c2) } -- | turn on/off colors @@ -515,7 +529,7 @@ -- | default options defOpts :: POpts defOpts = HOpts - { oWidth = 200 + { oWidth = 100 , oDebug = DNormal , oDisp = Ansi , oColor = colorDef @@ -537,7 +551,6 @@ data Debug = DZero -- ^ one line summary used mainly for testing | DLite -- ^ one line summary with additional context from the head of the evaluation tree - | DSubNormal -- ^ outputs the evaluation tree but skips noisy subtrees | DNormal -- ^ outputs the evaluation tree but skips noisy subtrees | DVerbose -- ^ outputs the entire evaluation tree deriving (Ord, Show, Eq, Enum, Bounded) @@ -563,60 +576,91 @@ Nothing -> t Just b -> t & tBool .~ _boolT # b -show01 :: (Show a1, Show a2) => POpts -> String -> a1 -> a2 -> String -show01 opts msg0 ret = lit01 opts msg0 ret . show - -lit01 :: Show a1 => POpts -> String -> a1 -> String -> String -lit01 opts msg0 ret = lit01' opts msg0 ret "" +show01 :: (Show a1, Show a2) + => POpts + -> String + -> a1 + -> a2 + -> String +show01 opts msg0 ret = lit01 opts msg0 ret "" . show -show01' :: (Show a1, Show a2) => POpts -> String -> a1 -> String -> a2 -> String -show01' opts msg0 ret fmt = lit01' opts msg0 ret fmt . show +show01' :: (Show a1, Show a2) + => POpts + -> String + -> a1 + -> String + -> a2 + -> String +show01' opts msg0 ret fmt = lit01 opts msg0 ret fmt . show -lit01' :: Show a1 => POpts -> String -> a1 -> String -> String -> String -lit01' opts msg0 ret fmt as +lit01 :: Show a1 + => POpts + -> String + -> a1 + -> String + -> String + -> String +lit01 opts msg0 ret fmt as | null fmt && null as = msg0 | otherwise = msg0 - <> show0 opts " " ret - <> showLit1 opts (" | " ++ fmt) as - --- | display all data regardless of debug level -showLit0 :: POpts -> String -> String -> String -showLit0 o = showLitImpl o DLite + <> " " + <> showL opts ret + <> litVerbose opts (" | " ++ fmt) as --- | more restrictive: only display data at debug level 1 or less -showLit1 :: POpts -> String -> String -> String -showLit1 o = showLitImpl o DLite +-- | more restrictive: only display data in verbose debug mode +litVerbose :: POpts + -> String + -> String + -> String +litVerbose o = showLitImpl o DVerbose -showLitImpl :: POpts -> Debug -> String -> String -> String +showLitImpl :: POpts + -> Debug + -> String + -> String + -> String showLitImpl o i s a = - if oDebug o >= i then s <> litL (oWidth o) a + if oDebug o >= i || oDebug o == DLite then s <> litL o a else "" -show0 :: Show a => POpts -> String -> a -> String -show0 o = showAImpl o DLite - -show3 :: Show a => POpts -> String -> a -> String -show3 o = showAImpl o DVerbose - -show1 :: Show a => POpts -> String -> a -> String -show1 o = showAImpl o DLite +showVerbose :: Show a + => POpts + -> String + -> a + -> String +showVerbose o = showAImpl o DVerbose -showAImpl :: Show a => POpts -> Debug -> String -> a -> String +showAImpl :: Show a + => POpts + -> Debug + -> String + -> a + -> String showAImpl o i s a = showLitImpl o i s (show a) -showL :: Show a => Int -> a -> String -showL i = litL i . show +showL :: Show a + => POpts + -> a + -> String +showL o = litL o . show -litL :: Int -> String -> String -litL i s = take i s <> if length s > i then "..." else "" +litL :: POpts -> String -> String +litL = litL' . oWidth -litBL :: Int -> BL8.ByteString -> String -litBL i s = litL i (BL8.unpack (BL8.take (fromIntegral i+1) s)) +litL' :: Int -> String -> String +litL' i s = take i s <> if length s > i then "..." else "" -litBS :: Int -> BS8.ByteString -> String -litBS i s = litL i (BS8.unpack (BS8.take (i+1) s)) +litBL :: POpts -> BL8.ByteString -> String +litBL o s = + let i = oWidth o + in litL' i (BL8.unpack (BL8.take (fromIntegral i+1) s)) +litBS :: POpts -> BS8.ByteString -> String +litBS o s = + let i = oWidth o + in litL' i (BS8.unpack (BS8.take (i+1) s)) + -- | Regex options for Rescan Resplit Re etc data ROpt = Anchored -- ^ Force pattern anchoring @@ -644,23 +688,30 @@ -- | compile a regex using the type level symbol compileRegex :: forall rs a . GetROpts rs - => POpts -> String -> String -> [Holder] -> Either (TT a) RH.Regex + => POpts + -> String + -> String + -> [Holder] + -> Either (TT a) RH.Regex compileRegex opts nm s hhs | null s = Left (mkNode opts (FailT "Regex cannot be empty") nm hhs) | otherwise = let rs = getROpts @rs mm = nm <> " " <> show rs - in flip left (RH.compileM (TE.encodeUtf8 (T.pack s)) rs) - $ \e -> mkNode opts (FailT "Regex failed to compile") (mm <> " compile failed with regex msg[" <> e <> "]") hhs + in flip left (RH.compileM (TE.encodeUtf8 (T.pack s)) (snd rs)) + $ \e -> mkNode opts (FailT "Regex failed to compile") (mm <> ":" <> e) hhs -- | extract the regex options from the type level list class GetROpts (os :: [ROpt]) where - getROpts :: [RL.PCREOption] + getROpts :: ([String], [RL.PCREOption]) instance GetROpts '[] where - getROpts = [] -instance (GetROpt r, GetROpts rs) => GetROpts (r ': rs) where - getROpts = getROpt @r : getROpts @rs + getROpts = ([], []) +instance (Typeable r, GetROpt r, GetROpts rs) => GetROpts (r ': rs) where + getROpts = ((showTK @r :) *** (getROpt @r :)) (getROpts @rs) +displayROpts :: [String] -> String +displayROpts xs = "[" <> intercalate ", " (nubOrd xs) <> "]" + -- | convert type level regex option to the value level class GetROpt (o :: ROpt) where getROpt :: RL.PCREOption @@ -740,7 +791,10 @@ TrueT -> Right (True,s,t) FalseT -> Right (False,s,t) -formatList :: forall x z . Show x => POpts -> [((Int, x), z)] -> String +formatList :: forall x z . Show x + => POpts + -> [((Int, x), z)] + -> String formatList opts = unwords . map (\((i, a), _) -> "(i=" <> show i <> showAImpl opts DLite ", a=" a <> ")") instance Foldable TT where @@ -954,28 +1008,6 @@ instance GetBool 'False where getBool = False --- | get 'Disp' from the typelevel -class GetDisp (a :: Disp) where - getDisp :: Disp -instance GetDisp 'Ansi where - getDisp = Ansi -instance GetDisp 'Unicode where - getDisp = Unicode - --- | get 'Debug' from the typelevel -class GetDebug (a :: Debug) where - getDebug :: Debug -instance GetDebug 'DZero where - getDebug = DZero -instance GetDebug 'DLite where - getDebug = DLite -instance GetDebug 'DSubNormal where - getDebug = DSubNormal -instance GetDebug 'DNormal where - getDebug = DNormal -instance GetDebug 'DVerbose where - getDebug = DVerbose - -- | get 'Color' from the typelevel class GetColor (a :: Color) where getColor :: Color @@ -1013,7 +1045,9 @@ instance GetOrd 'CNe where getOrd = ("/=",(/=)) -- | pretty print a tree -toNodeString :: POpts -> PE -> String +toNodeString :: POpts + -> PE + -> String toNodeString opts bpe = if hasNoTree opts then errorInProgram $ "shouldnt be calling this if we are dropping details: toNodeString " <> show (oDebug opts) <> " " <> show bpe @@ -1024,7 +1058,6 @@ case oDebug opts of DZero -> True DLite -> True - DSubNormal -> False DNormal -> False DVerbose -> False @@ -1033,7 +1066,10 @@ | otherwise = " " <> s -- | render the 'BoolP' value with colors -colorBoolP :: POpts -> BoolP -> String +colorBoolP :: + POpts + -> BoolP + -> String colorBoolP o = \case b@(FailP e) -> "[" <> colorMe o b "Error" <> nullSpace e <> "]" @@ -1042,7 +1078,10 @@ b@FalseP -> colorMe o b "False" -- | render the 'BoolT' value with colors -colorBoolT :: Show a => POpts -> BoolT a -> String +colorBoolT :: Show a + => POpts + -> BoolT a + -> String colorBoolT o r = let f = colorMe o (r ^. boolT2P) in case r of @@ -1051,7 +1090,10 @@ FalseT -> f "False" PresentT x -> f "Present" <> " " <> show x -colorBoolT' :: Show a => POpts -> BoolT a -> String +colorBoolT' :: Show a + => POpts + -> BoolT a + -> String colorBoolT' o r = let f = colorMe o (r ^. boolT2P) in case r of @@ -1061,23 +1103,38 @@ PresentT x -> f "PresentT" <> " " <> show x -- | colors the result of the predicate based on the current color palette -colorMe :: POpts -> BoolP -> String -> String +colorMe :: + POpts + -> BoolP + -> String + -> String colorMe o b s = let (_, PColor f) = if oNoColor o then nocolor else oColor o in f b s -fixLite :: forall a . Show a => POpts -> a -> Tree PE -> String +fixLite :: forall a . Show a + => POpts + -> a + -> Tree PE + -> String fixLite opts a t | hasNoTree opts = fixPresentP opts (t ^. root . pBool) a <> "\n" | otherwise = prtTreePure opts t -fixPresentP :: Show a => POpts -> BoolP -> a -> String +fixPresentP :: Show a + => POpts + -> BoolP + -> a + -> String fixPresentP opts bp a = case bp of PresentP -> colorMe opts PresentP "Present" <> " " <> show a _ -> colorBoolP opts bp -prtTreePure :: POpts -> Tree PE -> String +prtTreePure :: + POpts + -> Tree PE + -> String prtTreePure opts t | hasNoTree opts = colorBoolP opts (t ^. root . pBool) | otherwise = showImpl opts $ fmap (toNodeString opts) t @@ -1087,7 +1144,9 @@ let s = pp ^. tString in if null s then "" else "(" <> s <> ")" -showImpl :: POpts -> Tree String -> String +showImpl :: POpts + -> Tree String + -> String showImpl o = case oDisp o of Unicode -> TV.showTree @@ -1106,9 +1165,14 @@ prefixMsg msg t = t & tString %~ (msg <>) +-- | show the type as a string showT :: forall (t :: Type) . Typeable t => String showT = show (typeRep (Proxy @t)) +-- | show the kind as a string +showTK :: forall r . Typeable r => String +showTK = show (typeRep (Proxy @r)) + prettyOrd :: Ordering -> String prettyOrd = \case LT -> "<" @@ -1330,11 +1394,12 @@ GR.expectP (L.Punc "=") readVal +-- composite types are used instead of type synonyms as showT (typeRep) unrolls the definition +-- eg sqlhandler.encode/decode and parsejson* etc -- | Display options data OptT = - ODebug !Debug -- ^ set debug mode - | OWidth !Nat -- ^ set display width - | OMsg !Symbol -- ^ set text to add context to a failure message for refined types + OWidth !Nat -- ^ set display width + | OMsg !Symbol -- ^ set text to add context to a failure message for refined types | ORecursion !Nat -- ^ set recursion limit eg for regex | OOther -- ^ set effects for messages !Bool -- ^ set underline @@ -1352,19 +1417,27 @@ !Color -- ^ True background color !Color -- ^ Present foreground color !Color -- ^ Present background color - | ONoColor !Bool -- ^ turn off colors (fast) - | ODisp !Disp -- ^ ansi/unicode display + | OColorOn -- ^ turn on colors + | OColorOff -- ^ turn off colors + | OAnsi -- ^ ansi display + | OUnicode -- ^ unicode display + | OZero -- ^ debug mode return nothing + | OLite -- ^ debug mode return one line + | ONormal -- ^ debug mode normal + | OVerbose -- ^ debug mode verbose | OZ -- ^ composite: no messages | OL -- ^ composite: lite version | OAN -- ^ composite: ansi + no colors + | OANV -- ^ composite: ansi + no colors + verbose | OA -- ^ composite: ansi + colors + | OAV -- ^ composite: ansi + colors + verbose | OAB -- ^ composite: ansi + colors + background | OU -- ^ composite: unicode + colors | OUB -- ^ composite: unicode + colors + background + | OUV -- ^ composite: unicode + colors + verbose instance Show OptT where show = \case - ODebug _n -> "ODebug" OWidth _n -> "OWidth" OMsg _s -> "OMsg" ORecursion _n -> "ORecursion" @@ -1372,33 +1445,45 @@ OEmpty -> "OEmpty" a :# b -> show a ++ " ':# " ++ show b OColor _s _c1 _c2 _c3 _c4 _c5 _c6 _c7 _c8 -> "OColor" - ONoColor b -> "ONoColor " ++ show b - ODisp b -> "ODisp " ++ show b + OColorOn -> "OColorOn" + OColorOff -> "OColorOff" + OAnsi -> "OAnsi" + OUnicode -> "OUnicode" + OZero -> "OZero" + OLite -> "OLite" + ONormal -> "ONormal" + OVerbose -> "OVerbose" OZ -> "OZ" OL -> "OL" OAN -> "OAN" + OANV -> "OANV" OA -> "OA" OAB -> "OAB" + OAV -> "OAV" OU -> "OU" OUB -> "OUB" + OUV -> "OUV" infixr 6 :# class OptTC (k :: OptT) where getOptT' :: POptsL -instance GetDebug n => OptTC ('ODebug n) where - getOptT' = setDebug (getDebug @n) instance KnownNat n => OptTC ('OWidth n) where getOptT' = setWidth (nat @n) instance KnownSymbol s => OptTC ('OMsg s) where getOptT' = setMessage (symb @s) instance KnownNat n => OptTC ('ORecursion n) where getOptT' = setRecursion (nat @n) -instance (GetBool b, GetColor c1, GetColor c2) => OptTC ('OOther b c1 c2) where +instance ( GetBool b + , GetColor c1 + , GetColor c2 + ) => OptTC ('OOther b c1 c2) where getOptT' = setOther (getBool @b) (getColor @c1) (getColor @c2) instance OptTC 'OEmpty where getOptT' = mempty -instance (OptTC a, OptTC b) => OptTC (a ':# b) where +instance ( OptTC a + , OptTC b + ) => OptTC (a ':# b) where getOptT' = getOptT' @a <> getOptT' @b instance ( KnownSymbol s , GetColor c1 @@ -1420,28 +1505,57 @@ (getColor @c6) (getColor @c7) (getColor @c8) -instance GetBool b => OptTC ('ONoColor b) where - getOptT' = setNoColor (getBool @b) -instance GetDisp b => OptTC ('ODisp b) where - getOptT' = setDisp (getDisp @b) +instance OptTC 'OColorOn where + getOptT' = setNoColor False +instance OptTC 'OColorOff where + getOptT' = setNoColor True +instance OptTC 'OAnsi where + getOptT' = setDisp Ansi +instance OptTC 'OUnicode where + getOptT' = setDisp Unicode +instance OptTC 'OZero where + getOptT' = setDebug DZero +instance OptTC 'OLite where + getOptT' = setDebug DLite +instance OptTC 'ONormal where + getOptT' = setDebug DNormal +instance OptTC 'OVerbose where + getOptT' = setDebug DVerbose instance OptTC 'OZ where getOptT' = setDisp Ansi <> setNoColor True <> setDebug DZero instance OptTC 'OL where - getOptT' = setDisp Ansi <> setNoColor True <> setDebug DLite + getOptT' = setDisp Ansi <> setNoColor True <> setDebug DLite <> setWidth 200 instance OptTC 'OAN where - getOptT' = setDisp Ansi <> setNoColor True <> setDebug DNormal + getOptT' = setDisp Ansi <> setNoColor True <> setDebug DNormal <> setWidth 100 +instance OptTC 'OANV where + getOptT' = setDisp Ansi <> setNoColor True <> setDebug DVerbose <> setWidth 200 instance OptTC 'OA where - getOptT' = setDisp Ansi <> getOptT' @Color5 <> setDebug DNormal <> getOptT' @Other2 + getOptT' = setDisp Ansi <> getOptT' @Color5 <> setDebug DNormal <> getOptT' @Other2 <> setWidth 100 instance OptTC 'OAB where - getOptT' = setDisp Ansi <> getOptT' @Color1 <> setDebug DNormal <> getOptT' @Other1 + getOptT' = setDisp Ansi <> getOptT' @Color1 <> setDebug DNormal <> getOptT' @Other1 <> setWidth 100 +instance OptTC 'OAV where + getOptT' = getOptT' @('OA ':# 'OVerbose ':# 'OWidth 200) instance OptTC 'OU where - getOptT' = setDisp Unicode <> getOptT' @Color5 <> setDebug DNormal <> getOptT' @Other2 + getOptT' = getOptT' @('OA ':# 'OUnicode) instance OptTC 'OUB where - getOptT' = setDisp Unicode <> getOptT' @Color1 <> setDebug DNormal <> getOptT' @Other1 + getOptT' = getOptT' @('OAB ':# 'OUnicode) +instance OptTC 'OUV where + getOptT' = getOptT' @('OAV ':# 'OUnicode) +type OZ = 'OAnsi ':# 'OColorOff ':# 'OZero +type OL = 'OAnsi ':# 'OColorOff ':# 'OLite ':# 'OWidth 200 +type OAN = 'OAnsi ':# 'OColorOff ':# 'ONormal ':# 'OWidth 100 +type OANV = 'OAnsi ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200 +type OA = 'OAnsi ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100 +type OAB = 'OAnsi ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100 +type OAV = 'OAnsi ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200 +type OU = 'OUnicode ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100 +type OUB = 'OUnicode ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100 +type OUV = 'OUnicode ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200 + -- | convert typelevel options to 'POpts' -- --- >>> (oDisp &&& fst . oColor &&& oWidth) (getOptT @('OA ':# 'OU ':# 'OA ':# 'OWidth 321 ':# Color4 ':# 'OMsg "test message")) +-- >>> (oDisp &&& fst . oColor &&& oWidth) (getOptT @(OA ':# OU ':# OA ':# 'OWidth 321 ':# Color4 ':# 'OMsg "test message")) -- (Ansi,("color4",321)) -- -- >>> oMsg (getOptT @('OMsg "abc" ':# 'OMsg "def")) @@ -1450,9 +1564,9 @@ -- >>> oOther (getOptT @('OOther 'False 'Red 'White ':# 'OOther 'True 'Red 'Black)) -- (True,Red,Black) -- --- >>> a = show (getOptT @('OEmpty ':# 'OU)) --- >>> b = show (getOptT @('OU ':# 'OEmpty)); --- >>> c = show (getOptT @'OU) +-- >>> a = show (getOptT @('OEmpty ':# OU)) +-- >>> b = show (getOptT @(OU ':# 'OEmpty)); +-- >>> c = show (getOptT @OU) -- >>> a==b && b==c -- True -- @@ -1479,12 +1593,17 @@ type family T5_5 x where T5_5 '(_,_,_,_,e) = e -chkSize :: Foldable t => POpts -> String -> t a -> [Holder] -> Either (TT x) () +chkSize :: Foldable t + => POpts + -> String + -> t a + -> [Holder] + -> Either (TT x) () chkSize opts msg0 xs hhs = let mx = oRecursion opts in case splitAt mx (toList xs) of (_,[]) -> Right () - (_,_:_) -> Left $ mkNode opts (FailT (msg0 <> " list size exceeded")) (msg0 <> " list size exceeded: max is " ++ show mx) hhs + (_,_:_) -> Left $ mkNode opts (FailT (msg0 <> " list size exceeded")) ("max is " ++ show mx) hhs formatOMsg :: POpts -> String -> String formatOMsg o suffix = @@ -1505,12 +1624,12 @@ (False, Default, Default) -> id (b, c1, c2) -> (if b then style Underline else id) . color c1 . bgColor c2 -type family AnyT :: k where {} - pureTryTest :: a -> IO (Either () a) pureTryTest = fmap (left (const ())) . E.try @E.SomeException . E.evaluate -pureTryTestPred :: (String -> Bool) -> a -> IO (Either String (Either () a)) +pureTryTestPred :: (String -> Bool) + -> a + -> IO (Either String (Either () a)) pureTryTestPred p a = do lr <- left E.displayException <$> E.try @E.SomeException (E.evaluate a) return $ case lr of @@ -1518,6 +1637,32 @@ | otherwise -> Left ("no match found: e=" ++ e) Right r -> Right (Right r) +-- | prime predicate +-- +-- >>> isPrime 7 +-- True +-- +-- >>> isPrime 6 +-- False +-- isPrime :: Int -> Bool isPrime n = n==2 || n>2 && all ((> 0).rem n) (2:[3,5 .. floor . sqrt @Double . fromIntegral $ n+1]) + +type family AnyT :: k where {} + +-- | mconcat options at the type level +-- +-- >>> x = getOptT @(OptTT '[ 'OMsg "test", 'ORecursion 123, OU, OL, 'OMsg "field2"]) +-- >>> oMsg x +-- ["test","field2"] +-- >>> oRecursion x +-- 123 +-- +type family OptTT (xs :: [OptT]) where + OptTT '[] = 'OEmpty + OptTT (x ': xs) = x ':# OptTT xs + +unlessNull :: (Foldable t, Monoid m) => t a -> m -> m +unlessNull t m | null t = mempty + | otherwise = m diff --git a/src/Predicate/Util_TH.hs b/src/Predicate/Util_TH.hs --- a/src/Predicate/Util_TH.hs +++ b/src/Predicate/Util_TH.hs @@ -48,11 +48,11 @@ -- | creates a 'Refined.Refined' refinement type -- --- >>> $$(refinedTH 123) :: Refined 'OZ (Between 100 125 Id) Int +-- >>> $$(refinedTH 123) :: Refined OZ (Between 100 125 Id) Int -- Refined 123 -- -- @ --- >$$(refinedTH 99) :: Refined 'OZ (Between 100 125 Id) Int +-- >$$(refinedTH 99) :: Refined OZ (Between 100 125 Id) Int -- -- :8:4: error: -- * refinedTH: predicate failed with FalseP (100 <= 99) @@ -63,11 +63,11 @@ -- it = $$(refinedTH 99) :: Refined (Between 100 125 Id) Int -- @ -- --- >>> $$(refinedTH 123) :: Refined 'OAN (Between 100 125 Id) Int +-- >>> $$(refinedTH 123) :: Refined OAN (Between 100 125 Id) Int -- Refined 123 -- -- @ --- >$$(refinedTH 99) :: Refined 'OAN (FailS "asdf" >> Between 100 125 Id) Int +-- >$$(refinedTH 99) :: Refined OAN (FailS "asdf" >> Between 100 125 Id) Int -- -- :116:4: error: -- * @@ -75,7 +75,7 @@ -- | -- `- [Error asdf] Fail asdf -- | --- `- P 'asdf +-- `- P '"asdf" -- -- refinedTH: predicate failed with FailP "asdf" ((>>) lhs failed) -- * In the Template Haskell splice $$(refinedTH 99) @@ -112,21 +112,21 @@ -- | creates a 'Refined1.Refined1' refinement type -- --- >>> $$(refined1TH 100) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- Refined1 100 -- --- >>> $$(refined1TH 100) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- Refined1 100 -- --- >>> $$(refined1TH 100) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- Refined1 100 -- -- @ --- >$$(refined1TH 99) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- >$$(refined1TH 99) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- -- :127:4: error: -- * --- *** Step 1. Success Initial Conversion(ip) [99] *** +-- *** Step 1. Success Initial Conversion(ip) (99) *** -- -- P Id 99 -- @@ -143,13 +143,17 @@ -- refined1TH: predicate failed with Step 2. False Boolean Check(op) | {100 <= 99} -- * In the Template Haskell splice $$(refined1TH 99) -- In the expression: --- $$(refined1TH 99) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- $$(refined1TH 99) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- In an equation for \'it\': --- it = $$(refined1TH 99) :: Refined1 'OZ Id (Between 100 125 Id) Id Int +-- it = $$(refined1TH 99) :: Refined1 OZ Id (Between 100 125 Id) Id Int -- @ -- refined1TH :: forall opts ip op fmt i - . (Show i, Show (PP ip i), TH.Lift i, TH.Lift (PP ip i), Refined1C opts ip op fmt i) + . ( Show i + , Show (PP ip i) + , TH.Lift i + , TH.Lift (PP ip i) + , Refined1C opts ip op fmt i) => i -> TH.Q (TH.TExp (Refined1 opts ip op fmt i)) refined1TH i = @@ -166,18 +170,18 @@ -- | creates a 'Refined2.Refined2' refinement type -- --- >>> $$(refined2TH 100) :: Refined2 'OA Id (Between 100 125 Id) Int +-- >>> $$(refined2TH 100) :: Refined2 OA Id (Between 100 125 Id) Int -- Refined2 {r2In = 100, r2Out = 100} -- --- >>> $$(refined2TH 100) :: Refined2 'OAN Id (Between 100 125 Id) Int +-- >>> $$(refined2TH 100) :: Refined2 OAN Id (Between 100 125 Id) Int -- Refined2 {r2In = 100, r2Out = 100} -- -- @ --- >$$(refined2TH 99) :: Refined2 'OAN Id (Between 100 125 Id) Int +-- >$$(refined2TH 99) :: Refined2 OAN Id (Between 100 125 Id) Int -- -- :127:4: error: -- * --- *** Step 1. Success Initial Conversion(ip) [99] *** +-- *** Step 1. Success Initial Conversion(ip) (99) *** -- -- P Id 99 -- @@ -194,9 +198,9 @@ -- refined2TH: predicate failed with Step 2. False Boolean Check(op) | {100 <= 99} -- * In the Template Haskell splice $$(refined2TH 99) -- In the expression: --- $$(refined2TH 99) :: Refined2 'OZ Id (Between 100 125 Id) Id Int +-- $$(refined2TH 99) :: Refined2 OZ Id (Between 100 125 Id) Id Int -- In an equation for \'it\': --- it = $$(refined2TH 99) :: Refined2 'OZ Id (Between 100 125 Id) Id Int +-- it = $$(refined2TH 99) :: Refined2 OZ Id (Between 100 125 Id) Id Int -- @ -- refined2TH :: forall opts ip op i @@ -234,18 +238,18 @@ -- | creates a 'Refined3.Refined3' refinement type -- --- >>> $$(refined3TH 100) :: Refined3 'OZ Id (Between 100 125 Id) Id Int +-- >>> $$(refined3TH 100) :: Refined3 OZ Id (Between 100 125 Id) Id Int -- Refined3 {r3In = 100, r3Out = 100} -- --- >>> $$(refined3TH 100) :: Refined3 'OAN Id (Between 100 125 Id) Id Int +-- >>> $$(refined3TH 100) :: Refined3 OAN Id (Between 100 125 Id) Id Int -- Refined3 {r3In = 100, r3Out = 100} -- -- @ --- >$$(refined3TH 99) :: Refined3 'OAN Id (Between 100 125 Id) Id Int +-- >$$(refined3TH 99) :: Refined3 OAN Id (Between 100 125 Id) Id Int -- -- :127:4: error: -- * --- *** Step 1. Success Initial Conversion(ip) [99] *** +-- *** Step 1. Success Initial Conversion(ip) (99) *** -- -- P Id 99 -- @@ -262,12 +266,12 @@ -- refined3TH: predicate failed with Step 2. False Boolean Check(op) | {100 <= 99} -- * In the Template Haskell splice $$(refined3TH 99) -- In the expression: --- $$(refined3TH 99) :: Refined3 'OAN Id (Between 100 125 Id) Id Int +-- $$(refined3TH 99) :: Refined3 OAN Id (Between 100 125 Id) Id Int -- In an equation for \'it\': --- it = $$(refined3TH 99) :: Refined3 'OAN Id (Between 100 125 Id) Id Int +-- it = $$(refined3TH 99) :: Refined3 OAN Id (Between 100 125 Id) Id Int -- @ -- --- >>> $$(refined3TH @'OZ @(Resplit "\\." Id >> Map (ReadP Int Id) Id) @(All (0 <..> 0xff) Id && Len == 4) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "200.2.3.4") +-- >>> $$(refined3TH @OZ @(Resplit "\\." Id >> Map (ReadP Int Id) Id) @(All (0 <..> 0xff) Id && Len == 4) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "200.2.3.4") -- Refined3 {r3In = [200,2,3,4], r3Out = "200.002.003.004"} -- refined3TH :: forall opts ip op fmt i diff --git a/test/TestJson.hs b/test/TestJson.hs --- a/test/TestJson.hs +++ b/test/TestJson.hs @@ -30,21 +30,21 @@ suite :: TestTree suite = testGroup "testjson" [ testCase "testperson ok" $ expectIO testPerson (() <$) - , testCase "testperson1 ok" $ expectIO (testPerson1 @'OAB 2) (() <$) - , testCase "testperson1 bad ipaddress" $ expectIO (testPerson1 @'OAB 3) (expectLeftWith ["octet 3 out of range 0-255 found 260"]) - , testCase "testperson1 bad lastname lowercase first letter" $ expectIO (testPerson1 @'OAB 4) (expectLeftWith ["lastName1", "invalid name", "diaz"]) - , testCase "testperson1 bad first name lowercase first letter" $ expectIO (testPerson1 @'OAB 6) (expectLeftWith ["firstName1", "not upper first(d)"]) - , testCase "testperson1 age 99 out of range" $ expectIO (testPerson1 @'OAB 5) (expectLeftWith ["Error in $[0].age1"]) + , testCase "testperson1 ok" $ expectIO (testPerson1 @OAB 2) (() <$) + , testCase "testperson1 bad ipaddress" $ expectIO (testPerson1 @OAB 3) (expectLeftWith ["octet 3 out of range 0-255 found 260"]) + , testCase "testperson1 bad lastname lowercase first letter" $ expectIO (testPerson1 @OAB 4) (expectLeftWith ["lastName1", "invalid name", "diaz"]) + , testCase "testperson1 bad first name lowercase first letter" $ expectIO (testPerson1 @OAB 6) (expectLeftWith ["firstName1", "not upper first(d)"]) + , testCase "testperson1 age 99 out of range" $ expectIO (testPerson1 @OAB 5) (expectLeftWith ["Error in $[0].age1"]) , testCase "parse fail person1" $ expectPE (FailT "ParseJsonFile [Person1 'OZ](test3.json) Error in $[0].ipaddress1") $ pl @(ParseJsonFile [Person1 'OZ] "test3.json") () , testCase "parse ok person1" $ expectPE (PresentT 5) $ pl @(ParseJsonFile [Person1 'OA] "test2.json" >> Len) () , testCase "missing file" $ expectPE (FailT "ParseJsonFile [Person1 'OZ](test2.jsoxxxn) file does not exist") $ pl @(ParseJsonFile [Person1 'OZ] "test2.jsoxxxn" >> Len) () , testCase "getRow2Age1" $ do - x <- pz @(ParseJsonFile [Person1 'OUB] "test2.json" >> Id !! 2) () + x <- pz @(ParseJsonFile [Person1 OUB] "test2.json" >> Id !! 2) () (x ^? _PresentT . to (unRefined . age1)) @=? Just 45 (x ^? _PresentT . to (R3.r3Out . ipaddress1)) @=? Just "124.001.012.223" , testCase "getRow2" $ do - x <- pz @(ParseJsonFile [Person1 'OUB] "test2.json" >> Id !! 2) () + x <- pz @(ParseJsonFile [Person1 OUB] "test2.json" >> Id !! 2) () x @=? PresentT (Person1 {firstName1 = unsafeRefined "John", lastName1 = unsafeRefined "Doe", age1 = unsafeRefined 45, likesPizza1 = False, date1 = R3.unsafeRefined3 (read "2003-01-12 04:05:33 UTC") "2003-01-12 04:05:33", ipaddress1 = R3.unsafeRefined3 [124,1,12,223] "124.001.012.223"}) ] diff --git a/test/TestPredicate.hs b/test/TestPredicate.hs --- a/test/TestPredicate.hs +++ b/test/TestPredicate.hs @@ -434,9 +434,9 @@ , expectPE (PresentT (3, SG.Any True)) $ pl @(Id !! FromString _ "d" &&& (Map (Snd Id >> Gt 3 >> Coerce SG.Any) (IToList _ Id) >> MConcat Id) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) , expectPE (PresentT (3, True)) $ pl @(Id !! FromString _ "d" &&& (Map (Snd Id >> Gt 3 >> Wrap SG.Any Id) (IToList _ Id) >> MConcat Id >> Unwrap Id) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) --- have to wrap with W cos different kinds --- , expectPE TrueT $ pl @(Do '[ W ('PresentT I), W 'FalseT, Not Id]) False --- , expectPE FalseT $ pl @(Do '[ W ('PresentT Id), W 'FalseT ]) True -- have to wrap them cos BoolT a vs BoolT Bool ie different types --- , expectPE TrueT $ pl @('PresentT I >> Not 'FalseT) False + , expectPE TrueT $ pl @(Do '[ W ('PresentT I), W 'FalseT, Not Id]) False + , expectPE FalseT $ pl @(Do '[ W ('PresentT Id), W 'FalseT ]) True -- have to wrap them cos BoolT a vs BoolT Bool ie different types + , expectPE TrueT $ pl @('PresentT I >> Not 'FalseT) False -- IxL "d" doesnt work cos is Text not String , expectPE (PresentT 3) $ pl @(Id !! FromString _ "d") (M.fromList $ zip (map T.singleton "abcd") [0 ..]) -- use Fromstring @@ -721,7 +721,7 @@ , expectPE (PresentT [95,94,93,92,91]) $ pl @(IterateNUntil 10 (Id <= 90) (Pred Id)) 95 , expectPE (PresentT [95,94,93]) $ pl @(IterateNUntil 3 (Id <= 90) (Pred Id)) 95 -- check for infinite loops - , expectPE (FailT "Unfoldr (9999,1):failed at i=100") $ pl @(IterateNUntil 9999 'False I) 1 + , expectPE (FailT "Unfoldr (9999,1):recursion limit i=100") $ pl @(IterateNUntil 9999 'False I) 1 , expectPE (FailT "Scanl list size exceeded") $ pl @(FoldL (Fst Id) '() (EnumFromTo 1 9999)) () , expectPE (PresentT "a=9 b=rhs") $ pl @(TheseX (PrintF "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (PrintT "a=%d b=%s" (Snd Id)) Id) (These @Int 9 "rhs") , expectPE (PresentT "a=10") $ pl @(TheseX (PrintF "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (PrintT "a=%d b=%s" (Snd Id)) Id) (This @Int 9) @@ -800,7 +800,7 @@ , expectPE (PresentT [1,1,2,3,3,5,6,7]) $ pl @(SortBy (If (Fst Id==50 && Snd Id==3) (Failt _ (PrintT "pivot=%d value=%d" Id)) (OrdA Id)) (Snd Id)) ((), [5,7,3,1,6,2,1,3]) , expectPE TrueT $ pl @(Between (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),3) , expectPE FalseT $ pl @(Between (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),10) - , expectPE (FailT "no match on [03/29/0x7]") $ pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/0x7"] + , expectPE (FailT "no match on (03/29/0x7)") $ pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/0x7"] , expectPE (PresentT [readNote @Day "invalid day" "2001-01-01", readNote @Day "invalid day" "2009-01-24", readNote @Day "invalid day" "2007-03-29"]) $ pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/07"] , expectPE (PresentT "gt3") $ pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 15 @@ -854,17 +854,18 @@ , oMsg testopts1 @?= ["abc", "def"] , oWidth testopts1 @?= 99 , oDisp testopts1 @?= Unicode - , oDisp testopts2 @?= Ansi - , oDisp testopts3 @?= Unicode , fst (oColor testopts1) @?= "nocolor" , fst (oColor testopts2) @?= "testcolor" - , fst (oColor testopts3) @?= "testcolor" + , oDisp testopts2 @?= Ansi + , fst (oColor testopts3) @?= "testcolor1" + , oDisp testopts3 @?= Unicode + , oMsg testopts3 @?= ["def"] ] testopts1, testopts2, testopts3 :: POpts -testopts1 = getOptT @('ORecursion 11 ':# 'ODebug 'DVerbose ':# 'ONoColor 'True ':# 'OWidth 123 ':# 'OMsg "abc" ':# 'OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White ':# 'OMsg "def" ':# 'OEmpty ':# 'ORecursion 11 ':# 'ODisp 'Unicode ':# 'OWidth 99) -testopts2 = getOptT @('ONoColor 'False ':# 'OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White) -testopts3 = getOptT @('OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White ':# 'OMsg "def" ':# 'ODisp 'Unicode) +testopts1 = getOptT @('ORecursion 11 ':# 'OVerbose ':# 'OColorOff ':# 'OWidth 123 ':# 'OMsg "abc" ':# 'OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White ':# 'OMsg "def" ':# 'OEmpty ':# 'ORecursion 11 ':# 'OUnicode ':# 'OWidth 99) +testopts2 = getOptT @('OColorOn ':# 'OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White) +testopts3 = getOptT @('OColor "testcolor1" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White ':# 'OMsg "def" ':# 'OUnicode) type Fizzbuzz = '(Id, If (Id `Mod` 3==0) "fizz" "" <> If (Id `Mod` 5==0) "buzz" "") diff --git a/test/TestRefined.hs b/test/TestRefined.hs --- a/test/TestRefined.hs +++ b/test/TestRefined.hs @@ -35,24 +35,24 @@ namedTests :: [TestTree] namedTests = [ - testCase "always true" $ (@=?) (newRefined @'OA @'True @Int 7) (Right (unsafeRefined 7)) - , testCase "between5and9" $ (@=?) (newRefined @'OA @(Between 5 9 Id) @Int 7) (Right (unsafeRefined 7)) + testCase "always true" $ (@=?) (newRefined @OA @'True @Int 7) (Right (unsafeRefined 7)) + , testCase "between5and9" $ (@=?) (newRefined @OA @(Between 5 9 Id) @Int 7) (Right (unsafeRefined 7)) ] unnamedTests :: [IO ()] unnamedTests = [ - (@=?) (Right (unsafeRefined @'OA @'True ("1.2.3.4" :: String))) (newRefined "1.2.3.4") - , (@=?) (Right (unsafeRefined @'OA @((Len == 4) && Luhn Id) [1,2,3,0])) (newRefined [1,2,3,0]) - , (@=?) (Right (unsafeRefined @'OA @(Not ((Len == 4) && Luhn Id)) [1,2,3,1])) (newRefined [1,2,3,1]) + (@=?) (Right (unsafeRefined @OA @'True ("1.2.3.4" :: String))) (newRefined "1.2.3.4") + , (@=?) (Right (unsafeRefined @OA @((Len == 4) && Luhn Id) [1,2,3,0])) (newRefined [1,2,3,0]) + , (@=?) (Right (unsafeRefined @OA @(Not ((Len == 4) && Luhn Id)) [1,2,3,1])) (newRefined [1,2,3,1]) - , (@=?) [(unsafeRefined 7, "")] (reads @(Refined 'OA (Between 2 10 Id) Int) "Refined 7") - , (@=?) [] (reads @(Refined 'OA (Between 2 10 Id) Int) "Refined 0") - , (@=?) [(unsafeRefined "abcaaaabb", "")] (reads @(Refined 'OA (Re "^[abc]+$" Id) String) "Refined \"abcaaaabb\"") - , (@=?) [] (reads @(Refined 'OA (Re "^[abc]+$" Id) String) "Refined \"abcaaaabbx\"") + , (@=?) [(unsafeRefined 7, "")] (reads @(Refined OA (Between 2 10 Id) Int) "Refined 7") + , (@=?) [] (reads @(Refined OA (Between 2 10 Id) Int) "Refined 0") + , (@=?) [(unsafeRefined "abcaaaabb", "")] (reads @(Refined OA (Re "^[abc]+$" Id) String) "Refined \"abcaaaabb\"") + , (@=?) [] (reads @(Refined OA (Re "^[abc]+$" Id) String) "Refined \"abcaaaabbx\"") - , expectJ (Left ["Error in $: Refined(FromJSON:parseJSON):False"]) (toFrom (unsafeRefined @'OZ @(Between 4 7 Id || Gt 14) 12)) - , expectJ (Right (unsafeRefined 22)) (toFrom (unsafeRefined @'OZ @(Between 4 7 Id || Gt 14) 22)) - , expectJ (Left ["Error in $: Refined(FromJSON:parseJSON):FailT someval (|| [someval])"]) (toFrom (unsafeRefined @'OL @(Between 4 7 Id || Gt 14 || Failt _ "someval") 12)) + , expectJ (Left ["Error in $: Refined(FromJSON:parseJSON):False"]) (toFrom (unsafeRefined @OZ @(Between 4 7 Id || Gt 14) 12)) + , expectJ (Right (unsafeRefined 22)) (toFrom (unsafeRefined @OZ @(Between 4 7 Id || Gt 14) 22)) + , expectJ (Left ["Error in $: Refined(FromJSON:parseJSON):FailT someval (||)"]) (toFrom (unsafeRefined @OL @(Between 4 7 Id || Gt 14 || Failt _ "someval") 12)) , (fst <$> unRavelT (tst2 10 200)) >>= (@?= Right (10,200)) , (fst <$> unRavelT (tst2 11 12)) >>= (@?= Left "FalseT") @@ -64,18 +64,18 @@ allProps :: [TestTree] allProps = [ - testProperty "readshow" $ forAll (genRefined @'OA @(Between 10 45 Id) (choose (1,100))) (\r -> read @(Refined 'OA (Between 10 45 Id) Int) (show r) === r) - , testProperty "jsonroundtrip" $ forAll (genRefined @'OA @(Between 10 45 Id) (choose (1,100))) (\r -> testRefinedJ @'OA @(Between 10 45 Id) (unRefined r) === Right r) + testProperty "readshow" $ forAll (genRefined @OA @(Between 10 45 Id) (choose (1,100))) (\r -> read @(Refined OA (Between 10 45 Id) Int) (show r) === r) + , testProperty "jsonroundtrip" $ forAll (genRefined @OA @(Between 10 45 Id) (choose (1,100))) (\r -> testRefinedJ @OA @(Between 10 45 Id) (unRefined r) === Right r) ] tst1 :: Monad m => Int -> Int -> RefinedT m (Int,Int) -tst1 i j = withRefinedT @'OAN @(Between 2 11 Id) i - $ \x -> withRefinedT @'OAN @(Between 200 211 Id) j +tst1 i j = withRefinedT @OAN @(Between 2 11 Id) i + $ \x -> withRefinedT @OAN @(Between 200 211 Id) j $ \y -> return (unRefined x, unRefined y) tst2 :: MonadIO m => Int -> Int -> RefinedT m (Int,Int) -tst2 i j = withRefinedTIO @'OAN @(Between 2 11 Id) i - $ \x -> withRefinedTIO @'OAN @(Stderr "startio..." |> Between 200 211 Id >| Stderr "...endio") j +tst2 i j = withRefinedTIO @OAN @(Between 2 11 Id) i + $ \x -> withRefinedTIO @OAN @(Stderr "startio..." |> Between 200 211 Id >| Stderr "...endio") j $ \y -> return (unRefined x, unRefined y) -- roundtrip tojson then fromjson diff --git a/test/TestRefined2.hs b/test/TestRefined2.hs --- a/test/TestRefined2.hs +++ b/test/TestRefined2.hs @@ -45,74 +45,74 @@ namedTests :: [TestTree] namedTests = - [ testCase "ip9" $ (@?=) (newRefined2 "121.0.12.13" :: Either String (MakeR2 (Ip9 'OA))) (Right (unsafeRefined2 [121,0,12,13] "121.0.12.13")) - , testCase "luhn check" $ (@?=) (newRefined2 "12345678903" :: Either String (MakeR2 (Ccn 'OA 11))) (Right (unsafeRefined2 [1,2,3,4,5,6,7,8,9,0,3] "12345678903")) - , testCase "datetime utctime" $ (@?=) (newRefined2 "2019-01-04 23:00:59" :: Either String (MakeR2 (DateTime1 'OA UTCTime))) (Right (unsafeRefined2 (read "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) - , testCase "datetime localtime" $ (@?=) (newRefined2 "2019-01-04 09:12:30" :: Either String (MakeR2 (DateTime1 'OA LocalTime))) (Right (unsafeRefined2 (read "2019-01-04 09:12:30") "2019-01-04 09:12:30")) - , testCase "hms" $ (@?=) (newRefined2 "12:0:59" :: Either String (MakeR2 (Hms 'OA))) (Right (unsafeRefined2 [12,0,59] "12:0:59")) - , testCase "between5and9" $ (@?=) (newRefined2 "7" :: Either String (Refined2 'OA (ReadP Int Id) (Between 5 9 Id) String)) (Right (unsafeRefined2 7 "7")) - , testCase "ssn" $ (@?=) (newRefined2 "123-45-6789" :: Either String (MakeR2 (Ssn 'OA))) (Right (unsafeRefined2 [123,45,6789] "123-45-6789")) - , testCase "base16" $ (@?=) (newRefined2 "12f" :: Either String (MakeR2 (BaseN 'OA 16))) (Right (unsafeRefined2 303 "12f")) - , testCase "daten1" $ (@?=) (newRefined2 "June 25 1900" :: Either String (MakeR2 (DateN 'OA))) (Right (unsafeRefined2 (read "1900-06-25") "June 25 1900")) - , testCase "daten2" $ (@?=) (newRefined2 "12/02/99" :: Either String (MakeR2 (DateN 'OA))) (Right (unsafeRefined2 (read "1999-12-02") "12/02/99")) - , testCase "daten3" $ (@?=) (newRefined2 "2011-12-02" :: Either String (MakeR2 (DateN 'OA))) (Right (unsafeRefined2 (read "2011-12-02") "2011-12-02")) - , testCase "ccn123" $ (@?=) (newRefined2 "123455" :: Either String (MakeR2 (Ccn 'OA 6))) (Right (unsafeRefined2 [1,2,3,4,5,5] "123455")) + [ testCase "ip9" $ (@?=) (newRefined2 "121.0.12.13" :: Either String (MakeR2 (Ip9 OA))) (Right (unsafeRefined2 [121,0,12,13] "121.0.12.13")) + , testCase "luhn check" $ (@?=) (newRefined2 "12345678903" :: Either String (MakeR2 (Ccn OA 11))) (Right (unsafeRefined2 [1,2,3,4,5,6,7,8,9,0,3] "12345678903")) + , testCase "datetime utctime" $ (@?=) (newRefined2 "2019-01-04 23:00:59" :: Either String (MakeR2 (DateTime1 OA UTCTime))) (Right (unsafeRefined2 (read "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) + , testCase "datetime localtime" $ (@?=) (newRefined2 "2019-01-04 09:12:30" :: Either String (MakeR2 (DateTime1 OA LocalTime))) (Right (unsafeRefined2 (read "2019-01-04 09:12:30") "2019-01-04 09:12:30")) + , testCase "hms" $ (@?=) (newRefined2 "12:0:59" :: Either String (MakeR2 (Hms OA))) (Right (unsafeRefined2 [12,0,59] "12:0:59")) + , testCase "between5and9" $ (@?=) (newRefined2 "7" :: Either String (Refined2 OA (ReadP Int Id) (Between 5 9 Id) String)) (Right (unsafeRefined2 7 "7")) + , testCase "ssn" $ (@?=) (newRefined2 "123-45-6789" :: Either String (MakeR2 (Ssn OA))) (Right (unsafeRefined2 [123,45,6789] "123-45-6789")) + , testCase "base16" $ (@?=) (newRefined2 "12f" :: Either String (MakeR2 (BaseN OA 16))) (Right (unsafeRefined2 303 "12f")) + , testCase "daten1" $ (@?=) (newRefined2 "June 25 1900" :: Either String (MakeR2 (DateN OA))) (Right (unsafeRefined2 (read "1900-06-25") "June 25 1900")) + , testCase "daten2" $ (@?=) (newRefined2 "12/02/99" :: Either String (MakeR2 (DateN OA))) (Right (unsafeRefined2 (read "1999-12-02") "12/02/99")) + , testCase "daten3" $ (@?=) (newRefined2 "2011-12-02" :: Either String (MakeR2 (DateN OA))) (Right (unsafeRefined2 (read "2011-12-02") "2011-12-02")) + , testCase "ccn123" $ (@?=) (newRefined2 "123455" :: Either String (MakeR2 (Ccn OA 6))) (Right (unsafeRefined2 [1,2,3,4,5,5] "123455")) ] unnamedTests :: [IO ()] unnamedTests = [ - (@?=) [(unsafeRefined2 255 "ff", "")] (reads @(Refined2 'OA (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 255, r2Out = \"ff\"}") -- escape quotes cos read instance for String - , (@?=) [] (reads @(Refined2 'OA (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 256, r2Out = \"100\"}") - , (@?=) [(unsafeRefined2 (-1234) "-4d2", "")] (reads @(Refined2 'OA (ReadBase Int 16 Id) (Id < 0) String) "Refined2 {r2In = -1234, r2Out = \"-4d2\"}") + (@?=) [(unsafeRefined2 255 "ff", "")] (reads @(Refined2 OA (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 255, r2Out = \"ff\"}") -- escape quotes cos read instance for String + , (@?=) [] (reads @(Refined2 OA (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 256, r2Out = \"100\"}") + , (@?=) [(unsafeRefined2 (-1234) "-4d2", "")] (reads @(Refined2 OA (ReadBase Int 16 Id) (Id < 0) String) "Refined2 {r2In = -1234, r2Out = \"-4d2\"}") - , (@?=) (Right (unsafeRefined2 [1,2,3,4] "1.2.3.4")) (newRefined2 "1.2.3.4" :: Either String (Ip4R 'OA)) + , (@?=) (Right (unsafeRefined2 [1,2,3,4] "1.2.3.4")) (newRefined2 "1.2.3.4" :: Either String (Ip4R OA)) - , expectJ (Right (G4 (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4"))) (toFrom $ G4 @'OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) - , expectJ (Left ["Error in $.g4Ip", "False Boolean Check"]) (toFrom $ G4 @'OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.400")) - , expectJ (Left ["Error in $.g4Ip", "ReadP Int (3x)"]) (toFrom $ G4 @'OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3x.4")) - , expectJ (Left ["Error in $.g4Age", "False Boolean Check"]) (toFrom $ G4 @'OA (unsafeRefined2 (-2) "-2") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) - , expectRight (testRefined2P (Proxy @(Ccn 'OA 11)) "123-45-6---789-03-") - , expectLeft (testRefined2P (Proxy @(Ccn 'OA 11)) "123-45-6---789-04-") - , expectRight (testRefined2P (Proxy @(Hms 'OA)) "1:2:33") - , expectLeft (testRefined2P (Proxy @(Hms 'OA)) "1:2:61") - , expectRight (testRefined2P (Proxy @(Ccn 'OA 11)) "6433-1000-006") - , expectRight (testRefined2P (Proxy @(Ccn 'OA 11)) "6433-10000-06") - , expectLeft (testRefined2P (Proxy @(Ccn 'OA 11)) "6433-1000-000") - , expectRight (testRefined2P (Proxy @(Ccn 'OA 4)) "1-23-0") + , expectJ (Right (G4 (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4"))) (toFrom $ G4 @OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) + , expectJ (Left ["Error in $.g4Ip", "False Boolean Check"]) (toFrom $ G4 @OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.400")) + , expectJ (Left ["Error in $.g4Ip", "ReadP Int (3x)"]) (toFrom $ G4 @OA (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3x.4")) + , expectJ (Left ["Error in $.g4Age", "False Boolean Check"]) (toFrom $ G4 @OA (unsafeRefined2 (-2) "-2") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) + , expectRight (testRefined2P (Proxy @(Ccn OA 11)) "123-45-6---789-03-") + , expectLeft (testRefined2P (Proxy @(Ccn OA 11)) "123-45-6---789-04-") + , expectRight (testRefined2P (Proxy @(Hms OA)) "1:2:33") + , expectLeft (testRefined2P (Proxy @(Hms OA)) "1:2:61") + , expectRight (testRefined2P (Proxy @(Ccn OA 11)) "6433-1000-006") + , expectRight (testRefined2P (Proxy @(Ccn OA 11)) "6433-10000-06") + , expectLeft (testRefined2P (Proxy @(Ccn OA 11)) "6433-1000-000") + , expectRight (testRefined2P (Proxy @(Ccn OA 4)) "1-23-0") , expect2 (Left $ XF "Regex no results") - $ eval2 @'OA @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) + $ eval2 @OA @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) @((Len == 4) && All (Between 0 255 Id) Id) "1.21.x31.4" , expect2 (Right $ unsafeRefined2 [1,21,31,4] "1.21.31.4") - $ eval2 @'OA @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) + $ eval2 @OA @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) @((Len == 4) && All (Between 0 255 Id) Id) "1.21.31.4" , expect2 (Left $ XTFalse (-6.5) "(-13) % 2 > (-7) % 3") - $ eval2 @'OA @(ReadP Double Id) + $ eval2 @OA @(ReadP Double Id) @(ToRational Id > 7 -% 3) "-6.5" , expect2 (Right $ unsafeRefined2 4.123 "4.123") - $ eval2 @'OA @(ReadP Double Id) @(ToRational Id > 7 -% 3) + $ eval2 @OA @(ReadP Double Id) @(ToRational Id > 7 -% 3) "4.123" , expect2 (Right $ unsafeRefined2 4.123 (4123 % 1000)) - $ eval2 @'OA @Id @(Gt (7 -% 3)) 4.123 + $ eval2 @OA @Id @(Gt (7 -% 3)) 4.123 , expect2 (Right $ unsafeRefined2 [1,2,3,4] "1.2.3.4") - $ eval2 @'OA @(Map (ReadP Int Id) (Resplit "\\." Id)) @(All (Between 0 255 Id) Id && (Len == 4)) "1.2.3.4" + $ eval2 @OA @(Map (ReadP Int Id) (Resplit "\\." Id)) @(All (Between 0 255 Id) Id && (Len == 4)) "1.2.3.4" , expect2 (Left $ XTFalse [0,0,0,291,1048319,4387,17,1] "True && False | (out of bounds:All(8) i=4 (1048319 <= 65535))") - $ eval2 @'OA @Ip6ip @Ip6op "123:Ffeff:1123:11:1" + $ eval2 @OA @Ip6ip @Ip6op "123:Ffeff:1123:11:1" , expect2 (Right $ unsafeRefined2 [12,2,0,255] "12.2.0.255") - $ eval2 @'OA @Ip4ip @Ip4op' "12.2.0.255" + $ eval2 @OA @Ip4ip @Ip4op' "12.2.0.255" , expect2 (Right $ unsafeRefined2 [123,45,6789] "123-45-6789") - $ eval2 @'OA + $ eval2 @OA @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(Guard "expected 3" (Len == 3) >> Guard "3 digits" (Ix' 0 >> Between 0 999 Id) @@ -123,48 +123,48 @@ "123-45-6789" , expect2 (Right $ unsafeRefined2 [123,45,6789] "123-45-6789") - $ eval2 @'OA + $ eval2 @OA @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 999 Id, Between 0 99 Id, Between 0 9999 Id] >> 'True) "123-45-6789" , expect2 (Left $ XTFalse [0,0,0,291,1048319,4387,17,1] "True && False | (out of bounds:All(8) i=4 (1048319 <= 65535))") - $ eval2 @'OA @Ip6ip @Ip6op + $ eval2 @OA @Ip6ip @Ip6op "123:Ffeff:1123:11:1" , expect2 (Left $ XTFalse [0,0,0,291,1048319,4387,17,1] "True && False | (out of bounds:All(8) i=4 (1048319 <= 65535))") - $ eval2 @'OA @Ip6ip @Ip6op + $ eval2 @OA @Ip6ip @Ip6op "123:Ffeff:1123:11:1" , expect2 (Right $ unsafeRefined2 [0,0,0,291,65535,4387,17,1] "123:Ffff:1123:11:1") - $ eval2 @'OA @Ip6ip @Ip6op + $ eval2 @OA @Ip6ip @Ip6op "123:Ffff:1123:11:1" , expect2 (Right $ unsafeRefined2 [0,0,291,0,65535,0,0,17] "123::Ffff:::11") - $ eval2 @'OA @Ip6ip @Ip6op + $ eval2 @OA @Ip6ip @Ip6op "123::Ffff:::11" , expect2 (Right $ unsafeRefined2 [0,0,291,0,65535,0,0,17] "123::Ffff:::11") - $ eval2 @'OA @Ip6ip @Ip6op + $ eval2 @OA @Ip6ip @Ip6op "123::Ffff:::11" , expect2 (Right $ unsafeRefined2 [31,11,1999] "31-11-1999") - $ eval2 @'OA @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) + $ eval2 @OA @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(Ddmmyyyyop >> 'True) "31-11-1999" - , expect2 (Right $ unsafeRefined2 [123,45,6789] "123-45-6789") $ eval2 @'OA + , expect2 (Right $ unsafeRefined2 [123,45,6789] "123-45-6789") $ eval2 @OA @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 999 Id, Between 0 99 Id, Between 0 9999 Id] >> 'True) "123-45-6789" - , expect2 (Right $ unsafeRefined2 [1,2,3,4] "1.2.3.4") $ eval2P (ip4 @'OA) "1.2.3.4" - , expect2 (Left $ XF "ReadP Int (3x)") $ eval2P (ip4 @'OA) "1.2.3x.4" - , expect2 (Left $ XTFalse [1,2,3,4,5] "Bools:invalid length(5) expected 4") $ eval2P (ip4' @'OA) "1.2.3.4.5" - , expect2 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ eval2P (ip4 @'OA) "1.2.3.4.5" - , expect2 (Left $ XTFalse [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)") $ eval2P (ip4' @'OA) "1.2.300.4" - , expect2 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ eval2P (ip4 @'OA) "1.2.300.4" - , expect2 (Right $ unsafeRefined2 [1,2,3,4,5,6,7,8,9,0,3] "12345678903") $ eval2P (cc11 @'OA) "12345678903" - , expect2 (Left $ XTFalse [1,2,3,4,5,6,7,8,9,0,1] "") $ eval2P (cc11 @'OZ) "12345678901" + , expect2 (Right $ unsafeRefined2 [1,2,3,4] "1.2.3.4") $ eval2P (ip4 @OA) "1.2.3.4" + , expect2 (Left $ XF "ReadP Int (3x)") $ eval2P (ip4 @OA) "1.2.3x.4" + , expect2 (Left $ XTFalse [1,2,3,4,5] "Bools:invalid length(5) expected 4") $ eval2P (ip4' @OA) "1.2.3.4.5" + , expect2 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ eval2P (ip4 @OA) "1.2.3.4.5" + , expect2 (Left $ XTFalse [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)") $ eval2P (ip4' @OA) "1.2.300.4" + , expect2 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ eval2P (ip4 @OA) "1.2.300.4" + , expect2 (Right $ unsafeRefined2 [1,2,3,4,5,6,7,8,9,0,3] "12345678903") $ eval2P (cc11 @OA) "12345678903" + , expect2 (Left $ XTFalse [1,2,3,4,5,6,7,8,9,0,1] "") $ eval2P (cc11 @OZ) "12345678901" ] type HexLtR3 (opts :: OptT) = Refined2 opts (ReadBase Int 16 Id) (Id < 500) String @@ -174,29 +174,29 @@ -- 1. packaged up as a promoted tuple type Tst3 (opts :: OptT) = '(opts, Map (ReadP Int Id) (Resplit "\\." Id), (Len == 4) && All (Between 0 255 Id) Id, String) -www1, www2 :: String -> Either String (MakeR2 (Tst3 'OA)) -www1 = newRefined2P (Proxy @(Tst3 'OA)) +www1, www2 :: String -> Either String (MakeR2 (Tst3 OA)) +www1 = newRefined2P (Proxy @(Tst3 OA)) www2 = newRefined2P tst3 -- just pass in an ipaddress as a string: eg 1.2.3.4 or 1.2.3.4.5 (invalid) 1.2.3.400 (invalid) -- 2. packaged as a proxy tst3 :: Proxy - '( 'OA, Map (ReadP Int Id) (Resplit "\\." Id) + '( OA, Map (ReadP Int Id) (Resplit "\\." Id) ,(Len == 4) && All (Between 0 255 Id) Id ,String) tst3 = Proxy -- 3. direct -ww3 :: String -> Either String (Refined2 'OA +ww3 :: String -> Either String (Refined2 OA (Map (ReadP Int Id) (Resplit "\\." Id)) ((Len == 4) && All (Between 0 255 Id) Id) String) ww3 = newRefined2 {- ww3 = newRefined2 - @'OA + @OA @(Map (ReadP Int Id) (Resplit "\\." Id)) @((Len == 4) && All (Between 0 255 Id)) -} @@ -219,22 +219,22 @@ tst0a :: [Bool] tst0a = - [ newRefined2P (daten @'OUB) "June 25 1900" == Right (unsafeRefined2 (fromGregorian 1900 6 25) "June 25 1900") - , newRefined2P (daten @'OUB) "12/02/19" == Right (unsafeRefined2 (fromGregorian 2019 12 2) "12/02/19") - , newRefined2P (Proxy @(Ccn 'OAB 4)) "1230" == Right (unsafeRefined2 [1,2,3,0] "1230") - , newRefined2P (Proxy @(Ccn 'OAB 6)) "123455" == Right (unsafeRefined2 [1,2,3,4,5,5] "123455") + [ newRefined2P (daten @OUB) "June 25 1900" == Right (unsafeRefined2 (fromGregorian 1900 6 25) "June 25 1900") + , newRefined2P (daten @OUB) "12/02/19" == Right (unsafeRefined2 (fromGregorian 2019 12 2) "12/02/19") + , newRefined2P (Proxy @(Ccn OAB 4)) "1230" == Right (unsafeRefined2 [1,2,3,0] "1230") + , newRefined2P (Proxy @(Ccn OAB 6)) "123455" == Right (unsafeRefined2 [1,2,3,4,5,5] "123455") ] -- prtRefinedTIO tst1a tst1a :: Monad m => RefinedT m ((Int,String),(Int,String)) -tst1a = withRefined2T @'OA @(ReadBase Int 16 Id) @(Between 100 200 Id) @String "a3" - $ \r1 -> withRefined2T @'OA @(ReadP Int Id) @'True @String "12" +tst1a = withRefined2T @OA @(ReadBase Int 16 Id) @(Between 100 200 Id) @String "a3" + $ \r1 -> withRefined2T @OA @(ReadP Int Id) @'True @String "12" $ \r2 -> return ((r2In r1, r2Out r1), (r2In r2, r2Out r2)) -- prtRefinedTIO tst2a tst2a :: MonadIO m => RefinedT m ((Int,String),(Int,String)) -tst2a = withRefined2TIO @'OA @(ReadBase Int 16 Id) @(Stderr "start" |> Between 100 200 Id >| Stdout "end") @String "a3" - $ \r1 -> withRefined2TIO @'OA @(ReadP Int Id) @'True @String "12" +tst2a = withRefined2TIO @OA @(ReadBase Int 16 Id) @(Stderr "start" |> Between 100 200 Id >| Stdout "end") @String "a3" + $ \r1 -> withRefined2TIO @OA @(ReadP Int Id) @'True @String "12" $ \r2 -> return ((r2In r1, r2Out r1), (r2In r2, r2Out r2)) -- have to use 'i' as we dont hold onto the input @@ -320,22 +320,22 @@ expect2 lhs (rhs,mr) = (@?=) (maybe (Left $ toRResults2 rhs) Right mr) lhs -test2a :: Either String (MakeR2 (BaseN 'OU 16)) +test2a :: Either String (MakeR2 (BaseN OU 16)) test2a = newRefined2 "0000fe" -test2b :: Either String (Refined2 'OU +test2b :: Either String (Refined2 OU (Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) (All (0 <..> 0xff) Id) String) test2b = newRefined2 "123.211.122.1" -test2c :: Either String (Refined2 'OU +test2c :: Either String (Refined2 OU (Resplit "\\." Id >> Map (ReadP Int Id) Id) (All (0 <..> 0xff) Id && Len == 4) String) test2c = newRefined2 "200.2.3.4" -test2d :: Either String (Refined2 'OU +test2d :: Either String (Refined2 OU TimeUtc (ToDay Id > Just (MkDay '(2020,05,31))) ()) diff --git a/test/TestRefined3.hs b/test/TestRefined3.hs --- a/test/TestRefined3.hs +++ b/test/TestRefined3.hs @@ -49,79 +49,79 @@ namedTests :: [TestTree] namedTests = [ testCase "ip9" $ (@?=) (newRefined3 "121.0.12.13" :: Either String (MakeR3 Ip9)) (Right (unsafeRefined3 [121,0,12,13] "121.000.012.013")) - , testCase "luhn check" $ (@?=) (newRefined3 "12345678903" :: Either String (MakeR3 (Cc11 'OAN))) (Right (unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903")) - , testCase "datetime utctime" $ (@?=) (newRefined3 "2019-01-04 23:00:59" :: Either String (MakeR3 (DateTime1 'OZ UTCTime))) (Right (unsafeRefined3 (read "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) - , testCase "datetime localtime" $ (@?=) (newRefined3 "2019-01-04 09:12:30" :: Either String (MakeR3 (DateTime1 'OZ LocalTime))) (Right (unsafeRefined3 (read "2019-01-04 09:12:30") "2019-01-04 09:12:30")) - , testCase "hms" $ (@?=) (newRefined3 "12:0:59" :: Either String (MakeR3 (Hms 'OAN))) (Right (unsafeRefined3 [12,0,59] "12:00:59")) - , testCase "between5and9" $ (@?=) (newRefined3 "7" :: Either String (Refined3 'OAN (ReadP Int Id) (Between 5 9 Id) (PrintF "%03d" Id) String)) (Right (unsafeRefined3 7 "007")) - , testCase "ssn" $ (@?=) (newRefined3 "123-45-6789" :: Either String (MakeR3 (Ssn 'OAN))) (Right (unsafeRefined3 [123,45,6789] "123-45-6789")) - , testCase "base16" $ (@?=) (newRefined3 "12f" :: Either String (MakeR3 (BaseN 'OAN 16))) (Right (unsafeRefined3 303 "12f")) - , testCase "daten1" $ (@?=) (newRefined3 "June 25 1900" :: Either String (MakeR3 (DateN 'OAN))) (Right (unsafeRefined3 (read "1900-06-25") "1900-06-25")) - , testCase "daten2" $ (@?=) (newRefined3 "12/02/99" :: Either String (MakeR3 (DateN 'OAN))) (Right (unsafeRefined3 (read "1999-12-02") "1999-12-02")) - , testCase "daten3" $ (@?=) (newRefined3 "2011-12-02" :: Either String (MakeR3 (DateN 'OAN))) (Right (unsafeRefined3 (read "2011-12-02") "2011-12-02")) - , testCase "ccn123" $ (@?=) (newRefined3 "123455" :: Either String (MakeR3 (Ccn 'OAN '[1,2,3]))) (Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455")) - , testCase "readshow" $ (@?=) (newRefined3 "12 % 5" :: Either String (ReadShowR 'OAN Rational)) (Right (unsafeRefined3 (12 % 5) "12 % 5")) + , testCase "luhn check" $ (@?=) (newRefined3 "12345678903" :: Either String (MakeR3 (Cc11 OAN))) (Right (unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903")) + , testCase "datetime utctime" $ (@?=) (newRefined3 "2019-01-04 23:00:59" :: Either String (MakeR3 (DateTime1 OZ UTCTime))) (Right (unsafeRefined3 (read "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) + , testCase "datetime localtime" $ (@?=) (newRefined3 "2019-01-04 09:12:30" :: Either String (MakeR3 (DateTime1 OZ LocalTime))) (Right (unsafeRefined3 (read "2019-01-04 09:12:30") "2019-01-04 09:12:30")) + , testCase "hms" $ (@?=) (newRefined3 "12:0:59" :: Either String (MakeR3 (Hms OAN))) (Right (unsafeRefined3 [12,0,59] "12:00:59")) + , testCase "between5and9" $ (@?=) (newRefined3 "7" :: Either String (Refined3 OAN (ReadP Int Id) (Between 5 9 Id) (PrintF "%03d" Id) String)) (Right (unsafeRefined3 7 "007")) + , testCase "ssn" $ (@?=) (newRefined3 "123-45-6789" :: Either String (MakeR3 (Ssn OAN))) (Right (unsafeRefined3 [123,45,6789] "123-45-6789")) + , testCase "base16" $ (@?=) (newRefined3 "12f" :: Either String (MakeR3 (BaseN OAN 16))) (Right (unsafeRefined3 303 "12f")) + , testCase "daten1" $ (@?=) (newRefined3 "June 25 1900" :: Either String (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (read "1900-06-25") "1900-06-25")) + , testCase "daten2" $ (@?=) (newRefined3 "12/02/99" :: Either String (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (read "1999-12-02") "1999-12-02")) + , testCase "daten3" $ (@?=) (newRefined3 "2011-12-02" :: Either String (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (read "2011-12-02") "2011-12-02")) + , testCase "ccn123" $ (@?=) (newRefined3 "123455" :: Either String (MakeR3 (Ccn OAN '[1,2,3]))) (Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455")) + , testCase "readshow" $ (@?=) (newRefined3 "12 % 5" :: Either String (ReadShowR OAN Rational)) (Right (unsafeRefined3 (12 % 5) "12 % 5")) ] unnamedTests :: [IO ()] unnamedTests = [ - (@?=) [(unsafeRefined3 255 "ff", "")] (reads @(Refined3 'OAN (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 255, r3Out = \"ff\"}") -- escape quotes cos read instance for String - , (@?=) [] (reads @(Refined3 'OAN (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 256, r3Out = \"100\"}") - , (@?=) [(unsafeRefined3 (-1234) "-4d2", "")] (reads @(Refined3 'OAN (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}") + (@?=) [(unsafeRefined3 255 "ff", "")] (reads @(Refined3 OAN (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 255, r3Out = \"ff\"}") -- escape quotes cos read instance for String + , (@?=) [] (reads @(Refined3 OAN (ReadBase Int 16 Id) (Between 0 255 Id) (ShowBase 16 Id) String) "Refined3 {r3In = 256, r3Out = \"100\"}") + , (@?=) [(unsafeRefined3 (-1234) "-4d2", "")] (reads @(Refined3 OAN (ReadBase Int 16 Id) (Id < 0) (ShowBase 16 Id) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}") - , (@?=) (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) (newRefined3 "1.2.3.4" :: Either String (Ip4R 'OAB)) + , (@?=) (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) (newRefined3 "1.2.3.4" :: Either String (Ip4R OAB)) , expectJ (Right (G4 (unsafeRefined3 12 "12") (unsafeRefined3 [1,2,3,4] "001.002.003.004"))) (toFrom $ G4 (unsafeRefined3 12 "12") (unsafeRefined3 [1,2,3,4] "1.2.3.4")) , expectJ (Left ["Error in $.g4Ip", "False Boolean Check"]) (toFrom $ G4 (unsafeRefined3 12 "12") (unsafeRefined3 [1,2,3,4] "1.2.3.400")) , expectJ (Left ["Error in $.g4Ip", "ReadP Int (3x)"]) (toFrom $ G4 (unsafeRefined3 12 "12") (unsafeRefined3 [1,2,3,4] "1.2.3x.4")) , expectJ (Left ["Error in $.g4Age", "False Boolean Check"]) (toFrom $ G4 (unsafeRefined3 (-2) "-2") (unsafeRefined3 [1,2,3,4] "1.2.3.4")) - , expectRight (testRefined3P (Proxy @(Ccn 'OAN '[4,4,3])) "123-45-6---789-03-") - , expectLeft (testRefined3P (Proxy @(Ccn 'OAN '[4,4,3])) "123-45-6---789-04-") - , expectRight (testRefined3P (Proxy @(Hms 'OAN)) "1:2:33") - , expectLeft (testRefined3P (Proxy @(Hms 'OAN)) "1:2:61") - , expectRight (testRefined3P (Proxy @(Ccn 'OAN '[4,4,3])) "6433-1000-006") - , expectRight (testRefined3P (Proxy @(Ccn 'OAN '[4,4,3])) "6433-10000-06") - , expectLeft (testRefined3P (Proxy @(Ccn 'OAN '[4,4,3])) "6433-1000-000") - , expectRight (testRefined3P (Proxy @(Ccn 'OAN '[1,2,1])) "1-23-0") + , expectRight (testRefined3P (Proxy @(Ccn OAN '[4,4,3])) "123-45-6---789-03-") + , expectLeft (testRefined3P (Proxy @(Ccn OAN '[4,4,3])) "123-45-6---789-04-") + , expectRight (testRefined3P (Proxy @(Hms OAN)) "1:2:33") + , expectLeft (testRefined3P (Proxy @(Hms OAN)) "1:2:61") + , expectRight (testRefined3P (Proxy @(Ccn OAN '[4,4,3])) "6433-1000-006") + , expectRight (testRefined3P (Proxy @(Ccn OAN '[4,4,3])) "6433-10000-06") + , expectLeft (testRefined3P (Proxy @(Ccn OAN '[4,4,3])) "6433-1000-000") + , expectRight (testRefined3P (Proxy @(Ccn OAN '[1,2,1])) "1-23-0") , expect3 (Left $ XF "Regex no results") - $ eval3 @'OAN @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) + $ eval3 @OAN @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) @((Len == 4) && All (Between 0 255 Id) Id) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "1.21.x31.4" , expect3 (Right $ unsafeRefined3 [1,21,31,4] "001.021.031.004") - $ eval3 @'OAN @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) + $ eval3 @OAN @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) @((Len == 4) && All (Between 0 255 Id) Id) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "1.21.31.4" , expect3 (Left $ XTFalse (-6.5) "(-13) % 2 > (-7) % 3") - $ eval3 @'OAN @(ReadP Double Id) + $ eval3 @OAN @(ReadP Double Id) @(ToRational Id > 7 -% 3) @(PrintF "%5.3f" Id) "-6.5" , expect3 (Right $ unsafeRefined3 4.123 "") - $ eval3 @'OAN @(ReadP Double Id) @(ToRational Id > 7 -% 3) @"" + $ eval3 @OAN @(ReadP Double Id) @(ToRational Id > 7 -% 3) @"" "4.123" , expect3 (Right $ unsafeRefined3 4.123 (4123 % 1000)) - $ eval3 @'OAN @Id @(Gt (7 -% 3)) @(4123 % 1000) 4.123 + $ eval3 @OAN @Id @(Gt (7 -% 3)) @(4123 % 1000) 4.123 , expect3 (Right $ unsafeRefined3 [1,2,3,4] "") - $ eval3 @'OAN @(Map (ReadP Int Id) (Resplit "\\." Id)) @(All (Between 0 255 Id) Id && (Len == 4)) @"" + $ eval3 @OAN @(Map (ReadP Int Id) (Resplit "\\." Id)) @(All (Between 0 255 Id) Id && (Len == 4)) @"" "1.2.3.4" , expect3 (Left $ XTFalse [0,0,0,291,1048319,4387,17,1] "True && False | (out of bounds:All(8) i=4 (1048319 <= 65535))") - $ eval3 @'OAN @Ip6ip @Ip6op @"" "123:Ffeff:1123:11:1" + $ eval3 @OAN @Ip6ip @Ip6op @"" "123:Ffeff:1123:11:1" , expect3 (Right $ unsafeRefined3 [12,2,0,255] "abc") - $ eval3 @'OAN @Ip4ip @Ip4op' @"abc" "12.2.0.255" + $ eval3 @OAN @Ip4ip @Ip4op' @"abc" "12.2.0.255" , expect3 (Right $ unsafeRefined3 [123,45,6789] "def") $ eval3 - @'OAN @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) + @OAN @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(Guard "expected 3" (Len == 3) >> Guard "3 digits" (Ix' 0 >> Between 0 999 Id) >> Guard "2 digits" (Ix' 1 >> Between 0 99 Id) @@ -132,72 +132,72 @@ , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ eval3 - @'OAN + @OAN @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 999 Id, Between 0 99 Id, Between 0 9999 Id] >> 'True) @"xyz" "123-45-6789" , expect3 (Left $ XTFalse [0,0,0,291,1048319,4387,17,1] "True && False | (out of bounds:All(8) i=4 (1048319 <= 65535))") - $ eval3 @'OAN @Ip6ip @Ip6op @"xyz" + $ eval3 @OAN @Ip6ip @Ip6op @"xyz" "123:Ffeff:1123:11:1" , expect3 (Right $ unsafeRefined3 [0,0,0,291,65535,4387,17,1] "xyz") - $ eval3 @'OAN @Ip6ip @Ip6op @"xyz" + $ eval3 @OAN @Ip6ip @Ip6op @"xyz" "123:Ffff:1123:11:1" , expect3 (Right $ unsafeRefined3 [0,0,291,0,65535,0,0,17] "xyz") - $ eval3 @'OAN @Ip6ip @Ip6op @"xyz" + $ eval3 @OAN @Ip6ip @Ip6op @"xyz" "123::Ffff:::11" , expect3 (Right $ unsafeRefined3 [0,0,291,0,65535,0,0,17] "xyz") - $ eval3 @'OAN @Ip6ip @Ip6op @"xyz" + $ eval3 @OAN @Ip6ip @Ip6op @"xyz" "123::Ffff:::11" , expect3 (Right $ unsafeRefined3 [31,11,1999] "xyz") - $ eval3 @'OAN @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) + $ eval3 @OAN @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(Ddmmyyyyop >> 'True) @"xyz" "31-11-1999" - , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ eval3 @'OAN + , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ eval3 @OAN @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 999 Id, Between 0 99 Id, Between 0 9999 Id] >> 'True) @"xyz" "123-45-6789" - , expect3 (Right $ unsafeRefined3 [1,2,3,4] "001.002.003.004") $ eval3P (ip4 @'OZ) "1.2.3.4" - , expect3 (Left $ XF "ReadP Int (3x)") $ eval3P (ip4 @'OZ) "1.2.3x.4" - , expect3 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ eval3P (ip4 @'OZ) "1.2.3.4.5" - , expect3 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ eval3P (ip4 @'OZ) "1.2.300.4" - , expect3 (Left (XTFalse [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)")) $ eval3P (ip4' @'OL) "1.2.300.4" - , expect3 (Right $ unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") $ eval3P (cc11 @'OAN) "12345678903" - , expect3 (Left $ XTFalse [1,2,3,4,5,6,7,8,9,0,1] "") $ eval3P (cc11 @'OZ) "12345678901" + , expect3 (Right $ unsafeRefined3 [1,2,3,4] "001.002.003.004") $ eval3P (ip4 @OZ) "1.2.3.4" + , expect3 (Left $ XF "ReadP Int (3x)") $ eval3P (ip4 @OZ) "1.2.3x.4" + , expect3 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ eval3P (ip4 @OZ) "1.2.3.4.5" + , expect3 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ eval3P (ip4 @OZ) "1.2.300.4" + , expect3 (Left (XTFalse [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)")) $ eval3P (ip4' @OL) "1.2.300.4" + , expect3 (Right $ unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") $ eval3P (cc11 @OAN) "12345678903" + , expect3 (Left $ XTFalse [1,2,3,4,5,6,7,8,9,0,1] "") $ eval3P (cc11 @OZ) "12345678901" , expect3 (Right $ unsafeRefined3 ([12,13,14],TimeOfDay 12 13 14) "12:13:14") $ eval3P hms2E "12:13:14" -- , expect3 (Left (XTF ([12,13,99], TimeOfDay 12 13 99) "seconds invalid: found 99")) $ eval3P hms2E "12:13:99" - , expect3 (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) $ eval3 @'OAN @Ip4ip @Ip4op' @(ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id)) "1.2.3.4" - , expect3 (Right (unsafeRefined3 [1,2,3,4] "abc__002__3__zzz")) $ eval3 @'OAN @Ip4ip @Ip4op' @(Para '[W "abc",PrintF "%03d" Id,PrintF "%d" Id,W "zzz"] >> Concat (Intercalate '["__"] Id)) "1.2.3.4" - , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (Proxy @'( 'OAN, Ip4ip, Ip4op', ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id), _)) "1.2.3.4" - , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (mkProxy3' @_ @'OAN @Ip4ip @Ip4op' @(ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id))) "1.2.3.4" + , expect3 (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) $ eval3 @OAN @Ip4ip @Ip4op' @(ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id)) "1.2.3.4" + , expect3 (Right (unsafeRefined3 [1,2,3,4] "abc__002__3__zzz")) $ eval3 @OAN @Ip4ip @Ip4op' @(Para '[W "abc",PrintF "%03d" Id,PrintF "%d" Id,W "zzz"] >> Concat (Intercalate '["__"] Id)) "1.2.3.4" + , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (Proxy @'( OAN, Ip4ip, Ip4op', ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id), _)) "1.2.3.4" + , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (mkProxy3' @_ @OAN @Ip4ip @Ip4op' @(ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id))) "1.2.3.4" -- keep the original value - , expect3 (Right $ unsafeRefined3 ("1.2.3.4", [1,2,3,4]) "001.002.003.004") $ eval3 @'OAN @(Id &&& Ip4ip) @(Snd Id >> Ip4op') @(Snd Id >> ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id)) "1.2.3.4" + , expect3 (Right $ unsafeRefined3 ("1.2.3.4", [1,2,3,4]) "001.002.003.004") $ eval3 @OAN @(Id &&& Ip4ip) @(Snd Id >> Ip4op') @(Snd Id >> ParaN 4 (PrintF "%03d" Id) >> Concat (Intercalate '["."] Id)) "1.2.3.4" ] allProps :: [TestTree] allProps = [ - testProperty "base16" $ forAll (genRefined3P (mkProxy3 @'( 'OAN, ReadBase Int 16 Id, 'True, ShowBase 16 Id, String)) arbitrary) (\r -> evalQuick @(ReadBase Int 16 Id) (r3Out r) === Right (r3In r)) - , testProperty "readshow" $ forAll (genRefined3 arbitrary :: Gen (HexLtR3 'OAN)) (\r -> read @(HexLtR3 'OAN) (show r) === r) - , testProperty "jsonroundtrip1" $ forAll (genRefined3 arbitrary :: Gen (HexLtR3 'OAN)) + testProperty "base16" $ forAll (genRefined3P (mkProxy3 @'( OAN, ReadBase Int 16 Id, 'True, ShowBase 16 Id, String)) arbitrary) (\r -> evalQuick @(ReadBase Int 16 Id) (r3Out r) === Right (r3In r)) + , testProperty "readshow" $ forAll (genRefined3 arbitrary :: Gen (HexLtR3 OAN)) (\r -> read @(HexLtR3 OAN) (show r) === r) + , testProperty "jsonroundtrip1" $ forAll (genRefined3 arbitrary :: Gen (HexLtR3 OAN)) (\r -> testRefined3PJ Proxy (r3Out r) === Right r) ] type HexLtR3 (opts :: OptT) = Refined3 opts (ReadBase Int 16 Id) (Id < 500) (ShowBase 16 Id) String type IntLtR3 (opts :: OptT) = Refined3 opts (ReadP Int Id) (Id < 10) (ShowP Id) String -type Tst1 = '( 'OAN, ReadP Int Id, Between 1 7 Id, PrintF "someval val=%03d" Id, String) +type Tst1 = '( OAN, ReadP Int Id, Between 1 7 Id, PrintF "someval val=%03d" Id, String) yy1, yy2, yy3, yy4 :: RefinedT Identity (MakeR3 Tst1) @@ -207,7 +207,7 @@ yy3 = rapply3 (*) yy1 yy2 -- fails yy4 = rapply3 (+) yy1 yy2 -- pure () -hms2E :: Proxy '( 'OAN, Hmsip2, Hmsop2 >> 'True, Hmsfmt2, String) +hms2E :: Proxy '( OAN, Hmsip2, Hmsop2 >> 'True, Hmsfmt2, String) hms2E = mkProxy3 type Hmsip2 = Hmsip &&& ParseTimeP TimeOfDay "%H:%M:%S" Id @@ -216,7 +216,7 @@ -- better to use Guard for op boolean check cos we get better errormessages -- 1. packaged up as a promoted tuple -type Tst3 = '( 'OAN, Map (ReadP Int Id) (Resplit "\\." Id), (Len == 4) && All (Between 0 255 Id) Id, ConcatMap (PrintF "%03d" Id) Id, String) +type Tst3 = '( OAN, Map (ReadP Int Id) (Resplit "\\." Id), (Len == 4) && All (Between 0 255 Id) Id, ConcatMap (PrintF "%03d" Id) Id, String) www1, www2 :: String -> Either String (MakeR3 Tst3) www1 = newRefined3P (mkProxy3 @Tst3) @@ -226,14 +226,14 @@ -- 2. packaged as a proxy tst3 :: Proxy - '( 'OAN, Map (ReadP Int Id) (Resplit "\\." Id) + '( OAN, Map (ReadP Int Id) (Resplit "\\." Id) ,(Len == 4) && All (Between 0 255 Id) Id ,ConcatMap (PrintF "%03d" Id) Id ,String) tst3 = mkProxy3 -- 3. direct -ww3, ww3' :: String -> Either String (Refined3 'OAN +ww3, ww3' :: String -> Either String (Refined3 OAN (Map (ReadP Int Id) (Resplit "\\." Id)) ((Len == 4) && All (Between 0 255 Id) Id) (ConcatMap (PrintF "%03d" Id) Id) @@ -241,7 +241,7 @@ ww3 = newRefined3 ww3' = newRefined3 - @'OAN + @OAN @(Map (ReadP Int Id) (Resplit "\\." Id)) @((Len == 4) && All (Between 0 255 Id) Id) @(ConcatMap (PrintF "%03d" Id) Id) @@ -250,12 +250,12 @@ , g4Ip :: MakeR3 Ip9 } deriving (Show,Generic,Eq) -type MyAge = Refined3 'OAN (ReadP Int Id) (Gt 4) (ShowP Id) String +type MyAge = Refined3 OAN (ReadP Int Id) (Gt 4) (ShowP Id) String -type Age = '( 'OAN, ReadP Int Id, Gt 4, ShowP Id, String) +type Age = '( OAN, ReadP Int Id, Gt 4, ShowP Id, String) type Ip9 = '( - 'OAN + OAN ,Map (ReadP Int Id) (Resplit "\\." Id) -- split String on "." then convert to [Int] ,Len == 4 && All (Between 0 255 Id) Id -- process [Int] and make sure length==4 and each octet is between 0 and 255 ,PrintL 4 "%03d.%03d.%03d.%03d" Id -- printf [Int] @@ -267,22 +267,22 @@ tst0a :: [Bool] tst0a = - [ newRefined3P (daten @'OUB) "June 25 1900" == Right (unsafeRefined3 (fromGregorian 1900 6 25) "1900-06-25") - , newRefined3P (daten @'OUB) "12/02/19" == Right (unsafeRefined3 (fromGregorian 2019 12 2) "2019-12-02") - , newRefined3P (Proxy @(Ccn 'OAB '[1,1,1,1])) "1230" == Right (unsafeRefined3 [1,2,3,0] "1-2-3-0") - , newRefined3P (Proxy @(Ccn 'OAB '[1,2,3])) "123455" == Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455") + [ newRefined3P (daten @OUB) "June 25 1900" == Right (unsafeRefined3 (fromGregorian 1900 6 25) "1900-06-25") + , newRefined3P (daten @OUB) "12/02/19" == Right (unsafeRefined3 (fromGregorian 2019 12 2) "2019-12-02") + , newRefined3P (Proxy @(Ccn OAB '[1,1,1,1])) "1230" == Right (unsafeRefined3 [1,2,3,0] "1-2-3-0") + , newRefined3P (Proxy @(Ccn OAB '[1,2,3])) "123455" == Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455") ] -- prtRefinedTIO tst1a tst1a :: Monad m => RefinedT m ((Int,String),(Int,String)) -tst1a = withRefined3T @'OAN @(ReadBase Int 16 Id) @(Between 100 200 Id) @(ShowBase 16 Id) @String "a3" - $ \r1 -> withRefined3T @'OAN @(ReadP Int Id) @'True @(ShowP Id) @String "12" +tst1a = withRefined3T @OAN @(ReadBase Int 16 Id) @(Between 100 200 Id) @(ShowBase 16 Id) @String "a3" + $ \r1 -> withRefined3T @OAN @(ReadP Int Id) @'True @(ShowP Id) @String "12" $ \r2 -> return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) -- prtRefinedTIO tst2a tst2a :: MonadIO m => RefinedT m ((Int,String),(Int,String)) -tst2a = withRefined3TIO @'OAN @(ReadBase Int 16 Id) @(Stderr "start" |> Between 100 200 Id >| Stdout "end") @(ShowBase 16 Id) @String "a3" - $ \r1 -> withRefined3TIO @'OAN @(ReadP Int Id) @'True @(ShowP Id) @String "12" +tst2a = withRefined3TIO @OAN @(ReadBase Int 16 Id) @(Stderr "start" |> Between 100 200 Id >| Stdout "end") @(ShowBase 16 Id) @String "a3" + $ \r1 -> withRefined3TIO @OAN @(ReadP Int Id) @'True @(ShowP Id) @String "12" $ \r2 -> return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) -- have to use 'i' as we dont hold onto the input