predicate-typed 0.7.3.0 → 0.7.4.0
raw patch · 48 files changed
+17620/−15577 lines, 48 filesdep +constraintsdep +lens-actiondep +randomdep −mtldep −prettydep −tree-view
Dependencies added: constraints, lens-action, random
Dependencies removed: mtl, pretty, tree-view
Files
- predicate-typed.cabal +22/−55
- src/Predicate.hs +4/−7
- src/Predicate/Core.hs +2517/−2395
- src/Predicate/Data/Bits.hs +395/−0
- src/Predicate/Data/Char.hs +105/−90
- src/Predicate/Data/Condition.hs +436/−473
- src/Predicate/Data/DateTime.hs +268/−226
- src/Predicate/Data/Either.hs +211/−236
- src/Predicate/Data/Enum.hs +304/−238
- src/Predicate/Data/Extra.hs +549/−1053
- src/Predicate/Data/Foldable.hs +236/−230
- src/Predicate/Data/IO.hs +295/−104
- src/Predicate/Data/Index.hs +201/−249
- src/Predicate/Data/Iterator.hs +275/−252
- src/Predicate/Data/Json.hs +51/−60
- src/Predicate/Data/Lifted.hs +1326/−0
- src/Predicate/Data/List.hs +2147/−1885
- src/Predicate/Data/Maybe.hs +195/−187
- src/Predicate/Data/Monoid.hs +120/−157
- src/Predicate/Data/Numeric.hs +1213/−1068
- src/Predicate/Data/Ordering.hs +224/−259
- src/Predicate/Data/Proxy.hs +557/−0
- src/Predicate/Data/ReadShow.hs +193/−215
- src/Predicate/Data/Regex.hs +240/−247
- src/Predicate/Data/String.hs +184/−238
- src/Predicate/Data/These.hs +369/−381
- src/Predicate/Data/Tuple.hs +375/−124
- src/Predicate/Examples/Common.hs +72/−93
- src/Predicate/Examples/Refined1.hs +0/−55
- src/Predicate/Examples/Refined2.hs +113/−107
- src/Predicate/Examples/Refined3.hs +124/−142
- src/Predicate/Misc.hs +1269/−0
- src/Predicate/Prelude.hs +9/−4
- src/Predicate/Refined.hs +147/−380
- src/Predicate/Refined1.hs +0/−935
- src/Predicate/Refined2.hs +186/−350
- src/Predicate/Refined3.hs +229/−557
- src/Predicate/Refined5.hs +447/−0
- src/Predicate/TH_Orphans.hs +11/−9
- src/Predicate/Util.hs +1291/−1787
- src/Predicate/Util_TH.hs +109/−166
- test/TastyExtras.hs +9/−6
- test/TestJson.hs +41/−35
- test/TestPredicate.hs +125/−124
- test/TestRefined.hs +59/−37
- test/TestRefined2.hs +188/−172
- test/TestRefined3.hs +179/−188
- test/TestSpec.hs +0/−1
predicate-typed.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: aa2ab78d68dcddef601cdef424ad1d3c3bb857cb5afc594647e650913558a4a1+-- hash: db15387a70ddf9d1c952bbab2f258515c9ac6ba98285247c865cb0e19e3618a0 name: predicate-typed-version: 0.7.3.0+version: 0.7.4.0 synopsis: Predicates, Refinement types and Dsl description: Please see the README on GitHub at <https://github.com/gbwey/predicate-typed#readme> category: Data@@ -28,6 +28,7 @@ exposed-modules: Predicate Predicate.Core+ Predicate.Data.Bits Predicate.Data.Char Predicate.Data.Condition Predicate.Data.DateTime@@ -39,25 +40,27 @@ Predicate.Data.IO Predicate.Data.Iterator Predicate.Data.Json+ Predicate.Data.Lifted Predicate.Data.List Predicate.Data.Maybe Predicate.Data.Monoid Predicate.Data.Numeric Predicate.Data.Ordering+ Predicate.Data.Proxy Predicate.Data.ReadShow Predicate.Data.Regex Predicate.Data.String Predicate.Data.These Predicate.Data.Tuple Predicate.Examples.Common- Predicate.Examples.Refined1 Predicate.Examples.Refined2 Predicate.Examples.Refined3+ Predicate.Misc Predicate.Prelude Predicate.Refined- Predicate.Refined1 Predicate.Refined2 Predicate.Refined3+ Predicate.Refined5 Predicate.TH_Orphans Predicate.Util Predicate.Util_TH@@ -65,7 +68,7 @@ Paths_predicate_typed hs-source-dirs: src- ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Wpartial-fields -Wredundant-constraints+ ghc-options: -Wall -Wcompat -Wno-star-is-type -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wunused-type-patterns -Wredundant-constraints build-depends: QuickCheck , aeson@@ -74,16 +77,17 @@ , binary , bytestring , comonad+ , constraints , containers , deepseq , directory , hashable , lens- , mtl+ , lens-action , pcre-heavy >=1.0.0.2 , pcre-light- , pretty , pretty-terminal >=0.1.0.0+ , random , safe , string-conversions , template-haskell@@ -91,55 +95,18 @@ , th-lift , these >=0.8 , time- , tree-view >=0.5 if impl(ghc >= 8.8)- ghc-options: -fwrite-ide-info -hiedir=.hie+ ghc-options: -fwrite-ide-info -hiedir=.hie -Widentities default-language: Haskell2010 test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs other-modules:- Predicate- Predicate.Core- Predicate.Data.Char- Predicate.Data.Condition- Predicate.Data.DateTime- Predicate.Data.Either- Predicate.Data.Enum- Predicate.Data.Extra- Predicate.Data.Foldable- Predicate.Data.Index- Predicate.Data.IO- Predicate.Data.Iterator- Predicate.Data.Json- Predicate.Data.List- Predicate.Data.Maybe- Predicate.Data.Monoid- Predicate.Data.Numeric- Predicate.Data.Ordering- Predicate.Data.ReadShow- Predicate.Data.Regex- Predicate.Data.String- Predicate.Data.These- Predicate.Data.Tuple- Predicate.Examples.Common- Predicate.Examples.Refined1- Predicate.Examples.Refined2- Predicate.Examples.Refined3- Predicate.Prelude- Predicate.Refined- Predicate.Refined1- Predicate.Refined2- Predicate.Refined3- Predicate.TH_Orphans- Predicate.Util- Predicate.Util_TH Paths_predicate_typed hs-source-dirs:- src doctest- ghc-options: -threaded+ ghc-options: -Wall -threaded -Wcompat -Wno-star-is-type -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wunused-type-patterns build-depends: QuickCheck , aeson@@ -148,18 +115,19 @@ , binary , bytestring , comonad+ , constraints , containers , deepseq , directory , doctest , hashable , lens- , mtl+ , lens-action , pcre-heavy >=1.0.0.2 , pcre-light , predicate-typed- , pretty , pretty-terminal >=0.1.0.0+ , random , safe , string-conversions , template-haskell@@ -167,9 +135,8 @@ , th-lift , these >=0.8 , time- , tree-view >=0.5 if impl(ghc >= 8.8)- ghc-options: -fwrite-ide-info -hiedir=.hie+ ghc-options: -fwrite-ide-info -hiedir=.hie -Widentities default-language: Haskell2010 test-suite predicate-typed-test@@ -185,7 +152,7 @@ Paths_predicate_typed hs-source-dirs: test- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Wno-star-is-type -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wunused-type-patterns -Wredundant-constraints build-depends: QuickCheck , aeson@@ -194,17 +161,18 @@ , binary , bytestring , comonad+ , constraints , containers , deepseq , directory , hashable , lens- , mtl+ , lens-action , pcre-heavy >=1.0.0.2 , pcre-light , predicate-typed- , pretty , pretty-terminal >=0.1.0.0+ , random , safe , stm , string-conversions@@ -216,7 +184,6 @@ , th-lift , these >=0.8 , time- , tree-view >=0.5 if impl(ghc >= 8.8)- ghc-options: -fwrite-ide-info -hiedir=.hie+ ghc-options: -fwrite-ide-info -hiedir=.hie -Widentities default-language: Haskell2010
src/Predicate.hs view
@@ -1,16 +1,13 @@-{- | - Provides a type-level Dsl for refinement types - - "Predicate.Refined2" and "Predicate.Refined3" hold the more advanced refinement types allowing changes to the input type - --} +-- | Provides a type-level Dsl for refinement types +-- +-- "Predicate.Refined2" and "Predicate.Refined3" hold the more advanced refinement types allowing changes to the input type +-- module Predicate ( module Predicate.Core , module Predicate.Prelude , module Predicate.Util , module Predicate.Util_TH , module Predicate.Refined - , module Predicate.TH_Orphans ) where import Predicate.Core import Predicate.Util
src/Predicate/Core.hs view
@@ -1,2395 +1,2517 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoStarIsType #-} -{- | - Dsl for evaluating and displaying type level expressions --} -module Predicate.Core ( - - -- ** basic types - Id - , IdT - , I - , W - , Msg - , MsgI - , Hide - , Width - , Hole - , Unproxy - , Len - , Length - , Map - , Do - , Pure - , Coerce - , OneP - , type (>>) - - -- ** tree evaluation - , pan - , panv - , pa - , pu - , pab - , pub - , pav - , puv - , pl - , pz - , run - , runs - - , P(..) - - -- ** evaluation methods - , runPQ - , runPQBool - , evalBool - , evalBoolHide - , evalHide - , evalQuick - - -- ** wrap, unwrap expressions - , Unwrap - , Wrap - , Wrap' - - -- ** failure expressions - , Fail - , Failp - , Failt - , FailS - - -- ** tuple expressions - , Fst - , Snd - , Thd - , L1 - , L2 - , L3 - , L4 - , L5 - , L6 - - -- ** boolean expressions - , type (&&) - , type (&&~) - , type (||) - , type (||~) - , type (~>) - , Not - , Between - , All - , Any - , IdBool - - -- ** miscellaneous - , type (<..>) - , type (<<) - , Swap - , SwapC(..) - , type ($) - , type (&) - - ) where -import Predicate.Util -import qualified GHC.TypeLits as GL -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat) -import Control.Lens -- ((&), (^.), (.~)) -import Data.Foldable (toList) -import Data.Proxy -import Data.Typeable -import Data.Kind (Type) -import Data.These (These(..)) -import Control.Monad -import Data.List -import Data.Coerce --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> import Predicate.Prelude --- >>> import qualified Data.Semigroup as SG --- >>> import Data.Time - --- | This is the core class. Each instance of this class can be combined into a dsl using 'Predicate.Core.>>' -class P p a where - type PP (p :: k) a :: Type -- PP is the output type - 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 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)) - --- | identity function without show instance of 'Id' --- --- >>> pz @I 23 --- PresentT 23 --- -data I -instance P I a where - type PP I a = a - eval _ opts a = - let msg0 = "I" - in pure $ mkNode opts (PresentT a) msg0 [] - - --- | identity function --- --- >>> pz @Id 23 --- PresentT 23 --- -data Id -instance Show a => P Id a where - type PP Id a = a - eval _ opts a = - let msg0 = "Id" - in pure $ mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] - --- | identity function that also displays the type information for debugging --- --- >>> pz @IdT 23 --- PresentT 23 -data IdT -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 <> " " <> 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' --- --- >>> pz @'[W 123, Id] 99 --- PresentT [123,99] --- --- >>> pz @'[W "abc", W "def", Id, Id] "ghi" --- PresentT ["abc","def","ghi","ghi"] --- -data W (p :: k) -instance P p a => P (W p) a where - type PP (W p) a = PP p a - eval _ = eval (Proxy @(MsgI "W " p)) - --- | add a message to give more context to the evaluation tree --- --- >>> pan @(Msg "[somemessage]" Id) 999 --- P [somemessage] Id 999 --- PresentT 999 --- --- >>> pan @(Msg Id 999) "info message:" --- P info message: '999 --- PresentT 999 --- -data Msg prt p - -instance (P prt a - , PP prt a ~ String - , P p a - ) => P (Msg prt p) a where - type PP (Msg prt p) a = PP p a - eval _ opts a = do - pp <- eval (Proxy @prt) opts a - case getValueLR opts "Msg" pp [] of - Left e -> pure e - Right msg -> prefixMsg (setOtherEffects opts msg <> " ") <$> eval (Proxy @p) opts a - --- | add a message to give more context to the evaluation tree --- --- >>> pan @(MsgI "[somemessage] " Id) 999 --- P [somemessage] Id 999 --- PresentT 999 --- --- >>> pan @(MsgI Id 999) "info message:" --- P info message:'999 --- PresentT 999 --- -data MsgI prt p - -instance (P prt a - , PP prt a ~ String - , P p a - ) => P (MsgI prt p) a where - type PP (MsgI prt p) a = PP p a - eval _ opts a = do - pp <- eval (Proxy @prt) opts a - case getValueLR opts "MsgI" pp [] of - 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 .~ [] - -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. --- -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" [] - --- | override the display width for the expression \'p\' -data Width (n :: Nat) p - -instance (KnownNat n - , P p a - ) => P (Width n p) a where - type PP (Width n p) a = PP p a - eval _ opts a = do - let opts' = opts { oWidth = nat @n } - eval (Proxy @p) opts' a - --- | 'const' () function --- --- >>> pz @() "Asf" --- PresentT () --- -instance P () a where - type PP () a = () - eval _ opts _ = - let msg0 = "()" - in pure $ mkNode opts (PresentT ()) msg0 [] - -instance P (Proxy t) a where - type PP (Proxy t) a = Proxy t - eval _ opts _ = - let msg0 = "Proxy" - in pure $ mkNode opts (PresentT Proxy) msg0 [] - --- Start non-Type kinds ------------------------ - --- | pulls the type level 'Bool' to the value level --- --- >>> pz @'True "not used" --- TrueT --- --- >>> pz @'False () --- FalseT -instance GetBool b => P (b :: Bool) a where - type PP b a = Bool - eval _ opts _ = - let b = getBool @b - in pure $ mkNodeB opts b ("'" <> show b) [] - --- | pulls the type level 'GHC.TypeLits.Symbol' to the value level as a 'GHC.Base.String' --- --- >>> pz @"hello world" () --- PresentT "hello world" -instance KnownSymbol s => P (s :: Symbol) a where - type PP s a = String - eval _ opts _ = - let s = symb @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 - , 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 = "'(,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - pure $ case lr of - 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 --- --- >>> pz @'(4, Id, "goodbye") "hello" --- PresentT (4,"hello","goodbye") --- --- >>> pan @'( 'True, 'False, 123) True --- P '(,,) --- | --- +- True 'True --- | --- +- False 'False --- | --- `- P '123 --- PresentT (True,False,123) --- -instance (P p a - , P q a - , P r a - ) => P '(p,q,r) a where - type PP '(p,q,r) a = (PP p a, PP q a, PP r a) - eval _ opts a = do - let msg = "'(,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts msg rr hhs0 of - Left e -> e - Right r -> - let hhs1 = hhs0 <> [hh rr] - in mkNode opts (PresentT (p,q,r)) msg hhs1 - --- | run the predicates in a promoted 4-tuple --- --- >>> pz @'(4, Id, "inj", 999) "hello" --- PresentT (4,"hello","inj",999) --- -instance (P p a - , P q a - , P r a - , P s a - ) => P '(p,q,r,s) a where - type PP '(p,q,r,s) a = (PP p a, PP q a, PP r a, PP s a) - eval _ opts a = do - let msg = "'(,,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0 - pure $ case lr1 of - Left e -> e - Right (r,s,rr,ss) -> - let hhs1 = hhs0 ++ [hh rr, hh ss] - in mkNode opts (PresentT (p,q,r,s)) msg hhs1 - --- | run the predicates in a promoted 5-tuple --- --- >>> pz @'(4, Id, "inj", 999, 'LT) "hello" --- PresentT (4,"hello","inj",999,LT) --- -instance (P p a - , P q a - , P r a - , P s a - , P t a - ) => P '(p,q,r,s,t) a where - type PP '(p,q,r,s,t) a = (PP p a, PP q a, PP r a, PP s a, PP t a) - eval _ opts a = do - let msg = "'(,,,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0 - case lr1 of - Left e -> pure e - Right (r,s,rr,ss) -> do - let hhs1 = hhs0 ++ [hh rr, hh ss] - tt <- eval (Proxy @t) opts a - pure $ case getValueLR opts msg tt hhs1 of - Left e -> e - Right t -> - let hhs2 = hhs1 <> [hh tt] - in mkNode opts (PresentT (p,q,r,s,t)) msg hhs2 - --- | run the predicates in a promoted 6-tuple --- --- >>> pz @'(4, Id, "inj", 999, 'LT, 1) "hello" --- PresentT (4,"hello","inj",999,LT,1) --- -instance (P p a - , P q a - , P r a - , P s a - , P t a - , P u a - ) => P '(p,q,r,s,t,u) a where - type PP '(p,q,r,s,t,u) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a) - eval _ opts a = do - let msg = "'(,,,,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0 - case lr1 of - Left e -> pure e - Right (r,s,rr,ss) -> do - let hhs1 = hhs0 ++ [hh rr, hh ss] - lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1 - pure $ case lr2 of - Left e -> e - Right (t,u,tt,uu) -> - let hhs2 = hhs1 ++ [hh tt, hh uu] - in mkNode opts (PresentT (p,q,r,s,t,u)) msg hhs2 - --- | run the predicates in a promoted 7-tuple --- --- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2) "hello" --- PresentT (4,"hello","inj",999,LT,1,2) --- -instance (P p a - , P q a - , P r a - , P s a - , P t a - , P u a - , P v a - ) => P '(p,q,r,s,t,u,v) a where - type PP '(p,q,r,s,t,u,v) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a) - eval _ opts a = do - let msg = "'(,,,,,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0 - case lr1 of - Left e -> pure e - Right (r,s,rr,ss) -> do - let hhs1 = hhs0 ++ [hh rr, hh ss] - lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1 - case lr2 of - Left e -> pure e - Right (t,u,tt,uu) -> do - vv <- eval (Proxy @v) opts a - let hhs2 = hhs1 ++ [hh tt, hh uu] - pure $ case getValueLR opts msg vv hhs2 of - Left e -> e - Right v -> - let hhs3 = hhs2 ++ [hh vv] - in mkNode opts (PresentT (p,q,r,s,t,u,v)) msg hhs3 - --- | run the predicates in a promoted 8-tuple --- --- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2, 3) "hello" --- PresentT (4,"hello","inj",999,LT,1,2,3) --- -instance (P p a - , P q a - , P r a - , P s a - , P t a - , P u a - , P v a - , P w a - ) => P '(p,q,r,s,t,u,v,w) a where - type PP '(p,q,r,s,t,u,v,w) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a, PP w a) - eval _ opts a = do - let msg = "'(,,,,,,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a [] - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs0 = [hh pp, hh qq] - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0 - case lr1 of - Left e -> pure e - Right (r,s,rr,ss) -> do - let hhs1 = hhs0 ++ [hh rr, hh ss] - lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1 - case lr2 of - Left e -> pure e - Right (t,u,tt,uu) -> do - let hhs2 = hhs1 ++ [hh tt, hh uu] - lr3 <- runPQ msg (Proxy @v) (Proxy @w) opts a hhs2 - pure $ case lr3 of - Left e -> e - Right (v,w,vv,ww) -> - let hhs3 = hhs2 ++ [hh vv, hh ww] - in mkNode opts (PresentT (p,q,r,s,t,u,v,w)) msg hhs3 - - --- | extracts the value level representation of the promoted 'Ordering' --- --- >>> pz @'LT "not used" --- PresentT LT --- --- >>> pz @'EQ () --- PresentT EQ -instance GetOrdering cmp => P (cmp :: Ordering) a where - type PP cmp a = Ordering - eval _ opts _a = - let cmp = getOrdering @cmp - msg = "'" <> show cmp - in pure $ mkNode opts (PresentT cmp) msg [] - --- | extracts the value level representation of the type level 'Nat' --- --- >>> pz @123 () --- PresentT 123 --- -instance KnownNat n => P (n :: Nat) a where - type PP n a = Int - eval _ opts _ = - let n = nat @n - in pure $ mkNode opts (PresentT n) ("'" <> show n) [] - --- | extracts the value level representation of the type level '() --- --- >>> pz @'() () --- PresentT () -instance P '() a where - type PP '() a = () - eval _ opts _ = pure $ mkNode opts (PresentT ()) "'()" [] - --- the type has to be [a] so we still need type PP '[p] a = [PP p a] to keep the types in line - --- | extracts the value level representation of the type level '[] --- --- >>> pz @'[] False --- PresentT [] -instance P ('[] :: [k]) a where - type PP ('[] :: [k]) a = [a] - eval _ opts _ = pure $ mkNode opts (PresentT mempty) "'[]" [] - --- | runs each predicate in turn from the promoted list --- --- >>> pz @'[1, 2, 3] 999 --- PresentT [1,2,3] --- --- >>> 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 - 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]) ("'" <> showL opts [b] <> showVerbose opts " | " a) [hh pp] - -instance (Show (PP p a) - , Show a - , P (p1 ': ps) a - , PP (p1 ': ps) a ~ [PP p1 a] - , P p a - , PP p a ~ PP p1 a - ) => P (p ': p1 ': ps) a where - type PP (p ': p1 ': ps) a = [PP p a] - eval _ opts a = do - let msg0 = "'(p':q)" - 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]) - --- | tries to extract @a@ from @Maybe a@ otherwise it fails: similar to 'Data.Maybe.fromJust' --- --- >>> pz @('Just Id) (Just "abc") --- PresentT "abc" --- --- >>> pl @('Just Id >> Id) (Just 123) --- Present 123 ((>>) 123 | {Id 123}) --- PresentT 123 --- --- >>> pl @('Just Id) (Just [1,2,3]) --- Present [1,2,3] ('Just [1,2,3] | Just [1,2,3]) --- PresentT [1,2,3] --- --- >>> pl @('Just Id) (Just 10) --- Present 10 ('Just 10 | Just 10) --- PresentT 10 --- --- >>> pl @('Just Id) Nothing --- Error 'Just(empty) --- FailT "'Just(empty)" --- --- >>> pz @('Just (Fst Id)) (Just 123,'x') --- PresentT 123 --- -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)")) "" [hh pp] - Just d -> mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp] - --- | expects Nothing otherwise it fails --- if the value is Nothing then it returns \'Proxy a\' as this provides type information --- --- >>> pz @'Nothing Nothing --- PresentT Proxy --- --- >>> pz @'Nothing (Just True) --- FailT "'Nothing found Just" --- -instance P 'Nothing (Maybe a) where - type PP 'Nothing (Maybe a) = Proxy a -- () gives us less information - eval _ opts ma = - let msg0 = "'Nothing" - in pure $ case ma of - Nothing -> mkNode opts (PresentT Proxy) msg0 [] - 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 --- --- >>> pz @('Left Id) (Left 123) --- PresentT 123 --- --- >>> pz @('Left (Snd Id)) ('x', Left 123) --- PresentT 123 --- --- >>> pz @('Left Id) (Right "aaa") --- FailT "'Left found Right" --- --- >>> pl @('Left Id) (Left 123) --- Present 123 (Left) --- PresentT 123 --- --- >>> pl @('Left Id) (Right 123) --- Error 'Left found Right --- FailT "'Left found Right" --- - -instance ( PP p x ~ Either a b - , P p x) - => P ('Left p) x where - type PP ('Left p) x = LeftT (PP p x) - eval _ opts x = do - let msg0 = "'Left" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p of - Left a -> mkNode opts (PresentT a) "Left" [hh pp] - Right _b -> mkNode opts (FailT (msg0 <> " found Right")) "" [hh pp] - --- | extracts the \'b\' from type level \'Either a b\' if the value exists --- --- >>> pl @('Right Id) (Right 123) --- Present 123 (Right) --- PresentT 123 --- --- >>> pz @('Right Id >> Snd Id) (Right ('x',123)) --- PresentT 123 --- --- >>> pz @('Right Id) (Left "aaa") --- FailT "'Right found Left" --- --- >>> pl @('Right Id) (Left 123) --- Error 'Right found Left --- FailT "'Right found Left" --- -instance ( PP p x ~ Either a b - , P p x) - => P ('Right p) x where - type PP ('Right p) x = RightT (PP p x) - eval _ opts x = do - let msg0 = "'Right" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p of - Left _a -> mkNode opts (FailT (msg0 <> " found Left")) "" [hh pp] - Right b -> mkNode opts (PresentT b) "Right" [hh pp] - - --- removed Show x: else ambiguity errors in TestPredicate - --- | extracts the \'a\' from type level \'These a b\' if the value exists --- --- >>> pl @('This Id) (This 12) --- Present 12 (This) --- PresentT 12 --- --- >>> pz @('This Id) (That "aaa") --- FailT "'This found That" --- --- >>> pz @('This Id) (These 999 "aaa") --- FailT "'This found These" --- --- >>> pl @('This Id) (That 12) --- Error 'This found That --- FailT "'This found That" --- - -instance ( PP p x ~ These a b - , P p x) - => P ('This p) x where - type PP ('This p) x = ThisT (PP p x) - eval _ opts x = do - let msg0 = "'This" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p of - This a -> mkNode opts (PresentT a) "This" [hh pp] - That _b -> mkNode opts (FailT (msg0 <> " found That")) "" [hh pp] - These _a _b -> mkNode opts (FailT (msg0 <> " found These")) "" [hh pp] - --- | extracts the \'b\' from type level \'These a b\' if the value exists --- --- >>> pz @('That Id) (That 123) --- PresentT 123 --- --- >>> pz @('That Id) (This "aaa") --- FailT "'That found This" --- --- >>> pz @('That Id) (These 44 "aaa") --- FailT "'That found These" --- - -instance ( PP p x ~ These a b - , P p x) - => P ('That p) x where - type PP ('That p) x = ThatT (PP p x) - eval _ opts x = do - let msg0 = "'That" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - case p of - This _a -> mkNode opts (FailT (msg0 <> " found This")) "" [hh pp] - That b -> mkNode opts (PresentT b) "That" [hh pp] - These _a _b -> mkNode opts (FailT (msg0 <> " found These")) "" [hh pp] - - --- | extracts the (a,b) from type level \'These a b\' if the value exists --- --- >>> pz @('These Id Id) (These 123 "abc") --- PresentT (123,"abc") --- --- >>> pz @('These Id 5) (These 123 "abcde") --- PresentT (123,5) --- --- >>> pz @('These Id Id) (This "aaa") --- FailT "'These found This" --- --- >>> pz @('These Id Id) (That "aaa") --- FailT "'These found That" --- -instance (Show a - , Show b - , P p a - , P q b - , Show (PP p a) - , Show (PP q b) - ) => P ('These p q) (These a b) where - type PP ('These p q) (These a b) = (PP p a, PP q b) - eval _ opts th = do - let msg0 = "'These" - case th of - These a b -> do - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts b - 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)) "" [] - --- | converts the value to the corresponding 'Proxy' --- --- >>> pz @'Proxy 'x' --- PresentT Proxy --- -instance Show a => P 'Proxy a where - type PP 'Proxy a = Proxy a - eval _ opts a = - let b = Proxy @a - in pure $ mkNode opts (PresentT b) ("'Proxy" <> showVerbose opts " | " a) [] - --- | typelevel 'BoolT' --- --- >>> pz @'TrueT () --- TrueT --- --- >>> pz @'FalseT () --- FalseT --- --- >>> pz @('PresentT 123) () --- PresentT False --- --- >>> pz @('FailT '[]) () --- FailT "'FailT _" --- -instance GetBoolT x b => P (b :: BoolT x) a where - type PP b a = Bool - eval _ opts _ = do - 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) "'PresentT _" [] - Right False -> mkNode opts (FailT "'FailT _") "BoolT" [] - -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 --- | same as 'pz' but adds context to the end result -pl = run @OL @p --- | displays the evaluation tree in plain text without colors -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 --- | displays the evaluation tree using background colors -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 --- | displays the evaluation tree using unicode and colors with background colors -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 --- 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) - , P p a) - => a - -> IO (BoolT (PP p a)) -run a = do - let opts = getOptT @opts - pp <- eval (Proxy @p) opts a - let r = pp ^. tBool - putStr $ prtTree opts pp - return r - --- | run expression with multiple options in a list --- --- >>> runs @'[ OL, 'OMsg "field2"] @'( 'True, 'False) () --- field2 >>> Present (True,False) ('(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 - --- | convenience method to evaluate two expressions using the same input and return the results -runPQ :: ( P p a - , P q a - , MonadEval m) - => String - -> proxy1 p - -> proxy2 q - -> POpts - -> a - -> [Holder] - -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) -runPQ msg0 proxyp proxyq opts a hhs = do - pp <- eval proxyp opts a - case getValueLR opts msg0 pp hhs of - Left e -> pure $ Left e - Right p -> do - qq <- eval proxyq opts a - pure $ case getValueLR opts msg0 qq (hhs <> [hh pp]) of - Left e -> Left e - Right q -> Right (p, q, pp, qq) - --- | convenience method to evaluate two boolean expressions using the same input and return the results -runPQBool :: ( P p a - , PP p a ~ Bool - , P q a - , PP q a ~ Bool, MonadEval m) - => String - -> proxy1 p - -> proxy2 q - -> POpts - -> a - -> [Holder] - -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) -runPQBool msg0 proxyp proxyq opts a hhs = do - pp <- evalBool proxyp opts a - case getValueLR opts msg0 pp hhs of - Left e -> pure $ Left e - Right p -> do - qq <- evalBool proxyq opts a - pure $ case getValueLR opts msg0 qq (hhs <> [hh pp]) of - Left e -> Left e - Right q -> Right (p, q, pp, qq) - --- | evaluate a boolean expressions but hide the results unless verbose -evalBoolHide :: forall p a m - . (MonadEval m, P p a, PP p a ~ Bool) - => POpts - -> a - -> m (TT (PP p a)) -evalBoolHide opts = - if isVerbose opts then evalBool (Proxy @p) opts - else evalBool (Proxy @(Hide p)) opts - --- | evaluate a expressions but hide the results unless verbose -evalHide :: forall p a m - . (MonadEval m, P p a) - => POpts - -> a - -> m (TT (PP p a)) -evalHide opts = - if isVerbose opts then eval (Proxy @p) opts - else eval (Proxy @(Hide p)) opts - - --- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' - --- | compose expressions --- --- >>> pz @(Fst Id >> Snd Id) ((11,12),'x') --- PresentT 12 --- -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] - --- | flipped version of 'Predicate.Core.>>' -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)) - --- bearbeiten! only used by >> -topMessageEgregious :: TT a -> String -topMessageEgregious pp = innermost (pp ^. tString) - where innermost = ('{':) . reverse . ('}':) . takeWhile (/='{') . dropWhile (=='}') . reverse - --- | unwraps a value (see '_Wrapped'') --- --- >>> pz @(Unwrap Id) (SG.Sum (-13)) --- PresentT (-13) --- --- >>> pl @(Unwrap Id >> '(Id, 'True)) (SG.Sum 13) --- Present (13,True) ((>>) (13,True) | {'(13,True)}) --- PresentT (13,True) --- -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] - -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] - --- | 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}) --- --- >>> import Data.List.NonEmpty (NonEmpty(..)) --- >>> pz @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" --- PresentT ('a' :| "bcd") --- --- >>> pl @(Wrap (SG.Sum _) Id) 13 --- Present Sum {getSum = 13} (Wrap Sum {getSum = 13} | 13) --- PresentT (Sum {getSum = 13}) --- --- >>> pl @(Wrap (SG.Sum _) Id >> STimes 4 Id) 13 --- Present Sum {getSum = 52} ((>>) Sum {getSum = 52} | {getSum = 13}) --- PresentT (Sum {getSum = 52}) --- --- >>> pl @(Wrap _ 13 <> Id) (SG.Sum @Int 12) --- Present Sum {getSum = 25} (Sum {getSum = 13} <> Sum {getSum = 12} = Sum {getSum = 25}) --- PresentT (Sum {getSum = 25}) --- - -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)) - - --- | used for type inference -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" [] - --- | 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') (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] - --- | '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 --- --- >>> pl @(Not 'True) () --- False (Not ('True)) --- FalseT --- -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] - --- | Fails the computation with a message but allows you to set the output type --- --- >>> pz @(Failt Int (PrintF "value=%03d" Id)) 99 --- FailT "value=099" --- --- >>> pz @('False || (Fail 'True "failed")) (99,"somedata") --- FailT "failed" --- --- >>> pz @('False || (Fail (Hole Bool) "failed")) (99,"somedata") --- FailT "failed" --- --- >>> pz @('False || (Fail (Hole _) "failed")) (99,"somedata") --- FailT "failed" --- -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] - --- | Fails the computation with a message for simple failures: doesnt preserve types --- --- >>> pz @(FailS (PrintT "value=%03d string=%s" Id)) (99,"somedata") --- FailT "value=099 string=somedata" --- -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)) - --- | Fails the computation with a message (wraps the type in 'Hole') --- --- >>> pz @(Failt Int (PrintF "value=%03d" Id)) 99 --- FailT "value=099" --- -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)) - --- | Fails the computation with a message where the input value is a Proxy --- --- >>> pz @(Ix 3 (Failp "oops")) "abcd" --- PresentT 'd' --- --- >>> pz @(Ix 3 (Failp "oops")) "abc" --- FailT "oops" --- -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)) - --- | 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" --- --- >>> pl @(OneP Id) [12] --- Present 12 (OneP) --- PresentT 12 --- --- >>> pl @(OneP Id) [1..5] --- Error OneP 5 elements (expected one element) --- FailT "OneP 5 elements" --- --- >>> pl @(OneP Id) ([] ::[()]) --- 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] - ---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 - --- | 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 --- --- >>> pl @(Between 5 8 Id) 9 --- False (9 <= 8) --- FalseT --- --- >>> pl @(Between (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),3) --- True (1 <= 3 <= 4) --- TrueT --- --- >>> pl @(Between (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),10) --- False (10 <= 4) --- 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 - - --- | A operator predicate that determines if the value is between \'p\' and \'q\' --- --- >>> pz @(5 <..> 8) 6 --- TrueT --- --- >>> pz @(10 % 4 <..> 40 % 5) 4 --- TrueT --- --- >>> pz @(10 % 4 <..> 40 % 5) 33 --- FalseT --- -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)) - --- | 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 --- --- >>> pl @(All (Gt 3) (Fst Id)) ([10,12,3,5],"ss") --- False (All(4) i=2 (3 > 3)) --- FalseT --- --- >>> pl @(All (Lt 3) Id) [1::Int .. 10] --- False (All(10) i=2 (3 < 3)) --- 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 @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 - --- | 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 --- --- >>> pl @(Any (Gt 3) (Fst Id)) ([10,12,3,5],"ss") --- True (Any(4) i=0 (10 > 3)) --- TrueT --- --- >>> pl @(Any (Same 2) Id) [1,4,5] --- False (Any(3)) --- FalseT --- --- >>> pl @(Any (Same 2) Id) [1,4,5,2,1] --- True (Any(5) i=3 (2 == 2)) --- TrueT --- -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 @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 - --- | 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 --- --- >>> pl @(Fst Id) (99,'a',False,1.3) --- Present 99 (Fst 99 | (99,'a',False,1.3)) --- PresentT 99 --- -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" --- --- >>> pl @(Snd Id) (99,'a',False,1.3) --- Present 'a' (Snd 'a' | (99,'a',False,1.3)) --- PresentT 'a' --- -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 --- --- >>> pl @(Thd Id) (99,'a',False,1.3) --- Present False (Thd False | (99,'a',False,1.3)) --- PresentT False --- -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 --- --- >>> pl @(L4 Id) (99,'a',False,"someval") --- Present "someval" (L4 "someval" | (99,'a',False,"someval")) --- PresentT "someval" --- -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 - --- | 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'] - --- | 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 @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) - --- | 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") --- --- >>> pl @(Do '[Succ Id,Id,ShowP Id,Ones Id,Map (ReadBase Int 8 Id) Id]) 1239 --- Present [1,2,4,0] ((>>) [1,2,4,0] | {Map [1,2,4,0] | ["1","2","4","0"]}) --- PresentT [1,2,4,0] --- --- >>> pl @(Do '[Pred Id,Id,ShowP Id,Ones Id,Map (ReadBase Int 8 Id) Id]) 1239 --- Error invalid base 8 (1238 (>>) rhs failed) --- FailT "invalid base 8" --- --- >>> pl @(Do '[4,5,6]) () --- Present 6 ((>>) 6 | {'6}) --- PresentT 6 --- --- >>> pl @(Do '["abc", "Def", "ggg", "hhhhh"]) () --- Present "hhhhh" ((>>) "hhhhh" | {'"hhhhh"}) --- PresentT "hhhhh" --- --- >>> pl @(Do '[ 'LT, 'EQ, 'GT ]) () --- Present GT ((>>) GT | {'GT}) --- PresentT GT --- --- >>> pl @(Do '[4 % 4,22 % 1 ,12 -% 4]) () --- Present (-3) % 1 ((>>) (-3) % 1 | {Negate (-3) % 1 | 3 % 1}) --- PresentT ((-3) % 1) --- --- >>> pl @(Do '[ W ('PresentT I), W 'FalseT, Not Id]) False --- True ((>>) True | {Not (Id False)}) --- TrueT --- --- >>> pl @(Do '[W ('PresentT Id), W 'FalseT]) True -- have to wrap them cos BoolT a vs BoolT Bool ie different types --- False ((>>) False | {W 'FalseT}) --- FalseT --- --- >>> pl @(Do '[1,2,3]) () --- Present 3 ((>>) 3 | {'3}) --- PresentT 3 --- - -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) - --- | 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] - --- | boolean 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] - - --- | 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) --- --- >>> pl @Swap (Right "asfd") --- Present Left "asfd" (Swap Left "asfd" | Right "asfd") --- PresentT (Left "asfd") --- --- >>> pl @Swap (12,"asfd") --- Present ("asfd",12) (Swap ("asfd",12) | (12,"asfd")) --- PresentT ("asfd",12) --- - -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) [] - --- | 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 '("abc",2)) --- PresentT ("abc",2) --- --- >>> pl @(2 & '(,) "abc") () --- Present ("abc",2) ('("abc",2)) --- PresentT ("abc",2) --- --- >>> pl @('(,) 4 $ '(,) 7 $ "aa") () --- Present (4,(7,"aa")) ('(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)) - --- | 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) --- --- >>> pl @(Pure Maybe Id) 'x' --- Present Just 'x' (Pure Just 'x' | 'x') --- PresentT (Just 'x') --- --- >>> pl @(Pure (Either _) Id) 'x' --- Present Right 'x' (Pure Right 'x' | 'x') --- PresentT (Right 'x') --- --- >>> pl @(Pure (Either _) Id >> Swap) 'x' --- Present Left 'x' ((>>) Left 'x' | {Swap Left 'x' | Right 'x'}) --- PresentT (Left 'x') --- --- >>> pl @(Pure (Either ()) Id >> Swap) 'x' --- Present Left 'x' ((>>) Left 'x' | {Swap Left 'x' | Right 'x'}) --- PresentT (Left 'x') --- --- >>> pl @(Pure (Either String) Id >> Swap) 123 --- Present Left 123 ((>>) Left 123 | {Swap Left 123 | Right 123}) --- PresentT (Left 123) --- -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] - --- | similar to 'coerce' --- --- >>> pz @(Coerce (SG.Sum Integer)) (Identity (-13)) --- PresentT (Sum {getSum = -13}) --- --- >>> pl @(Coerce SG.Any) True --- Present Any {getAny = True} (Coerce Any {getAny = True} | True) --- PresentT (Any {getAny = True}) --- --- >>> pl @(Coerce Bool) (SG.Any True) --- Present True (Coerce True | Any {getAny = True}) --- PresentT True --- -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) [] - - +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE NoStarIsType #-} +-- | a dsl for evaluating and displaying type level expressions +module Predicate.Core ( + -- ** basic types + Id + , IdT + , W + , Msg + , MsgI + , Hide + , Width + , Hole + , UnproxyT + , Len + , Length + , Map' + , Map + , Do + , Pure + , Coerce + , OneP + + -- ** core class + , P(..) + + -- ** IO evaluation + , pan + , panv + , pa + , pu + , pab + , pub + , pav + , puv + , pl + , pz + , run + , runs + + -- ** pure evaluation + , runP + , runPQ + , runPQBool + , evalBool + , evalBoolHide + , evalHide + , evalQuick + + -- ** wrap, unwrap + , Wrap + , Wrap' + , Unwrap + + -- ** failure + , Fail + , FailP + , FailT + , FailS + + -- ** tuple + , Fst + , Snd + , Thd + , L1 + , L2 + , L3 + , L4 + , L5 + , L6 + , L7 + , L8 + , L11 + , L12 + , L13 + , L21 + , L22 + , L23 + , L31 + , L32 + , L33 + + -- ** boolean + , type (&&) + , type (&&~) + , type (||) + , type (||~) + , type (~>) + , Not + , Between + , type (<..>) + , All + , Any + , IdBool + + -- ** type application + , type (>>) + , type (>>>) + , type (<<) + , type ($) + , type (&) + , DoL + + -- ** miscellaneous + , Swap + + ) where +import Predicate.Misc +import Predicate.Util +import qualified GHC.TypeLits as GL +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat) +import Control.Lens +import Data.Foldable (toList) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) +import Data.Kind (Type) +import Data.These (These(..)) +import Control.Monad (zipWithM) +import Control.Arrow (right) +import Data.List (find) +import Data.Tree (Tree) +import Data.Coerce (Coercible) +import Data.Tree.Lens (root) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoOverloadedLists +-- >>> import Predicate.Prelude +-- >>> import Data.Time +-- >>> :m + Control.Lens +-- >>> :m + Control.Lens.Action +-- >>> :m + Data.Typeable +-- >>> :m + Text.Show.Functions +-- >>> :m + Data.Ratio +-- >>> import qualified Data.Semigroup as SG + +-- | This is the core class. Each instance of this class can be combined into a dsl using 'Predicate.Core.>>' +class P p a where + type PP (p :: k) a :: Type -- PP is the output type + 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 p opts = fmap fixTTBool . eval p opts +-- evalBool p opts = (over (mapped . ttValBool) id) . eval p opts + + +evalQuick :: forall opts p i + . ( OptC opts + , P p i + ) + => i + -> Either String (PP p i) +evalQuick = getValLRFromTT . runIdentity . eval @_ (Proxy @p) (getOpt @opts) + +-- | identity function +-- +-- >>> pz @Id 23 +-- Val 23 +-- +data Id deriving Show +instance Show a => P Id a where + type PP Id a = a + eval _ opts a = + let msg0 = "Id" + in pure $ mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] + +-- | identity function that also displays the type information for debugging +-- +-- >>> pz @IdT 23 +-- Val 23 +data IdT deriving Show +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 (Val a) (msg0 <> " " <> showL opts a) [] + +-- | transparent wrapper to turn kind k into kind 'Type' +-- eg useful for putting in a promoted list (cant mix kinds) see 'Predicate.Core.Do' +-- +-- >>> pz @'[W 123, Id] 99 +-- Val [123,99] +-- +-- >>> pz @'[W "abc", W "def", Id, Id] "ghi" +-- Val ["abc","def","ghi","ghi"] +-- +data W (p :: k) deriving Show +instance P p a => P (W p) a where + type PP (W p) a = PP p a + eval _ opts | isVerbose opts = eval (Proxy @(MsgI "W " p)) opts + | otherwise = eval (Proxy @p) opts + +-- | add a message to give more context to the evaluation tree +-- +-- >>> pan @(Msg "[somemessage]" Id) 999 +-- P [somemessage] Id 999 +-- Val 999 +-- +-- >>> pan @(Msg Id 999) "info message:" +-- P info message: '999 +-- Val 999 +-- +data Msg prt p deriving Show + +instance ( P prt a + , PP prt a ~ String + , P p a + ) => P (Msg prt p) a where + type PP (Msg prt p) a = PP p a + eval _ opts a = do + pp <- eval (Proxy @prt) opts a + case getValueLR NoInline opts "Msg" pp [] of + Left e -> pure e + Right msg -> prefixMsg (setOtherEffects opts msg <> " ") <$> eval (Proxy @p) opts a + +-- | add a message to give more context to the evaluation tree +-- +-- >>> pan @(MsgI "[somemessage] " Id) 999 +-- P [somemessage] Id 999 +-- Val 999 +-- +-- >>> pan @(MsgI Id 999) "info message:" +-- P info message:'999 +-- Val 999 +-- +data MsgI prt p deriving Show + +instance ( P prt a + , PP prt a ~ String + , P p a + ) => P (MsgI prt p) a where + type PP (MsgI prt p) a = PP p a + eval _ opts a = do + pp <- eval (Proxy @prt) opts a + case getValueLR NoInline opts "MsgI" pp [] of + Left e -> pure e + Right msg -> prefixMsg msg <$> eval (Proxy @p) opts a + +-- | run the expression @p@ but remove the subtrees +data Hide p deriving Show +-- 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 & ttForest .~ [] + + +-- | Acts as a proxy for a Type. +data Hole (t :: Type) deriving Show + +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 _ = + let msg0 = "Hole(" <> showT @t <> ")" + in pure $ mkNode opts (Fail msg0) "you probably meant to get access to the type of PP only and not evaluate" [] + +-- | override the display width for the expression @p@ +data Width (n :: Nat) p deriving Show + +instance ( KnownNat n + , P p a + ) => P (Width n p) a where + type PP (Width n p) a = PP p a + eval _ opts a = do + let opts' = opts { oWidth = nat @n } + eval (Proxy @p) opts' a + +-- | 'const' () function +-- +-- >>> pz @() "Asf" +-- Val () +-- +instance P () a where + type PP () a = () + eval _ opts _ = + let msg0 = "()" + in pure $ mkNode opts (Val ()) msg0 [] + +-- | 'const' [] function +-- +-- >>> pz @[] "Asf" +-- Val [] +-- +instance P [] a where + type PP [] a = [a] + eval _ opts _ = + let msg0 = "[]" + in pure $ mkNode opts (Val []) msg0 [] + +-- | create a Proxy for a kind @t@ +-- +-- >>> pz @(Proxy 4) () +-- Val Proxy +-- +-- >>> pz @(Proxy Int) () +-- Val Proxy +-- +-- >>> pz @(Proxy "abc" >> Pop0 Id ()) () +-- Val "abc" +-- +instance P (Proxy t) a where + type PP (Proxy t) a = Proxy t + eval _ opts _ = + let msg0 = "Proxy" + in pure $ mkNode opts (Val Proxy) msg0 [] + +-- | pulls the type level 'Bool' to the value level +-- +-- >>> pz @'True "not used" +-- Val True +-- +-- >>> pz @'False () +-- Val False +instance GetBool b => P (b :: Bool) a where + type PP b a = Bool + eval _ opts _ = + let b = getBool @b + in pure $ mkNodeB opts b ("'" <> showL opts b) [] + +-- | pulls the type level 'GHC.TypeLits.Symbol' to the value level as a 'GHC.Base.String' +-- +-- >>> pz @"hello world" () +-- Val "hello world" +instance KnownSymbol s => P (s :: Symbol) a where + type PP s a = String + eval _ opts _ = + let s = symb @s + in pure $ mkNode opts (Val s) ("'" <> litL opts ("\"" <> s <> "\"")) [] + +-- | run the predicates in a promoted 2-tuple; similar to 'Control.Arrow.&&&' +-- +-- >>> pz @'(Id, 4) "hello" +-- Val ("hello",4) +-- +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 = "'(,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + mkNode opts (Val (p,q)) ("'(" <> showL opts p <> "," <> showL opts q <> ")") [hh pp, hh qq] + +-- | run the predicates in a promoted 3-tuple +-- +-- >>> pz @'(4, Id, "goodbye") "hello" +-- Val (4,"hello","goodbye") +-- +-- >>> pan @'( 'True, 'False, 123) True +-- P '(,,) +-- | +-- +- True 'True +-- | +-- +- False 'False +-- | +-- `- P '123 +-- Val (True,False,123) +-- +instance ( P p a + , P q a + , P r a + ) => P '(p,q,r) a where + type PP '(p,q,r) a = (PP p a, PP q a, PP r a) + eval _ opts a = do + let msg = "'(,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + rr <- eval (Proxy @r) opts a + pure $ case getValueLR NoInline opts msg rr hhs0 of + Left e -> e + Right r -> + let hhs1 = hhs0 <> [hh rr] + in mkNode opts (Val (p,q,r)) msg hhs1 + +-- | run the predicates in a promoted 4-tuple +-- +-- >>> pz @'(4, Id, "inj", 999) "hello" +-- Val (4,"hello","inj",999) +-- +instance ( P p a + , P q a + , P r a + , P s a + ) => P '(p,q,r,s) a where + type PP '(p,q,r,s) a = (PP p a, PP q a, PP r a, PP s a) + eval _ opts a = do + let msg = "'(,,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + lr1 <- runPQ NoInline msg (Proxy @r) (Proxy @s) opts a hhs0 + pure $ case lr1 of + Left e -> e + Right (r,s,rr,ss) -> + let hhs1 = hhs0 ++ [hh rr, hh ss] + in mkNode opts (Val (p,q,r,s)) msg hhs1 + +-- | run the predicates in a promoted 5-tuple +-- +-- >>> pz @'(4, Id, "inj", 999, 'LT) "hello" +-- Val (4,"hello","inj",999,LT) +-- +instance ( P p a + , P q a + , P r a + , P s a + , P t a + ) => P '(p,q,r,s,t) a where + type PP '(p,q,r,s,t) a = (PP p a, PP q a, PP r a, PP s a, PP t a) + eval _ opts a = do + let msg = "'(,,,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + lr1 <- runPQ NoInline msg (Proxy @r) (Proxy @s) opts a hhs0 + case lr1 of + Left e -> pure e + Right (r,s,rr,ss) -> do + let hhs1 = hhs0 ++ [hh rr, hh ss] + tt <- eval (Proxy @t) opts a + pure $ case getValueLR NoInline opts msg tt hhs1 of + Left e -> e + Right t -> + let hhs2 = hhs1 <> [hh tt] + in mkNode opts (Val (p,q,r,s,t)) msg hhs2 + +-- | run the predicates in a promoted 6-tuple +-- +-- >>> pz @'(4, Id, "inj", 999, 'LT, 1) "hello" +-- Val (4,"hello","inj",999,LT,1) +-- +instance ( P p a + , P q a + , P r a + , P s a + , P t a + , P u a + ) => P '(p,q,r,s,t,u) a where + type PP '(p,q,r,s,t,u) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a) + eval _ opts a = do + let msg = "'(,,,,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + lr1 <- runPQ NoInline msg (Proxy @r) (Proxy @s) opts a hhs0 + case lr1 of + Left e -> pure e + Right (r,s,rr,ss) -> do + let hhs1 = hhs0 ++ [hh rr, hh ss] + lr2 <- runPQ NoInline msg (Proxy @t) (Proxy @u) opts a hhs1 + pure $ case lr2 of + Left e -> e + Right (t,u,tt,uu) -> + let hhs2 = hhs1 ++ [hh tt, hh uu] + in mkNode opts (Val (p,q,r,s,t,u)) msg hhs2 + +-- | run the predicates in a promoted 7-tuple +-- +-- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2) "hello" +-- Val (4,"hello","inj",999,LT,1,2) +-- +instance ( P p a + , P q a + , P r a + , P s a + , P t a + , P u a + , P v a + ) => P '(p,q,r,s,t,u,v) a where + type PP '(p,q,r,s,t,u,v) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a) + eval _ opts a = do + let msg = "'(,,,,,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + lr1 <- runPQ NoInline msg (Proxy @r) (Proxy @s) opts a hhs0 + case lr1 of + Left e -> pure e + Right (r,s,rr,ss) -> do + let hhs1 = hhs0 ++ [hh rr, hh ss] + lr2 <- runPQ NoInline msg (Proxy @t) (Proxy @u) opts a hhs1 + case lr2 of + Left e -> pure e + Right (t,u,tt,uu) -> do + vv <- eval (Proxy @v) opts a + let hhs2 = hhs1 ++ [hh tt, hh uu] + pure $ case getValueLR NoInline opts msg vv hhs2 of + Left e -> e + Right v -> + let hhs3 = hhs2 ++ [hh vv] + in mkNode opts (Val (p,q,r,s,t,u,v)) msg hhs3 + +-- | run the predicates in a promoted 8-tuple +-- +-- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2, 3) "hello" +-- Val (4,"hello","inj",999,LT,1,2,3) +-- +instance ( P p a + , P q a + , P r a + , P s a + , P t a + , P u a + , P v a + , P w a + ) => P '(p,q,r,s,t,u,v,w) a where + type PP '(p,q,r,s,t,u,v,w) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a, PP w a) + eval _ opts a = do + let msg = "'(,,,,,,,)" + lr <- runPQ NoInline msg (Proxy @p) (Proxy @q) opts a [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs0 = [hh pp, hh qq] + lr1 <- runPQ NoInline msg (Proxy @r) (Proxy @s) opts a hhs0 + case lr1 of + Left e -> pure e + Right (r,s,rr,ss) -> do + let hhs1 = hhs0 ++ [hh rr, hh ss] + lr2 <- runPQ NoInline msg (Proxy @t) (Proxy @u) opts a hhs1 + case lr2 of + Left e -> pure e + Right (t,u,tt,uu) -> do + let hhs2 = hhs1 ++ [hh tt, hh uu] + lr3 <- runPQ NoInline msg (Proxy @v) (Proxy @w) opts a hhs2 + pure $ case lr3 of + Left e -> e + Right (v,w,vv,ww) -> + let hhs3 = hhs2 ++ [hh vv, hh ww] + in mkNode opts (Val (p,q,r,s,t,u,v,w)) msg hhs3 + + +-- | extracts the value level representation of the promoted 'Ordering' +-- +-- >>> pz @'LT "not used" +-- Val LT +-- +-- >>> pz @'EQ () +-- Val EQ +instance GetOrdering cmp => P (cmp :: Ordering) a where + type PP cmp a = Ordering + eval _ opts _ = + let cmp = getOrdering @cmp + msg = "'" <> showL opts cmp + in pure $ mkNode opts (Val cmp) msg [] + +-- | extracts the value level representation of the type level 'Nat' +-- +-- >>> pz @123 () +-- Val 123 +-- +instance KnownNat n => P (n :: Nat) a where + type PP n a = Int + eval _ opts _ = + let n = nat @n + in pure $ mkNode opts (Val n) ("'" <> showL opts n) [] + +-- | extracts the value level representation of the type level '() +-- +-- >>> pz @'() () +-- Val () +instance P '() a where + type PP '() a = () + eval _ opts _ = pure $ mkNode opts (Val ()) "'()" [] + +-- the type has to be [a] so we still need type PP '[p] a = [PP p a] to keep the types in line + +-- | extracts the value level representation of the type level '[] +-- +-- >>> pz @'[] False +-- Val [] +instance P ('[] :: [k]) a where + type PP ('[] :: [k]) a = [a] + eval _ opts _ = pure $ mkNode opts (Val mempty) "'[]" [] + +-- | runs each predicate in turn from the promoted list +-- +-- >>> pz @'[1, 2, 3] 999 +-- Val [1,2,3] +-- +-- >>> pz @'[W 1, W 2, W 3, Id] 999 +-- Val [1,2,3,999] +-- +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 NoInline opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (Val [b]) ("'" <> showL opts ([b] :: [PP p a]) <> showVerbose opts " | " a) [hh pp] + +instance ( Show (PP p a) + , Show a + , P (p1 ': ps) a + , PP (p1 ': ps) a ~ [PP p1 a] + , P p a + , PP p a ~ PP p1 a + ) => P (p ': p1 ': ps) a where + type PP (p ': p1 ': ps) a = [PP p a] + eval _ opts a = do + let msg0 = "'(p':q)" + pp <- eval (Proxy @p) opts a + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @(p1 ': ps)) opts a + pure $ case getValueLR Inline opts "" qq [hh pp] of + Left e -> e + Right q -> + let ret = p:q + in mkNode opts (Val ret) ("'" <> showL opts ret <> litVerbose opts " " (topMessage pp) <> showVerbose opts " | " a) (verboseList opts pp <> [hh qq]) + +-- | tries to extract @a@ from @Maybe a@ otherwise it fails: similar to 'Data.Maybe.fromJust' +-- +-- >>> pz @('Just Id) (Just "abc") +-- Val "abc" +-- +-- >>> pl @('Just Id >> Id) (Just 123) +-- Present 123 ((>>) 123 | {Id 123}) +-- Val 123 +-- +-- >>> pl @('Just Id) (Just [1,2,3]) +-- Present [1,2,3] ('Just [1,2,3] | Just [1,2,3]) +-- Val [1,2,3] +-- +-- >>> pl @('Just Id) (Just 10) +-- Present 10 ('Just 10 | Just 10) +-- Val 10 +-- +-- >>> pl @('Just Id) Nothing +-- Error 'Just(empty) +-- Fail "'Just(empty)" +-- +-- >>> pz @('Just Fst) (Just 123,'x') +-- Val 123 +-- +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + case p of + Nothing -> mkNode opts (Fail (msg0 <> "(empty)")) "" [hh pp] + Just d -> mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + +-- | expects Nothing otherwise it fails +-- if the value is Nothing then it returns @Proxy a@ as this provides type information +-- +-- >>> pz @'Nothing Nothing +-- Val Proxy +-- +-- >>> pz @'Nothing (Just True) +-- Fail "'Nothing found Just" +-- +instance P 'Nothing (Maybe a) where + type PP 'Nothing (Maybe a) = Proxy a -- () gives us less information + eval _ opts ma = + let msg0 = "'Nothing" + in pure $ case ma of + Nothing -> mkNode opts (Val Proxy) msg0 [] + Just _ -> mkNode opts (Fail (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 +-- +-- >>> pz @('Left Id) (Left 123) +-- Val 123 +-- +-- >>> pz @('Left Snd) ('x', Left 123) +-- Val 123 +-- +-- >>> pz @('Left Id) (Right "aaa") +-- Fail "'Left found Right" +-- +-- >>> pl @('Left Id) (Left 123) +-- Present 123 (Left) +-- Val 123 +-- +-- >>> pl @('Left Id) (Right 123) +-- Error 'Left found Right +-- Fail "'Left found Right" +-- + +instance ( PP p x ~ Either a b + , P p x + ) + => P ('Left p) x where + type PP ('Left p) x = LeftT (PP p x) + eval _ opts x = do + let msg0 = "'Left" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + case p of + Left a -> mkNode opts (Val a) "Left" [hh pp] + Right _b -> mkNode opts (Fail (msg0 <> " found Right")) "" [hh pp] + +-- | extracts the @b@ from type level @Either a b@ if the value exists +-- +-- >>> pl @('Right Id) (Right 123) +-- Present 123 (Right) +-- Val 123 +-- +-- >>> pz @('Right Id >> Snd) (Right ('x',123)) +-- Val 123 +-- +-- >>> pz @('Right Id) (Left "aaa") +-- Fail "'Right found Left" +-- +-- >>> pl @('Right Id) (Left 123) +-- Error 'Right found Left +-- Fail "'Right found Left" +-- +instance ( PP p x ~ Either a b + , P p x + ) + => P ('Right p) x where + type PP ('Right p) x = RightT (PP p x) + eval _ opts x = do + let msg0 = "'Right" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + case p of + Left _a -> mkNode opts (Fail (msg0 <> " found Left")) "" [hh pp] + Right b -> mkNode opts (Val b) "Right" [hh pp] + + +-- removed Show x: else ambiguity errors in TestPredicate + +-- | extracts the @a@ from type level @These a b@ if the value exists +-- +-- >>> pl @('This Id) (This 12) +-- Present 12 (This) +-- Val 12 +-- +-- >>> pz @('This Id) (That "aaa") +-- Fail "'This found That" +-- +-- >>> pz @('This Id) (These 999 "aaa") +-- Fail "'This found These" +-- +-- >>> pl @('This Id) (That 12) +-- Error 'This found That +-- Fail "'This found That" +-- + +instance ( PP p x ~ These a b + , P p x + ) + => P ('This p) x where + type PP ('This p) x = ThisT (PP p x) + eval _ opts x = do + let msg0 = "'This" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + case p of + This a -> mkNode opts (Val a) "This" [hh pp] + That _b -> mkNode opts (Fail (msg0 <> " found That")) "" [hh pp] + These _a _b -> mkNode opts (Fail (msg0 <> " found These")) "" [hh pp] + +-- | extracts the @b@ from type level @These a b@ if the value exists +-- +-- >>> pz @('That Id) (That 123) +-- Val 123 +-- +-- >>> pz @('That Id) (This "aaa") +-- Fail "'That found This" +-- +-- >>> pz @('That Id) (These 44 "aaa") +-- Fail "'That found These" +-- + +instance ( PP p x ~ These a b + , P p x + ) + => P ('That p) x where + type PP ('That p) x = ThatT (PP p x) + eval _ opts x = do + let msg0 = "'That" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + case p of + This _a -> mkNode opts (Fail (msg0 <> " found This")) "" [hh pp] + That b -> mkNode opts (Val b) "That" [hh pp] + These _a _b -> mkNode opts (Fail (msg0 <> " found These")) "" [hh pp] + + +-- | extracts the (a,b) from type level @These a b@ if the value exists +-- +-- >>> pz @('These Id Id) (These 123 "abc") +-- Val (123,"abc") +-- +-- >>> pz @('These Id 5) (These 123 "abcde") +-- Val (123,5) +-- +-- >>> pz @('These Id Id) (This "aaa") +-- Fail "'These found This" +-- +-- >>> pz @('These Id Id) (That "aaa") +-- Fail "'These found That" +-- +instance ( Show a + , Show b + , P p a + , P q b + , Show (PP p a) + , Show (PP q b) + ) => P ('These p q) (These a b) where + type PP ('These p q) (These a b) = (PP p a, PP q b) + eval _ opts th = do + let msg0 = "'These" + case th of + These a b -> do + pp <- eval (Proxy @p) opts a + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR NoInline opts (msg0 <> " q failed p=" <> showL opts p) qq [hh pp] of + Left e -> e + Right q -> + let ret =(p,q) + in mkNode opts (Val ret) (show3 opts msg0 ret (These a b)) [hh pp, hh qq] + _ -> pure $ mkNode opts (Fail (msg0 <> " found " <> showThese th)) "" [] + +-- | converts the type to the corresponding 'Proxy' +-- +-- >>> pz @'Proxy 'x' ^!? acts . _Val . to typeRep +-- Just Char +-- +-- >>> pz @'Proxy 45 ^!? acts . _Val . to typeRep +-- Just Integer +-- +-- >>> pz @'Proxy "abc" ^!? acts . _Val . to typeRep +-- Just [Char] +-- +-- >>> pz @(Pop1' (Proxy ToEnum) 'Proxy 2) LT +-- Val GT +-- +instance P 'Proxy t where + type PP 'Proxy t = Proxy t + eval _ opts _ = + let b = Proxy @t + in pure $ mkNode opts (Val b) "'Proxy" [] + +-- | evaluate the type level expression in IO +-- +-- >>> pl @(Between 4 10 Id) 7 & mapped . _Val %~ not +-- True (4 <= 7 <= 10) +-- Val False +-- +-- >>> eval (Proxy @'True) defOpts 7 & mapped . ttValBool . _Val %~ not +-- TT {_ttValP = FalseP, _ttVal = Val False, _ttString = "'True", _ttForest = []} +-- + +pu, pl, pa, pan, panv, pab, pub, pav, puv, pz + :: forall p a + . ( Show (PP p a) + , P p a + ) => a + -> IO (Val (PP p a)) +-- | skips the evaluation tree and just displays the end result +pz = run @OZ @p +-- | same as 'pz' but adds context to the end result +pl = run @OL @p +-- | displays the evaluation tree in plain text without colors +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 +-- | displays the evaluation tree using background colors +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 +-- | displays the evaluation tree using unicode and colors with background colors +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 +-- Val 123 +-- +-- >>> run @('OMsg "field1" ':# OL) @('Left Id) (Right 123) +-- field1 >>> Error 'Left found Right +-- Fail "'Left found Right" +-- +-- >>> run @(OptT '[ 'OMsg "test", OU, 'OEmpty, OL, 'OMsg "field2"]) @(FailT _ "oops") () +-- test | field2 >>> Error oops +-- Fail "oops" +-- +run :: forall opts p a + . ( OptC opts + , Show (PP p a) + , P p a + ) + => a + -> IO (Val (PP p a)) +run a = do + let opts = getOpt @opts + pp <- eval (Proxy @p) opts a + case oDebug opts of + DZero -> pure () + _ -> unlessNullM (prtTree opts pp) putStrLn + return (_ttVal pp) + +-- | run expression with multiple options in a list +-- +-- >>> runs @'[OL, 'OMsg "field2"] @'( 'True, 'False) () +-- field2 >>> Present (True,False) ('(True,False)) +-- Val (True,False) +-- +-- >>> runs @'[ 'OMsg "test", OU, 'OEmpty, OL, 'OMsg "field2"] @(FailT _ "oops") () +-- test | field2 >>> Error oops +-- Fail "oops" +-- +runs :: forall optss p a + . ( OptC (OptT optss) + , Show (PP p a) + , P p a + ) + => a + -> IO (Val (PP p a)) +runs = run @(OptT optss) @p + +-- | convenience method to evaluate one expression +runP :: ( P p a + , MonadEval m) + => Inline + -> String + -> proxy p + -> POpts + -> a + -> [Tree PE] + -> m (Either (TT x) (PP p a, TT (PP p a))) +runP inline msg0 proxyp opts a hhs = do + pp <- eval proxyp opts a + return $ right (,pp) $ getValueLR inline opts msg0 pp hhs + +-- | convenience method to evaluate two expressions using the same input and return the results +runPQ :: ( P p a + , P q a + , MonadEval m) + => Inline + -> String + -> proxy1 p + -> proxy2 q + -> POpts + -> a + -> [Tree PE] + -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) +runPQ inline msg0 proxyp proxyq opts a hhs = do + pp <- eval proxyp opts a + case getValueLR inline opts msg0 pp hhs of + Left e -> pure $ Left e + Right p -> do + qq <- eval proxyq opts a + pure $ case getValueLR inline opts msg0 qq (hhs <> [hh pp]) of + Left e -> Left e + Right q -> Right (p, q, pp, qq) + +-- | convenience method to evaluate two boolean expressions using the same input and return the results +runPQBool :: ( P p a + , PP p a ~ Bool + , P q a + , PP q a ~ Bool, MonadEval m) + => Inline + -> String + -> proxy1 p + -> proxy2 q + -> POpts + -> a + -> [Tree PE] + -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) +runPQBool inline msg0 proxyp proxyq opts a hhs = do + pp <- evalBool proxyp opts a + case getValueLR inline opts msg0 pp hhs of + Left e -> pure $ Left e + Right p -> do + qq <- evalBool proxyq opts a + pure $ case getValueLR inline opts msg0 qq (hhs <> [hh pp]) of + Left e -> Left e + Right q -> Right (p, q, pp, qq) + +-- | evaluate a boolean expressions but hide the results unless verbose +evalBoolHide :: forall p a m + . (MonadEval m, P p a, PP p a ~ Bool) + => POpts + -> a + -> m (TT (PP p a)) +evalBoolHide opts + | isVerbose opts = evalBool (Proxy @p) opts + | otherwise = evalBool (Proxy @(Hide p)) opts + +-- | evaluate a expressions but hide the results unless verbose +evalHide :: forall p a m + . ( MonadEval m + , P p a + ) + => POpts + -> a + -> m (TT (PP p a)) +evalHide opts + | isVerbose opts = eval (Proxy @p) opts + | otherwise = eval (Proxy @(Hide p)) opts + + +-- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' + +-- | compose expressions +-- +-- >>> pz @(L11 >> Not Id) ((True,12),'x') +-- Val False +-- +-- >>> pz @(L12 >> Succ >> Dup) ((True,12),'x') +-- Val (13,13) +-- +-- >>> pz @(10 >> '(Id,"abc") >> Second Len) () +-- Val (10,3) +-- +data p >> q deriving Show +infixr 1 >> + +instance ( P p a + , P q (PP p a) + , Show (PP p a) + , Show (PP 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 NoInline opts "" pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts p + pure $ case getValueLR NoInline opts (showL opts p) qq [hh pp] of + -- need to look inside to see if there is already an exception in ttForest + Left e | isVerbose opts -> e + | otherwise -> + if anyOf (ttForest . folded . root . peValP) (has _FailP) qq + then qq & ttForest %~ (hh pp:) -- we still need pp for context + else e + Right q -> mkNodeCopy opts qq (lit3 opts msg0 q "" (topMessageEgregious qq)) [hh pp, hh qq] + +-- | infixl version of 'Predicate.Core.>>' +data p >>> q deriving Show +type RightArrowsLeftInfixT p q = p >> q +infixl 1 >>> + +instance P (RightArrowsLeftInfixT p q) x => P (p >>> q) x where + type PP (p >>> q) x = PP (RightArrowsLeftInfixT p q) x + eval _ = eval (Proxy @(RightArrowsLeftInfixT p q)) + + +-- | flipped version of 'Predicate.Core.>>' +data p << q deriving Show +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)) + +-- bearbeiten! only used by >> +topMessageEgregious :: TT a -> String +topMessageEgregious pp = innermost (_ttString pp) + where innermost = ('{':) . reverse . ('}':) . takeWhile (/='{') . dropWhile (=='}') . reverse + +-- | unwraps a value (see '_Wrapped'') +-- +-- >>> pz @Unwrap (SG.Sum (-13)) +-- Val (-13) +-- +-- >>> pl @(Unwrap >> '(Id, 'True)) (SG.Sum 13) +-- Present (13,True) ((>>) (13,True) | {'(13,True)}) +-- Val (13,True) +-- +data Unwrap deriving Show + +instance ( Show x + , Show (Unwrapped x) + , Wrapped x + ) => P Unwrap x where + type PP Unwrap x = Unwrapped x + eval _ opts x = + let msg0 = "Unwrap" + d = x ^. _Wrapped' + in pure $ mkNode opts (Val d) (show3 opts msg0 d x) [] + +data Wrap' t p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = p ^. _Unwrapped' + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + +-- | wraps a value (see '_Wrapped'' and '_Unwrapped'') +-- +-- >>> pz @(Wrap (SG.Sum _) Id) (-13) +-- Val (Sum {getSum = -13}) +-- +-- >>> pz @(Wrap SG.Any (Ge 4)) 13 +-- Val (Any {getAny = True}) +-- +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> pz @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" +-- Val ('a' :| "bcd") +-- +-- >>> pl @(Wrap (SG.Sum _) Id) 13 +-- Present Sum {getSum = 13} (Wrap Sum {getSum = 13} | 13) +-- Val (Sum {getSum = 13}) +-- +-- >>> pl @(Wrap (SG.Sum _) Id >> STimes 4 Id) 13 +-- Present Sum {getSum = 52} ((>>) Sum {getSum = 52} | {getSum = 13}) +-- Val (Sum {getSum = 52}) +-- +-- >>> pl @(Wrap _ 13 <> Id) (SG.Sum @Int 12) +-- Present Sum {getSum = 25} (Sum {getSum = 13} <> Sum {getSum = 12} = Sum {getSum = 25}) +-- Val (Sum {getSum = 25}) +-- + +data Wrap (t :: Type) p deriving Show +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)) + + +-- | used internally for type inference +data UnproxyT deriving Show + +instance Typeable t => P UnproxyT (Proxy (t :: Type)) where + type PP UnproxyT (Proxy t) = t + eval _ opts _ = + let msg0 = "UnproxyT(" <> showT @t <> ")" + in pure $ mkNode opts (Fail msg0) "you probably meant to get access to the type of PP only and not evaluate (see Pop0)" [] + +-- | similar to 'length' +-- +-- >>> pz @Len [10,4,5,12,3,4] +-- Val 6 +-- +-- >>> pz @Len [] +-- Val 0 +-- +-- >>> pz @(Pairs >> Len > 2) "abcdef" +-- Val True +-- +data Len deriving Show +instance ( Show a + , x ~ [a] + ) => P Len x where + type PP Len x = Int + eval _ opts as = + let msg0 = "Len" + n = length as + in pure $ mkNode opts (Val n) (show3 opts msg0 n as) [] + +-- | similar to 'length' for 'Foldable' instances +-- +-- >>> pz @(Length Id) (Left "aa") +-- Val 0 +-- +-- >>> pz @(Length Id) (Right "aa") +-- Val 1 +-- +-- >>> pz @(Length Right') (Right "abcd") +-- Val 4 +-- +-- >>> pz @(Length L23) (True,(23,'x',[10,9,1,3,4,2])) +-- Val 6 +-- +data Length p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let n = length p + in mkNode opts (Val n) (show3 opts msg0 n p) [hh pp] + +-- | 'not' function +-- +-- >>> pz @(Not Id) False +-- Val True +-- +-- >>> pz @(Not Id) True +-- Val False +-- +-- >>> pz @(Not Fst) (True,22) +-- Val False +-- +-- >>> pl @(Not (Lt 3)) 13 +-- True (Not (13 < 3)) +-- Val True +-- +-- >>> pl @(Not 'True) () +-- False (Not ('True)) +-- Val False +-- +data Not p deriving Show + +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 NoInline 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 @('[ 'True] >> Head >> IdBool) () +-- Val True +-- +-- >>> pz @(Fst >> IdBool) (False,22) +-- Val False +-- +-- >>> pl @(Head >> IdBool) [True] +-- True ((>>) True | {IdBool}) +-- Val True +-- +-- >>> pan @(Head >> Id) [True] +-- P (>>) True +-- | +-- +- P Head True +-- | +-- `- P Id True +-- Val True +-- +-- >>> pan @(Head >> IdBool) [True] +-- True (>>) True +-- | +-- +- P Head True +-- | +-- `- True IdBool +-- Val True +-- + +data IdBool deriving Show + +instance x ~ Bool + => P IdBool x where + type PP IdBool x = Bool + eval _ opts x = + let msg0 = "IdBool" + in pure $ mkNodeB opts x msg0 [] + +-- | Fails the computation with a message but allows you to set the output type +-- +-- >>> pz @('False || (Fail 'True "failed")) (99,"somedata") +-- Fail "failed" +-- +-- >>> pz @('False || (Fail (Hole Bool) "failed")) (99,"somedata") +-- Fail "failed" +-- +-- >>> pz @('False || (Fail (Hole _) "failed")) (99,"somedata") +-- Fail "failed" +-- +data Fail t prt deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right s -> mkNode opts (Fail s) "" (verboseList opts pp) + +-- | Fails the computation with a message for simple failures: doesnt preserve types +-- +-- >>> pz @(FailS (PrintT "value=%03d string=%s" Id)) (99,"somedata") +-- Fail "value=099 string=somedata" +-- +data FailS p deriving Show +instance P (Fail Id p) x => P (FailS p) x where + type PP (FailS p) x = PP (Fail Id p) x + eval _ = eval (Proxy @(Fail Id p)) + +-- | Fails the computation with a message (wraps the type in 'Hole') +-- +-- >>> pz @(FailT Int (PrintF "value=%03d" Id)) 99 +-- Fail "value=099" +-- +data FailT (t :: Type) p deriving Show +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)) + +-- | Fails the computation with a message where the input value is a Proxy +-- +-- >>> pz @(Ix 3 (FailP "oops")) "abcd" +-- Val 'd' +-- +-- >>> pz @(Ix 3 (FailP "oops")) "abc" +-- Fail "oops" +-- +data FailP p deriving Show +instance P (Fail UnproxyT p) x => P (FailP p) x where + type PP (FailP p) x = PP (Fail UnproxyT p) x + eval _ = eval (Proxy @(Fail UnproxyT p)) + +-- | gets the singleton value from a foldable +-- +-- >>> pl @OneP [10..15] +-- Error OneP:expected one element(6) +-- Fail "OneP:expected one element(6)" +-- +-- >>> pl @OneP [10] +-- Present 10 (OneP) +-- Val 10 +-- +-- >>> pl @OneP [] +-- Error OneP:expected one element(empty) +-- Fail "OneP:expected one element(empty)" +-- +-- >>> pl @OneP (Just 10) +-- Present 10 (OneP) +-- Val 10 +-- +-- >>> pl @OneP Nothing +-- Error OneP:expected one element(empty) +-- Fail "OneP:expected one element(empty)" +-- +data OneP deriving Show +instance ( Foldable t + , x ~ t a + ) => P OneP x where + type PP OneP x = ExtractAFromTA x + eval _ opts x = do + let msg0 = "OneP" + pure $ case toList x of + [] -> mkNode opts (Fail (msg0 <> ":expected one element(empty)")) "" [] + [a] -> mkNode opts (Val a) msg0 [] + as -> let n = length as + in mkNode opts (Fail (msg0 <> ":expected one element(" <> show n <> ")")) "" [] + +--type OneP = Guard "expected list of length 1" (Len == 1) >> Head +--type OneP = Guard (PrintF "expected list of length 1 but found length=%d" Len) (Len == 1) >> Head + +-- | A predicate that determines if the value is between @p@ and @q@ +-- +-- >>> pz @(Between 5 8 Len) [1,2,3,4,5,5,7] +-- Val True +-- +-- >>> pl @(Between 5 8 Id) 9 +-- False (9 <= 8) +-- Val False +-- +-- >>> pl @(Between L11 L12 Snd) ((1,4),3) +-- True (1 <= 3 <= 4) +-- Val True +-- +-- >>> pl @(Between L11 L12 Snd) ((1,4),10) +-- False (10 <= 4) +-- Val False +-- +data Between p q r deriving Show + +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 NoInline opts msg0 rr [] of + Left e -> pure e + Right r -> do + lr <- runPQ NoInline 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 + + +-- | A operator predicate that determines if the value is between @p@ and @q@ +-- +-- >>> pz @(5 <..> 8) 6 +-- Val True +-- +-- >>> pz @(10 % 4 <..> 40 % 5) 4 +-- Val True +-- +-- >>> pz @(10 % 4 <..> 40 % 5) 33 +-- Val False +-- +data p <..> q deriving Show +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)) + +-- | similar to 'all' +-- +-- >>> pl @(All (Between 1 8 Id)) [7,3,4,1,2,9,0,1] +-- False (All(8) i=5 (9 <= 8)) +-- Val False +-- +-- >>> pz @(All Odd) [1,5,11,5,3] +-- Val True +-- +-- >>> pz @(All Odd) [] +-- Val True +-- +-- >>> run @OANV @(All Even) [1,5,11,5,3] +-- False All(5) i=0 (1 == 0) +-- | +-- +- False i=0: 1 == 0 +-- | | +-- | +- P 1 `mod` 2 = 1 +-- | | | +-- | | +- P Id 1 +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=1: 1 == 0 +-- | | +-- | +- P 5 `mod` 2 = 1 +-- | | | +-- | | +- P Id 5 +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=2: 1 == 0 +-- | | +-- | +- P 11 `mod` 2 = 1 +-- | | | +-- | | +- P Id 11 +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- +- False i=3: 1 == 0 +-- | | +-- | +- P 5 `mod` 2 = 1 +-- | | | +-- | | +- P Id 5 +-- | | | +-- | | `- P '2 +-- | | +-- | `- P '0 +-- | +-- `- False i=4: 1 == 0 +-- | +-- +- P 3 `mod` 2 = 1 +-- | | +-- | +- P Id 3 +-- | | +-- | `- P '2 +-- | +-- `- P '0 +-- Val False +-- +-- >>> pl @(Fst >> All (Gt 3)) ([10,12,3,5],"ss") +-- False ((>>) False | {All(4) i=2 (3 > 3)}) +-- Val False +-- +-- >>> pl @(All (Lt 3)) [1 .. 10] +-- False (All(10) i=2 (3 < 3)) +-- Val False +-- +data All p deriving Show + +instance ( P p a + , PP p a ~ Bool + , x ~ f a + , Show a + , Foldable f + ) => P (All p) x where + type PP (All p) x = Bool + eval _ opts x = do + let msg0 = "All" + case chkSize opts msg0 x [] of + Left e -> pure e + Right xs -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBoolHide @p opts a) [0::Int ..] xs + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let hhs = map (hh . prefixNumberToTT) ts + msg1 = msg0 ++ "(" ++ showL opts (length x) ++ ")" + in case find (not . view _1) abcs of + Nothing -> mkNodeB opts True msg1 hhs + Just (_,(i,_),tt) -> + mkNodeB opts False (msg1 <> " i=" ++ show i ++ " " <> topMessage tt) hhs + +-- | similar to 'any' +-- +-- >>> pl @(Any Even) [1,5,11,5,3] +-- False (Any(5)) +-- Val False +-- +-- >>> pl @(Any Even) [1,5,112,5,3] +-- True (Any(5) i=2 (0 == 0)) +-- Val True +-- +-- >>> pz @(Any Even) [] +-- Val False +-- +-- >>> pl @(Fst >> Any (Gt 3)) ([10,12,3,5],"ss") +-- True ((>>) True | {Any(4) i=0 (10 > 3)}) +-- Val True +-- +-- >>> pl @(Any (Same 2)) [1,4,5] +-- False (Any(3)) +-- Val False +-- +-- >>> pl @(Any (Same 2)) [1,4,5,2,1] +-- True (Any(5) i=3 (2 == 2)) +-- Val True +-- +data Any p deriving Show +instance ( P p a + , PP p a ~ Bool + , x ~ f a + , Show a + , Foldable f + ) => P (Any p) x where + type PP (Any p) x = Bool + eval _ opts x = do + let msg0 = "Any" + case chkSize opts msg0 x [] of + Left e -> pure e + Right xs -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBoolHide @p opts a) [0::Int ..] xs + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let hhs = map (hh . prefixNumberToTT) ts + msg1 = msg0 ++ "(" ++ showL opts (length xs) ++ ")" + in case find (view _1) abcs of + Nothing -> mkNodeB opts False msg1 hhs + Just (_,(i,_),tt) -> + mkNodeB opts True (msg1 <> " i=" ++ show i ++ " " <> topMessage tt) hhs + +-- | similar to 'fst' +-- +-- >>> pz @Fst (10,"Abc") +-- Val 10 +-- +-- >>> pz @Fst (10,"Abc",'x') +-- Val 10 +-- +-- >>> pz @Fst (10,"Abc",'x',False) +-- Val 10 +-- +-- >>> pl @Fst (99,'a',False,1.3) +-- Present 99 (Fst 99 | (99,'a',False,1.3)) +-- Val 99 +-- +data L1 p deriving Show + +instance ( Show (ExtractL1T (PP p x)) + , ExtractL1C (PP p x) + , P p x + , Show (PP p x) + ) => P (L1 p) x where + type PP (L1 p) x = ExtractL1T (PP p x) + eval _ opts x = do + let msg0 = "Fst" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL1C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +data Fst deriving Show +type FstT = L1 Id + +instance P FstT x => P Fst x where + type PP Fst x = PP FstT x + eval _ = eval (Proxy @FstT) + +-- | similar to 'snd' +-- +-- >>> pz @Snd (10,"Abc") +-- Val "Abc" +-- +-- >>> pz @Snd (10,"Abc",True) +-- Val "Abc" +-- +-- >>> pl @Snd (99,'a',False,1.3) +-- Present 'a' (Snd 'a' | (99,'a',False,1.3)) +-- Val 'a' +-- +data L2 p deriving Show + +instance ( Show (ExtractL2T (PP p x)) + , ExtractL2C (PP p x) + , P p x + , Show (PP p x) + ) => P (L2 p) x where + type PP (L2 p) x = ExtractL2T (PP p x) + eval _ opts x = do + let msg0 = "Snd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL2C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +data Snd deriving Show + +type SndT = L2 Id + +instance P SndT x => P Snd x where + type PP Snd x = PP SndT x + eval _ = eval (Proxy @SndT) + +-- | similar to 3rd element in a n-tuple +-- +-- >>> pz @Thd (10,"Abc",133) +-- Val 133 +-- +-- >>> pz @Thd (10,"Abc",133,True) +-- Val 133 +-- +-- >>> pl @Thd (99,'a',False,1.3) +-- Present False (Thd False | (99,'a',False,1.3)) +-- Val False +-- +data L3 p deriving Show + +instance ( Show (ExtractL3T (PP p x)) + , ExtractL3C (PP p x) + , P p x + , Show (PP p x) + ) => P (L3 p) x where + type PP (L3 p) x = ExtractL3T (PP p x) + eval _ opts x = do + let msg0 = "Thd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL3C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +data Thd deriving Show +type ThdT = L3 Id + +instance P ThdT x => P Thd x where + type PP Thd x = PP ThdT x + eval _ = eval (Proxy @ThdT) + +-- | similar to 4th element in a n-tuple +-- +-- >>> pz @(L4 Id) (10,"Abc",'x',True) +-- Val True +-- +-- >>> pz @(L4 L21) ('x',((10,"Abc",'x',999),"aa",1),9) +-- Val 999 +-- +-- >>> pl @(L4 Id) (99,'a',False,"someval") +-- Present "someval" (L4 "someval" | (99,'a',False,"someval")) +-- Val "someval" +-- +data L4 p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL4C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | similar to 5th element in a n-tuple +-- +-- >>> pz @(L5 Id) (10,"Abc",'x',True,1) +-- Val 1 +-- +data L5 p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL5C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + + +-- | similar to 6th element in a n-tuple +-- +-- >>> pz @(L6 Id) (10,"Abc",'x',True,1,99) +-- Val 99 +-- +data L6 p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL6C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | similar to 7th element in a n-tuple +-- +-- >>> pz @(L7 Id) (10,"Abc",'x',True,1,99,'a') +-- Val 'a' +-- +data L7 p deriving Show + +instance ( Show (ExtractL7T (PP p x)) + , ExtractL7C (PP p x) + , P p x + , Show (PP p x) + ) => P (L7 p) x where + type PP (L7 p) x = ExtractL7T (PP p x) + eval _ opts x = do + let msg0 = "L7" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL7C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | similar to 8th element in a n-tuple +-- +-- >>> pz @(L8 Id) (10,"Abc",'x',True,1,99,True,'a') +-- Val 'a' +-- +data L8 p deriving Show + +instance ( Show (ExtractL8T (PP p x)) + , ExtractL8C (PP p x) + , P p x + , Show (PP p x) + ) => P (L8 p) x where + type PP (L8 p) x = ExtractL8T (PP p x) + eval _ opts x = do + let msg0 = "L8" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL8C p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | similar to 'map' for foldable +-- +-- >>> pz @(Map' Pred Id) [1..5] +-- Val [0,1,2,3,4] +-- +data Map' p q deriving Show + +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 NoInline opts msg0 qq [] of + Left e -> pure e + Right q -> do + case chkSize opts msg0 (toList q) [hh qq] of + Left e -> pure e + Right xs -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalHide @p opts a) [0::Int ..] xs + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let vals = map (view _1) abcs + in mkNode opts (Val vals) (show3 opts msg0 vals q) (hh qq : map (hh . prefixNumberToTT) ts) + +-- | similar to 'map' +-- +-- >>> pz @(Map Pred) [1..5] +-- Val [0,1,2,3,4] +-- +data Map p deriving Show + +instance ( Show (PP p a) + , P p a + , x ~ [a] + , Show a + ) => P (Map p) x where + type PP (Map p) x = [PP p (ExtractAFromTA x)] + eval _ opts x = do + let msg0 = "Map" + case chkSize opts msg0 x [] of + Left e -> pure e + Right xs -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalHide @p opts a) [0::Int ..] xs + pure $ case splitAndAlign opts msg0 ts of + Left e -> e + Right abcs -> + let vals = map (view _1) abcs + in mkNode opts (Val vals) (show3 opts msg0 vals x) (map (hh . prefixNumberToTT) ts) + +-- | processes a type level list predicates running each in sequence with infixr: see 'Predicate.>>' +-- +-- >>> pz @(Do [Pred, ShowP Id, Id &&& Len]) 9876543 +-- Val ("9876542",7) +-- +-- >>> pz @(Do '[W 123, W "xyz", Len &&& Id, Pred *** Id<>Id]) () +-- Val (2,"xyzxyz") +-- +-- >>> pl @(Do '[Succ,Id,ShowP Id,Ones,Map (ReadBase Int 8)]) 1239 +-- Present [1,2,4,0] ((>>) [1,2,4,0] | {Map [1,2,4,0] | ["1","2","4","0"]}) +-- Val [1,2,4,0] +-- +-- >>> pl @(Do '[Pred,Id,ShowP Id,Ones,Map (ReadBase Int 8)]) 1239 +-- Error invalid base 8 (Map(i=3, a="8") excnt=1) +-- Fail "invalid base 8" +-- +-- >>> pl @(Do '[4,5,6]) () +-- Present 6 ((>>) 6 | {'6}) +-- Val 6 +-- +-- >>> pl @(Do '["abc", "Def", "ggg", "hhhhh"]) () +-- Present "hhhhh" ((>>) "hhhhh" | {'"hhhhh"}) +-- Val "hhhhh" +-- +-- >>> pl @(Do '[ 'LT, 'EQ, 'GT ]) () +-- Present GT ((>>) GT | {'GT}) +-- Val GT +-- +-- >>> pl @(Do '[4 % 4,22 % 1 ,12 -% 4]) () +-- Present (-3) % 1 ((>>) (-3) % 1 | {Negate (-3) % 1 | 3 % 1}) +-- Val ((-3) % 1) +-- +-- >>> pl @(Do '[1,2,3]) () +-- Present 3 ((>>) 3 | {'3}) +-- Val 3 +-- +data Do (ps :: [k]) deriving Show +-- infixr same as >> + +instance (P (DoExpandT ps) a) => P (Do ps) a where + type PP (Do ps) a = PP (DoExpandT ps) a + eval _ = eval (Proxy @(DoExpandT ps)) + +-- need both :: Type and (Id >> p or W) +type family DoExpandT (ps :: [k]) :: Type where -- need Type not k else No instance for GN.KnownNat: pl @(Do '[4,5,6]) () + DoExpandT '[] = GL.TypeError ('GL.Text "DoExpandT '[] invalid: requires at least one predicate in the list") + DoExpandT '[p] = W p -- need W or Id >> p else will fail with No instance for Show: pl @(Do '[4,5,6]) () + DoExpandT (p ': p1 ': ps) = p >> DoExpandT (p1 ': ps) + +-- | processes a type level list predicates running each in sequence with infixl: see 'Predicate.>>' +-- +-- >>> pz @(DoL [Pred, ShowP Id, Id &&& Len]) 9876543 +-- Val ("9876542",7) +-- +-- >>> pz @(DoL [2,3,4]) () +-- Val 4 +-- +-- >>> pl @(DoL '[4,5,6]) () +-- Present 6 ((>>) 6 | {'6}) +-- Val 6 +-- +data DoL (ps :: [k]) deriving Show +-- infixl unlike >> + +instance (P (DoExpandLT ps) a) => P (DoL ps) a where + type PP (DoL ps) a = PP (DoExpandLT ps) a + eval _ = eval (Proxy @(DoExpandLT ps)) + +type family DoExpandLT (ps :: [k]) :: Type where + DoExpandLT '[] = GL.TypeError ('GL.Text "DoExpandT '[] invalid: requires at least one predicate in the list") + DoExpandLT '[p] = W p + DoExpandLT (p ': p1 ': '[]) = p >> p1 + DoExpandLT (p ': p1 ': p2 ': ps) = (p >> p1) >> DoExpandLT (p2 ': ps) + +-- | similar to 'Prelude.&&' +-- +-- >>> pz @(Fst && Snd) (True, True) +-- Val True +-- +-- >>> pz @(Id > 15 && Id < 17) 16 +-- Val True +-- +-- >>> pz @(Id > 15 && Id < 17) 30 +-- Val False +-- +-- >>> pz @(Fst && (Length Snd >= 4)) (True,[11,12,13,14]) +-- Val True +-- +-- >>> pz @(Fst && (Length Snd == 4)) (True,[12,11,12,13,14]) +-- Val False +-- +data p && q deriving Show +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 NoInline 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 <> nullIf " | " zz) [hh pp, hh qq] + +-- | short circuit version of boolean And +-- +-- >>> pl @(Id > 10 &&~ FailT _ "ss") 9 +-- False (False &&~ _ | (9 > 10)) +-- Val False +-- +-- >>> pl @(Id > 10 &&~ Id == 12) 11 +-- False (True &&~ False | (11 == 12)) +-- Val False +-- +-- >>> pl @(Id > 10 &&~ Id == 11) 11 +-- True (True &&~ True) +-- Val True +-- +data p &&~ q deriving Show +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 <- evalBool (Proxy @p) opts a + case getValueLR NoInline 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 <- evalBool (Proxy @q) opts a + pure $ case getValueLR NoInline 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 || (Length Snd >= 4)) (False,[11,12,13,14]) +-- Val True +-- +-- >>> pz @(Not Fst || (Length Snd == 4)) (True,[12,11,12,13,14]) +-- Val False +-- +data p || q deriving Show +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 NoInline 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)) +-- Val True +-- +-- >>> pz @(Id > 10 ||~ Id == 9) 9 +-- Val True +-- +-- >>> pl @(Id > 10 ||~ Id > 9) 9 +-- False (False ||~ False | (9 > 10) ||~ (9 > 9)) +-- Val False +-- +data p ||~ q deriving Show +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 <- evalBool (Proxy @p) opts a + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right False -> do + qq <- evalBool (Proxy @q) opts a + pure $ case getValueLR NoInline 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] + +-- | boolean implication +-- +-- >>> pz @(Fst ~> (Length Snd >= 4)) (True,[11,12,13,14]) +-- Val True +-- +-- >>> pz @(Fst ~> (Length Snd == 4)) (True,[12,11,12,13,14]) +-- Val False +-- +-- >>> pz @(Fst ~> (Length Snd == 4)) (False,[12,11,12,13,14]) +-- Val True +-- +-- >>> pz @(Fst ~> (Length Snd >= 4)) (False,[11,12,13,14]) +-- Val True +-- +data p ~> q deriving Show +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 NoInline 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 <> nullIf " | " zz) [hh pp, hh qq] + + +-- | swaps using 'SwapC' +-- +-- >>> pz @Swap (Left 123) +-- Val (Right 123) +-- +-- >>> pz @Swap (Right 123) +-- Val (Left 123) +-- +-- >>> pz @Swap (These 'x' 123) +-- Val (These 123 'x') +-- +-- >>> pz @Swap (This 'x') +-- Val (That 'x') +-- +-- >>> pz @Swap (That 123) +-- Val (This 123) +-- +-- >>> pz @Swap (123,'x') +-- Val ('x',123) +-- +-- >>> pz @Swap (Left "abc") +-- Val (Right "abc") +-- +-- >>> pz @Swap (Right 123) +-- Val (Left 123) +-- +-- >>> pl @Swap (Right "asfd") +-- Present Left "asfd" (Swap Left "asfd" | Right "asfd") +-- Val (Left "asfd") +-- +-- >>> pl @Swap (12,"asfd") +-- Present ("asfd",12) (Swap ("asfd",12) | (12,"asfd")) +-- Val ("asfd",12) +-- +-- >>> pz @Swap (True,12,"asfd") +-- Val (True,"asfd",12) +-- +data Swap deriving Show + +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 (Val d) (show3 opts msg0 d pabx) [] + +-- | like 'GHC.Base.$' for expressions taking exactly on argument +-- ie this doesnt work: pz @('(,) $ 4 $ 'True) () +-- +-- >>> pl @(L1 $ L2 $ Id) ((1,2),(3,4)) +-- Present 3 (Fst 3 | (3,4)) +-- Val 3 +-- +-- >>> pl @((<=) 4 $ L1 $ L2 $ Id) ((1,2),(3,4)) +-- False (4 <= 3) +-- Val False +-- +-- >>> pz @('(,) 4 $ 'True) () +-- Val (4,True) +-- +data (p :: k -> k1) $ (q :: k) deriving Show +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.&' for expressions taking exactly on argument +-- +-- >>> pl @(Id & L1 & Singleton & Length) (13,"xyzw") +-- Present 1 (Length 1 | [13]) +-- Val 1 +-- +-- >>> pl @(2 & (&&&) "abc") () +-- Present ("abc",2) ('("abc",2)) +-- Val ("abc",2) +-- +-- >>> pl @(2 & '(,) "abc") () +-- Present ("abc",2) ('("abc",2)) +-- Val ("abc",2) +-- +-- >>> pl @('(,) 4 $ '(,) 7 $ "aa") () +-- Present (4,(7,"aa")) ('(4,(7,"aa"))) +-- Val (4,(7,"aa")) +-- +-- >>> pl @(L3 $ L2 $ Fst) ((1,("X",9,'a')),(3,4)) +-- Present 'a' (Thd 'a' | ("X",9,'a')) +-- Val 'a' +-- +data (q :: k) & (p :: k -> k1) deriving Show +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)) + +-- | similar to 'pure' +-- +-- >>> pz @(Pure Maybe Id) 4 +-- Val (Just 4) +-- +-- >>> pz @(Pure [] Id) 4 +-- Val [4] +-- +-- >>> pz @(Pure (Either String) Fst) (13,True) +-- Val (Right 13) +-- +-- >>> pl @(Pure Maybe Id) 'x' +-- Present Just 'x' (Pure Just 'x' | 'x') +-- Val (Just 'x') +-- +-- >>> pl @(Pure (Either _) Id) 'x' +-- Present Right 'x' (Pure Right 'x' | 'x') +-- Val (Right 'x') +-- +-- >>> pl @(Pure (Either _) Id >> Swap) 'x' +-- Present Left 'x' ((>>) Left 'x' | {Swap Left 'x' | Right 'x'}) +-- Val (Left 'x') +-- +-- >>> pl @(Pure (Either ()) Id >> Swap) 'x' +-- Present Left 'x' ((>>) Left 'x' | {Swap Left 'x' | Right 'x'}) +-- Val (Left 'x') +-- +-- >>> pl @(Pure (Either String) Id >> Swap) 123 +-- Present Left 123 ((>>) Left 123 | {Swap Left 123 | Right 123}) +-- Val (Left 123) +-- +data Pure (t :: Type -> Type) p deriving Show +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 NoInline opts msg0 pp [] of + Left e -> e + Right a -> + let b = pure a + in mkNode opts (Val b) (show3 opts msg0 b a) [hh pp] + +-- | similar to 'Data.Coerce.coerce' +-- +-- >>> pz @(Coerce (SG.Sum Integer)) (Identity (-13)) +-- Val (Sum {getSum = -13}) +-- +-- >>> pl @(Coerce SG.Any) True +-- Present Any {getAny = True} (Coerce Any {getAny = True} | True) +-- Val (Any {getAny = True}) +-- +-- >>> pl @(Coerce Bool) (SG.Any True) +-- Present True (Coerce True | Any {getAny = True}) +-- Val True +-- +-- >>> pz @(Proxy 'True >> Coerce (Proxy 'False)) () ^!? acts . _Val . to typeRep +-- Just 'False +-- +-- >>> pz @(Proxy Int >> Coerce (Proxy (String,Char))) () ^!? acts . _Val . to typeRep +-- Just ([Char],Char) +-- +-- >>> import qualified GHC.Exts as GE +-- >>> pz @(Proxy GE.Any >> Coerce (Proxy Int)) () ^!? acts . _Val . to typeRep +-- Just Int +-- +-- >>> pz @(Proxy '(_,_) >> Coerce (Proxy '(Float,Int))) () ^!? acts . _Val . to typeRep +-- Just ('(,) * * Float Int) +-- +data Coerce (t :: k) deriving Show -- has to be the same kind: Type to Type or Bool to Bool ... + +instance ( Coercible t a + , Show a + , Show t + ) => P (Coerce t) a where + type PP (Coerce t) a = t + eval _ opts a = + let msg0 = "Coerce" + d = a ^. coerced + in pure $ mkNode opts (Val d) (show3 opts msg0 d a) [] + +{- + -- | extracts the value level representation of the promoted 'DayOfWeek' + -- + -- >>> pz @'Monday () + -- Val Monday + -- + -- >>> pz @'Sunday () + -- Val Sunday + -- +instance GetWeekDay dy => P (dy :: DayOfWeek) a where + type PP dy a = DayOfWeek + eval _ opts _ = + let dy = getWeekDay @dy + msg = "'" <> showL opts dy + in pure $ mkNode opts (Val dy) msg [] + +-- | get weekday from the typelevel +class GetWeekDay (dy :: DayOfWeek) where + getWeekDay :: DayOfWeek +instance GetWeekDay 'Sunday where + getWeekDay = Sunday +instance GetWeekDay 'Monday where + getWeekDay = Monday +instance GetWeekDay 'Tuesday where + getWeekDay = Tuesday +instance GetWeekDay 'Wednesday where + getWeekDay = Wednesday +instance GetWeekDay 'Thursday where + getWeekDay = Thursday +instance GetWeekDay 'Friday where + getWeekDay = Friday +instance GetWeekDay 'Saturday where + getWeekDay = Saturday +-} + +-- | first element in a tuple followed by the first element +-- +-- >>> pz @L11 ((10,"ss"),2) +-- Val 10 +-- +data L11 deriving Show +type L11T = MsgI "L11:" (L1 (L1 Id)) + +instance P L11T x => P L11 x where + type PP L11 x = PP L11T x + eval _ = eval (Proxy @L11T) + +-- | first element in a tuple followed by the second element +-- +-- >>> pz @L12 ((10,"ss"),2) +-- Val "ss" +-- +data L12 deriving Show +type L12T = MsgI "L12:" (L2 (L1 Id)) + +instance P L12T x => P L12 x where + type PP L12 x = PP L12T x + eval _ = eval (Proxy @L12T) + +-- | first element in a tuple followed by the third element +-- +-- >>> pz @L13 ((10,"ss",4.5),2) +-- Val 4.5 +-- +data L13 deriving Show +type L13T = MsgI "L13:" (L3 (L1 Id)) + +instance P L13T x => P L13 x where + type PP L13 x = PP L13T x + eval _ = eval (Proxy @L13T) + +-- | second element in a tuple followed by the first element +-- +-- >>> pz @L21 ('x',(10,"ss",4.5),2) +-- Val 10 +-- +data L21 deriving Show +type L21T = MsgI "L21:" (L1 (L2 Id)) + +instance P L21T x => P L21 x where + type PP L21 x = PP L21T x + eval _ = eval (Proxy @L21T) + +-- | second element in a tuple followed by the second element +-- +-- >>> pz @L22 ('z',(10,"ss",4.5),2) +-- Val "ss" +-- +data L22 deriving Show +type L22T = MsgI "L22:" (L2 (L2 Id)) + +instance P L22T x => P L22 x where + type PP L22 x = PP L22T x + eval _ = eval (Proxy @L22T) + +-- | second element in a tuple followed by the third element +-- +-- >>> pz @L23 ('x',(10,"ss",4.5),2) +-- Val 4.5 +-- +data L23 deriving Show +type L23T = MsgI "L23:" (L3 (L2 Id)) + +instance P L23T x => P L23 x where + type PP L23 x = PP L23T x + eval _ = eval (Proxy @L23T) + +-- | third element in a tuple followed by the first element +-- +-- >>> pz @L31 (1,2,('c',4)) +-- Val 'c' +-- +data L31 deriving Show +type L31T = MsgI "L31:" (L1 (L3 Id)) + +instance P L31T x => P L31 x where + type PP L31 x = PP L31T x + eval _ = eval (Proxy @L31T) + +-- | third element in a tuple followed by the second element +-- +-- >>> pz @L32 (1,2,('c',4)) +-- Val 4 +-- +data L32 deriving Show +type L32T = MsgI "L32:" (L2 (L3 Id)) + +instance P L32T x => P L32 x where + type PP L32 x = PP L32T x + eval _ = eval (Proxy @L32T) + +-- | third element in a tuple followed by the third element +-- +-- >>> pz @L33 (1,2,('c',4,False)) +-- Val False +-- +data L33 deriving Show +type L33T = MsgI "L33:" (L3 (L3 Id)) + +instance P L33T x => P L33 x where + type PP L33 x = PP L33T x + eval _ = eval (Proxy @L33T)
+ src/Predicate/Data/Bits.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +-- | promoted bit manipulation functions +module Predicate.Data.Bits ( + type (.&.) + , type (.|.) + , type (.^.) + , BitShift + , BitShiftL + , BitShiftR + , BitRotate + , BitRotateL + , BitRotateR + , BitSet + , BitComplement + , BitClear + + , PopCount + , TestBit + , Bit + , ZeroBits + + ) where +import Predicate.Core +import Predicate.Util +import Data.Proxy (Proxy(Proxy)) +import qualified Data.Bits as Bits +import Data.Bits (Bits(..)) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XOverloadedStrings +-- >>> import Predicate.Prelude + +-- | bitwise @and@ similar to 'Data.Bits..&.' +-- +-- >>> pz @(344 .&. 123) () +-- Val 88 +-- +data p .&. q deriving Show +infixl 7 .&. + +instance ( P p a + , P q a + , Show (PP p a) + , PP p a ~ PP q a + , Bits (PP p a) + ) => P (p .&. q) a where + type PP (p .&. q) a = PP p a + eval _ opts a = do + let msg0 = "(.&.)" + lr <- runPQ NoInline 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] + d = p Bits..&. q + in mkNode opts (Val d) (showL opts p <> " .&. " <> showL opts q <> " = " <> showL opts d) hhs + + +-- | bitwise @or@ similar to 'Data.Bits..|.' +-- +-- >>> pz @(344 .|. 123) () +-- Val 379 +-- +-- >>> pz @(Fst .|. Snd) (124,33) +-- Val 125 +-- +data p .|. q deriving Show +infixl 5 .|. + +instance ( P p a + , P q a + , Show (PP p a) + , PP p a ~ PP q a + , Bits (PP p a) + ) => P (p .|. q) a where + type PP (p .|. q) a = PP p a + eval _ opts a = do + let msg0 = "(.|.)" + lr <- runPQ NoInline 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] + d = p Bits..|. q + in mkNode opts (Val d) (showL opts p <> " .|. " <> showL opts q <> " = " <> showL opts d) hhs + +-- | bitwise @xor@ similar to 'Data.Bits.xor' +-- +-- >>> pz @(344 .^. 123) () +-- Val 291 +-- +data p .^. q deriving Show +infixl 5 .^. + +instance ( P p a + , P q a + , Show (PP p a) + , PP p a ~ PP q a + , Bits (PP p a) + ) => P (p .^. q) a where + type PP (p .^. q) a = PP p a + eval _ opts a = do + let msg0 = "(.^.)" + lr <- runPQ NoInline 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] + d = p `Bits.xor` q + in mkNode opts (Val d) (showL opts p <> " .^. " <> showL opts q <> " = " <> showL opts d) hhs + +data BitFunction = + BFShift + | BFShiftL + | BFShiftR + | BFRotate + | BFRotateL + | BFRotateR + | BFSet + | BFClear + | BFComplement + deriving (Show,Eq) + +class BitFunctionC (fn :: BitFunction) where + bitFunction :: Bits a => (String, a -> Int -> a) +instance BitFunctionC 'BFShift where + bitFunction = ("shift", Bits.shift) +instance BitFunctionC 'BFShiftL where + bitFunction = ("shiftL", Bits.shiftL) +instance BitFunctionC 'BFShiftR where + bitFunction = ("shiftR", Bits.shiftR) +instance BitFunctionC 'BFRotate where + bitFunction = ("rotate", Bits.rotate) +instance BitFunctionC 'BFRotateL where + bitFunction = ("rotateL", Bits.rotateL) +instance BitFunctionC 'BFRotateR where + bitFunction = ("rotateR", Bits.rotateR) +instance BitFunctionC 'BFSet where + bitFunction = ("setBit", Bits.setBit) +instance BitFunctionC 'BFClear where + bitFunction = ("clearBit", Bits.clearBit) +instance BitFunctionC 'BFComplement where + bitFunction = ("complementBit", Bits.complementBit) + +-- flips the function where p is the integral +data BitImpl (fn :: BitFunction) p q deriving Show + +instance ( P p a + , P q a + , Show (PP q a) + , Bits (PP q a) + , Integral (PP p a) + , BitFunctionC fn + ) => P (BitImpl fn p q) a where + type PP (BitImpl fn p q) a = PP q a + eval _ opts a = do + let msg0 = ss + (ss,fn) = bitFunction @fn + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + d = fn q p + in mkNode opts (Val d) (ss <> " " <> showL opts p <> " " <> showL opts q <> " = " <> showL opts d) hhs + +-- | shift by @p@ using @q@: similar to flipped version of 'Data.Bits.shift' +-- +-- >>> pz @(BitShift 1 7) () +-- Val 14 +-- +-- >>> pz @(BitShift 1 Id) 123 +-- Val 246 +-- +data BitShift p q deriving Show +type BitShiftT p q = BitImpl 'BFShift p q + +instance P (BitShiftT p q) x => P (BitShift p q) x where + type PP (BitShift p q) x = PP (BitShiftT p q) x + eval _ = eval (Proxy @(BitShiftT p q)) + + +-- | shift left by @p@ using @q@: similar to flipped version of 'Data.Bits.shiftL' +-- +-- >>> pz @(BitShiftL 1 Id) 123 +-- Val 246 +-- +data BitShiftL p q deriving Show +type BitShiftLT p q = BitImpl 'BFShiftL p q + +instance P (BitShiftLT p q) x => P (BitShiftL p q) x where + type PP (BitShiftL p q) x = PP (BitShiftLT p q) x + eval _ = eval (Proxy @(BitShiftLT p q)) + +-- | shift right by @p@ using @q@: similar to flipped version of 'Data.Bits.shiftR' +-- +-- >>> pz @(BitShiftR 1 Id) 123 +-- Val 61 +-- +data BitShiftR p q deriving Show +type BitShiftRT p q = BitImpl 'BFShiftR p q + +instance P (BitShiftRT p q) x => P (BitShiftR p q) x where + type PP (BitShiftR p q) x = PP (BitShiftRT p q) x + eval _ = eval (Proxy @(BitShiftRT p q)) + +-- | rotate by @p@ using @q@: similar to flipped version of 'Data.Bits.rotate' +-- +-- >>> pz @(BitRotate 2 Id) 7 +-- Val 28 +-- +data BitRotate p q deriving Show +type BitRotateT p q = BitImpl 'BFRotate p q + +instance P (BitRotateT p q) x => P (BitRotate p q) x where + type PP (BitRotate p q) x = PP (BitRotateT p q) x + eval _ = eval (Proxy @(BitRotateT p q)) + +-- | rotate left by @p@ using @q@: similar to flipped version of 'Data.Bits.rotateL' +-- +-- >>> pz @(BitRotateL 2 Id) 7 +-- Val 28 +-- +data BitRotateL p q deriving Show +type BitRotateLT p q = BitImpl 'BFRotateL p q + +instance P (BitRotateLT p q) x => P (BitRotateL p q) x where + type PP (BitRotateL p q) x = PP (BitRotateLT p q) x + eval _ = eval (Proxy @(BitRotateLT p q)) + +-- | rotate right by @p@ using @q@: similar to flipped version of 'Data.Bits.rotateR' +-- +-- >>> pz @(BitRotateR 2 Id) 7 +-- Val 1 +-- + +data BitRotateR p q deriving Show +type BitRotateRT p q = BitImpl 'BFRotateR p q + +instance P (BitRotateRT p q) x => P (BitRotateR p q) x where + type PP (BitRotateR p q) x = PP (BitRotateRT p q) x + eval _ = eval (Proxy @(BitRotateRT p q)) + +-- | set the bit at @p@ using @q@: similar to flipped version of 'Data.Bits.setBit' +-- +-- >>> pz @(BitSet 0 Id) 8 +-- Val 9 +-- +data BitSet p q deriving Show +type BitSetT p q = BitImpl 'BFSet p q + +instance P (BitSetT p q) x => P (BitSet p q) x where + type PP (BitSet p q) x = PP (BitSetT p q) x + eval _ = eval (Proxy @(BitSetT p q)) + +-- | clear the bit at @p@ using @q@: similar to flipped version of 'Data.Bits.clearBit' +-- +-- >>> pz @(BitClear 2 Id) 7 +-- Val 3 +-- +data BitClear p q deriving Show +type BitClearT p q = BitImpl 'BFClear p q + +instance P (BitClearT p q) x => P (BitClear p q) x where + type PP (BitClear p q) x = PP (BitClearT p q) x + eval _ = eval (Proxy @(BitClearT p q)) + +-- | complement the bit at @p@ using @q@: similar to flipped version of 'Data.Bits.complementBit' +-- +-- >>> pz @(BitComplement 1 Id) 7 +-- Val 5 +-- +data BitComplement p q deriving Show +type BitComplementT p q = BitImpl 'BFComplement p q + +instance P (BitComplementT p q) x => P (BitComplement p q) x where + type PP (BitComplement p q) x = PP (BitComplementT p q) x + eval _ = eval (Proxy @(BitComplementT p q)) + +-- | test the bit at @p@ using @q@: similar to flipped version of 'Data.Bits.testBit' +-- +-- >>> pz @(TestBit 2 Id) 7 +-- Val True +-- +-- >>> pz @(TestBit 2 Id) 8 +-- Val False +-- +data TestBit p q deriving Show + +instance ( P p a + , P q a + , Show (PP q a) + , Bits (PP q a) + , Integral (PP p a) + ) => P (TestBit p q) a where + type PP (TestBit p q) a = Bool + eval _ opts a = do + let msg0 = "TestBit" + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + d = Bits.testBit q p + in mkNode opts (Val d) (msg0 <> " " <> showL opts p <> " " <> showL opts q <> " = " <> showL opts d) hhs + + +-- | count number of bits at @p@: similar to 'Data.Bits.popCount' +-- +-- >>> pz @(PopCount Id) 7 +-- Val 3 +-- +-- >>> pz @(PopCount Id) 8 +-- Val 1 +-- +-- >>> pz @(PopCount Id) (-7) +-- Val (-3) +-- +data PopCount p deriving Show + +instance ( P p a + , Show (PP p a) + , Bits (PP p a) + ) => P (PopCount p) a where + type PP (PopCount p) a = Int + eval _ opts a = do + let msg0 = "PopCount" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = Bits.popCount p + in mkNode opts (Val d) (msg0 <> " " <> showL opts p <> " = " <> showL opts d) [hh pp] + +-- | create a 'Data.Bits.Bits' for type @t with the bit at @p@ and all the others set to zero: similar to 'Data.Bits.bit' +-- +-- >>> pz @(Bit Int Id) 0 +-- Val 1 +-- +-- >>> pz @(Bit Int Id) 3 +-- Val 8 +-- +data Bit t p deriving Show + +instance ( P p a + , Show t + , Bits t + , Integral (PP p a) + ) => P (Bit t p) a where + type PP (Bit t p) a = t + eval _ opts a = do + let msg0 = "Bit" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right (fromIntegral -> p) -> + let d = Bits.bit @t p + in mkNode opts (Val d) (msg0 <> " " <> showL opts p <> " = " <> showL opts d) [hh pp] + + +-- | create a 'Data.Bits.Bits' for type @t with all bits set to zero: similar to 'Data.Bits.zeroBits' +-- +-- >>> pz @(ZeroBits Int) () +-- Val 0 +-- +data ZeroBits t deriving Show + +instance ( Show t + , Bits t + ) => P (ZeroBits t) a where + type PP (ZeroBits t) a = t + eval _ opts _ = pure $ + let msg0 = "ZeroBits" + d = Bits.zeroBits @t + in mkNode opts (Val d) (msg0 <> " " <> " = " <> showL opts d) []
src/Predicate/Data/Char.hs view
@@ -1,8 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -18,14 +13,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted character functions --} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +-- | promoted character functions module Predicate.Data.Char ( -- ** constructor Char1 + , C -- ** character predicates , IsLower @@ -56,45 +51,60 @@ , ToLower ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Control.Lens hiding (iall) +import Control.Lens import qualified Data.Text.Lens as DTL import GHC.TypeLits (Symbol, KnownSymbol) import qualified GHC.TypeLits as GL -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import Data.Char +import qualified Data.Type.Equality as DE -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Text as T -- >>> import Predicate.Prelude -- | extracts the first character from a non empty 'GHC.TypeLits.Symbol' -- -- >>> pz @(Char1 "aBc") () --- PresentT 'a' +-- Val 'a' -- -data Char1 (s :: Symbol) -- gets the first char from the Symbol [requires that Symbol is not empty] +data Char1 (s :: Symbol) deriving Show instance ( KnownSymbol s - , GL.CmpSymbol s "" ~ 'GT + , FailUnlessT (GL.CmpSymbol s "" DE.== 'GT) + ('GL.Text "Char1 symbol cannot be empty") ) => 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) [] + c:_ -> pure $ mkNode opts (Val c) ("Char1 " <> showL opts c) [] +-- | extracts the first character from a non empty 'GHC.TypeLits.Symbol': shorthand for 'Char1' +-- +-- >>> pz @(C "aBc") () +-- Val 'a' +-- +data C (s :: Symbol) deriving Show +type CT s = Char1 s + +instance P (CT s) x => P (C s) x where + type PP (C s) x = PP (CT s) x + eval _ = eval (Proxy @(CT s)) + + -- | a predicate for determining if a character belongs to the given character set -- --- >>> 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)] +-- >>> pz @(Map '(IsControl, IsLatin1, IsHexDigit, IsOctDigit, IsDigit, IsPunctuation, IsSeparator, IsSpace)) "abc134" +-- Val [(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 IsCharSet (cs :: CharSet) +data IsCharSet (cs :: CharSet) deriving Show instance ( x ~ Char , GetCharSet cs @@ -104,21 +114,20 @@ let msg0 = "Is" ++ drop 1 (show cs) (cs,f) = getCharSet @cs b = f c - in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " [c]) [] + in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " ([c] :: String)) [] -- | predicate similar to 'Data.Char.isLower' -- -- >>> pz @IsLower 'X' --- FalseT +-- Val False -- -- >>> pz @IsLower '1' --- FalseT +-- Val False -- -- >>> pz @IsLower 'a' --- TrueT +-- Val True -- - -data IsLower +data IsLower deriving Show type IsLowerT = IsCharSet 'CLower instance P IsLowerT x => P IsLower x where @@ -127,7 +136,7 @@ -- | predicate similar to 'Data.Char.isUpper' -- -data IsUpper +data IsUpper deriving Show type IsUpperT = IsCharSet 'CUpper instance P IsUpperT x => P IsUpper x where @@ -137,12 +146,12 @@ -- | predicate similar to 'Data.Char.isDigit' -- -- >>> pz @IsDigit 'g' --- FalseT +-- Val False -- -- >>> pz @IsDigit '9' --- TrueT +-- Val True -- -data IsDigit +data IsDigit deriving Show type IsDigitT = IsCharSet 'CNumber instance P IsDigitT x => P IsDigit x where type PP IsDigit x = Bool @@ -151,15 +160,15 @@ -- | predicate similar to 'Data.Char.isSpace' -- -- >>> pz @IsSpace '\t' --- TrueT +-- Val True -- -- >>> pz @IsSpace ' ' --- TrueT +-- Val True -- -- >>> pz @IsSpace 'x' --- FalseT +-- Val False -- -data IsSpace +data IsSpace deriving Show type IsSpaceT = IsCharSet 'CSpace instance P IsSpaceT x => P IsSpace x where type PP IsSpace x = Bool @@ -167,7 +176,7 @@ -- | predicate similar to 'Data.Char.isPunctuation' -- -data IsPunctuation +data IsPunctuation deriving Show type IsPunctuationT = IsCharSet 'CPunctuation instance P IsPunctuationT x => P IsPunctuation x where type PP IsPunctuation x = Bool @@ -175,7 +184,7 @@ -- | predicate similar to 'Data.Char.isControl' -- -data IsControl +data IsControl deriving Show type IsControlT = IsCharSet 'CControl instance P IsControlT x => P IsControl x where type PP IsControl x = Bool @@ -184,12 +193,12 @@ -- | predicate similar to 'Data.Char.isHexDigit' -- -- >>> pz @IsHexDigit 'A' --- TrueT +-- Val True -- -- >>> pz @IsHexDigit 'g' --- FalseT +-- Val False -- -data IsHexDigit +data IsHexDigit deriving Show type IsHexDigitT = IsCharSet 'CHexDigit instance P IsHexDigitT x => P IsHexDigit x where type PP IsHexDigit x = Bool @@ -197,7 +206,7 @@ -- | predicate similar to 'Data.Char.isOctDigit' -- -data IsOctDigit +data IsOctDigit deriving Show type IsOctDigitT = IsCharSet 'COctDigit instance P IsOctDigitT x => P IsOctDigit x where type PP IsOctDigit x = Bool @@ -205,7 +214,7 @@ -- | predicate similar to 'Data.Char.isSeparator' -- -data IsSeparator +data IsSeparator deriving Show type IsSeparatorT = IsCharSet 'CSeparator instance P IsSeparatorT x => P IsSeparator x where type PP IsSeparator x = Bool @@ -213,7 +222,7 @@ -- | predicate similar to 'Data.Char.isLatin1' -- -data IsLatin1 +data IsLatin1 deriving Show type IsLatin1T = IsCharSet 'CLatin1 instance P IsLatin1T x => P IsLatin1 x where type PP IsLatin1 x = Bool @@ -224,45 +233,45 @@ -- -- >>> pl @('Just Uncons >> IsUpper &* IsLowerAll) "AbcdE" -- False ((>>) False | {True (&*) False | (IsLowerAll | "bcdE")}) --- FalseT +-- Val False -- -- >>> pl @('Just Uncons >> IsUpper &* IsLowerAll) "Abcde" -- True ((>>) True | {True (&*) True}) --- TrueT +-- Val True -- -- >>> pl @('Just Uncons >> IsUpper &* IsLowerAll) "xbcde" -- False ((>>) False | {False (&*) True | (IsUpper | "x")}) --- FalseT +-- Val False -- -- >>> pl @('Just Uncons >> IsUpper &* IsLowerAll) "X" -- True ((>>) True | {True (&*) True}) --- TrueT +-- Val True -- -- >>> pz @( '(IsControlAll, IsLatin1All , IsHexDigitAll , IsOctDigitAll , IsDigitAll , IsPunctuationAll , IsSeparatorAll , IsSpaceAll)) "abc134" --- PresentT (False,True,True,False,False,False,False,False) +-- Val (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] +-- Val [True,False,False] -- -- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll]) "a98efghi" --- False ((>>) False | {Bool(2) [] (IsUpperAll | "efghi")}) --- FalseT +-- Error Bool(2) [] (IsUpperAll | "efghi") (["a","98","efghi"]) +-- Fail "Bool(2) [] (IsUpperAll | \"efghi\")" -- -- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll]) "a98efghi" -- True ((>>) True | {Bools}) --- TrueT +-- Val True -- -- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsDigitAll, IsUpperAll || IsLowerAll]) "a98efgHi" --- False ((>>) False | {Bool(2) [] (False || False | (IsUpperAll | "efgHi") || (IsLowerAll | "efgHi"))}) --- FalseT +-- Error Bool(2) [] (False || False | (IsUpperAll | "efgHi") || (IsLowerAll | "efgHi")) (["a","98","efgHi"]) +-- Fail "Bool(2) [] (False || False | (IsUpperAll | \"efgHi\") || (IsLowerAll | \"efgHi\"))" -- -data IsCharSetAll (cs :: CharSet) +data IsCharSetAll (cs :: CharSet) deriving Show -instance (GetCharSet cs - , Show a - , DTL.IsText a - ) => P (IsCharSetAll cs) a where +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 @@ -280,7 +289,7 @@ | COctDigit | CSeparator | CLatin1 - deriving Show + deriving stock (Bounded, Enum, Show, Read, Ord, Eq) class GetCharSet (cs :: CharSet) where getCharSet :: (CharSet, Char -> Bool) @@ -308,28 +317,29 @@ -- | predicate for determining if a string is all lowercase -- -- >>> pz @IsLowerAll "abc" --- TrueT +-- Val True -- -- >>> pz @IsLowerAll "abcX" --- FalseT +-- Val False -- -- >>> pz @IsLowerAll (T.pack "abcX") --- FalseT +-- Val False -- -- >>> pz @IsLowerAll "abcdef213" --- FalseT +-- Val False -- -- >>> pz @IsLowerAll "" --- TrueT +-- Val True -- -data IsLowerAll +data IsLowerAll deriving Show 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 +-- | predicate for determining if a string is all uppercase +data IsUpperAll deriving Show type IsUpperAllT = IsCharSetAll 'CUpper instance P IsUpperAllT x => P IsUpperAll x where @@ -339,12 +349,12 @@ -- | predicate for determining if the string is all digits -- -- >>> pz @IsDigitAll "213G" --- FalseT +-- Val False -- -- >>> pz @IsDigitAll "929" --- TrueT +-- Val True -- -data IsDigitAll +data IsDigitAll deriving Show type IsDigitAllT = IsCharSetAll 'CNumber instance P IsDigitAllT x => P IsDigitAll x where type PP IsDigitAll x = Bool @@ -353,27 +363,29 @@ -- | predicate for determining if the string is all spaces -- -- >>> pz @IsSpaceAll "213G" --- FalseT +-- Val False -- -- >>> pz @IsSpaceAll " " --- TrueT +-- Val True -- -- >>> pz @IsSpaceAll "" --- TrueT +-- Val True -- -data IsSpaceAll +data IsSpaceAll deriving Show type IsSpaceAllT = IsCharSetAll 'CSpace instance P IsSpaceAllT x => P IsSpaceAll x where type PP IsSpaceAll x = Bool eval _ = evalBool (Proxy @IsSpaceAllT) -data IsPunctuationAll +-- | predicate for determining if a string has all punctuation +data IsPunctuationAll deriving Show type IsPunctuationAllT = IsCharSetAll 'CPunctuation instance P IsPunctuationAllT x => P IsPunctuationAll x where type PP IsPunctuationAll x = Bool eval _ = evalBool (Proxy @IsPunctuationAllT) -data IsControlAll +-- | predicate for determining if a string has all control chars +data IsControlAll deriving Show type IsControlAllT = IsCharSetAll 'CControl instance P IsControlAllT x => P IsControlAll x where type PP IsControlAll x = Bool @@ -382,30 +394,33 @@ -- | predicate for determining if the string is all hex digits -- -- >>> pz @IsHexDigitAll "01efA" --- TrueT +-- Val True -- -- >>> pz @IsHexDigitAll "01egfA" --- FalseT +-- Val False -- -data IsHexDigitAll +data IsHexDigitAll deriving Show type IsHexDigitAllT = IsCharSetAll 'CHexDigit instance P IsHexDigitAllT x => P IsHexDigitAll x where type PP IsHexDigitAll x = Bool eval _ = evalBool (Proxy @IsHexDigitAllT) -data IsOctDigitAll +-- | predicate for determining if the string is all octal digits +data IsOctDigitAll deriving Show type IsOctDigitAllT = IsCharSetAll 'COctDigit instance P IsOctDigitAllT x => P IsOctDigitAll x where type PP IsOctDigitAll x = Bool eval _ = evalBool (Proxy @IsOctDigitAllT) -data IsSeparatorAll +-- | predicate for determining if the string has all separators +data IsSeparatorAll deriving Show type IsSeparatorAllT = IsCharSetAll 'CSeparator instance P IsSeparatorAllT x => P IsSeparatorAll x where type PP IsSeparatorAll x = Bool eval _ = evalBool (Proxy @IsSeparatorAllT) -data IsLatin1All +-- | predicate for determining if the string is all latin chars +data IsLatin1All deriving Show type IsLatin1AllT = IsCharSetAll 'CLatin1 instance P IsLatin1AllT x => P IsLatin1All x where type PP IsLatin1All x = Bool @@ -415,9 +430,9 @@ -- | converts a string 'Data.Text.Lens.IsText' value to lower case -- -- >>> pz @ToLower "HeLlO wOrld!" --- PresentT "hello world!" +-- Val "hello world!" -- -data ToLower +data ToLower deriving Show instance ( Show a , DTL.IsText a @@ -426,14 +441,14 @@ eval _ opts as = let msg0 = "ToLower" xs = as & DTL.text %~ toLower - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + in pure $ mkNode opts (Val xs) (show3 opts msg0 xs as) [] -- | converts a string 'Data.Text.Lens.IsText' value to upper case -- -- >>> pz @ToUpper "HeLlO wOrld!" --- PresentT "HELLO WORLD!" +-- Val "HELLO WORLD!" -- -data ToUpper +data ToUpper deriving Show instance ( Show a , DTL.IsText a @@ -442,19 +457,19 @@ eval _ opts as = let msg0 = "ToUpper" xs = as & DTL.text %~ toUpper - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + in pure $ mkNode opts (Val xs) (show3 opts msg0 xs as) [] -- | converts a string 'Data.Text.Lens.IsText' value to title case -- -- >>> pz @ToTitle "HeLlO wOrld!" --- PresentT "Hello world!" +-- Val "Hello world!" -- -- >>> data Color = Red | White | Blue | Green | Black deriving (Show,Eq,Enum,Bounded,Read) -- >>> pz @(ToTitle >> ReadP Color Id) "red" --- PresentT Red +-- Val Red -- -data ToTitle +data ToTitle deriving Show instance ( Show a , DTL.IsText a @@ -463,7 +478,7 @@ eval _ opts as = let msg0 = "ToTitle" xs = toTitleAll (as ^. DTL.unpacked) ^. DTL.packed - in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) [] + in pure $ mkNode opts (Val xs) (show3 opts msg0 xs as) [] toTitleAll :: String -> String
src/Predicate/Data/Condition.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,13 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted conditional functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted conditional functions module Predicate.Data.Condition ( - -- ** conditional expressions If , Case , Case' @@ -36,23 +27,23 @@ , GuardSimple , GuardsN , GuardsDetail - + , GuardBool , Bools , BoolsQuick , BoolsN - ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.ReadShow (PrintT) import GHC.TypeLits (Nat,KnownNat,ErrorMessage((:<>:))) import qualified GHC.TypeLits as GL -import Control.Lens hiding (iall) -import Data.Proxy +import Control.Lens +import Data.Proxy (Proxy(..)) import Data.Kind (Type) -import Data.Void +import Data.Void (Void) import qualified Data.Type.Equality as DE - +import Data.Bool (bool) -- $setup -- >>> import Predicate.Prelude -- >>> :set -XDataKinds @@ -60,76 +51,75 @@ -- >>> :set -XTypeOperators -- >>> :set -XAllowAmbiguousTypes -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> :set -XFlexibleContexts -- >>> import qualified Data.Text as T --- | similar to an if statement: if \'p\' then run \'q\' else run \'r\' +-- | similar to an if statement: 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" +-- Val "greater than 4" -- -- >>> pz @(If (Gt 4) "greater than 4" "less than or equal to 4") 0 --- PresentT "less than or equal to 4" +-- Val "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) +-- >>> pz @(If (Snd == "a") '("xxx",Fst + 13) (If (Snd == "b") '("yyy",Fst + 7) (FailT _ "oops"))) (99,"b") +-- Val ("yyy",106) -- --- >>> pl @(If (Len > 2) (Map (Succ Id) Id) (FailS "someval")) [12,15,16] --- Present [13,16,17] (If (true cond)) --- PresentT [13,16,17] +-- >>> pl @(If (Len > 2) (Map Succ) (FailS "someval")) [12,15,16] +-- Present [13,16,17] (If 'True [13,16,17]) +-- Val [13,16,17] -- --- >>> pl @(Map (If (Lt 3) 'True (Failt _ "err")) Id) [1..10] +-- >>> pl @(Map (If (Lt 3) 'True (FailT _ "err"))) [1..10] -- Error err(8) (Map(i=2, a=3) excnt=8) --- FailT "err(8)" +-- Fail "err(8)" -- --- >>> pl @(Map (If (Lt 3) 'True (Failt _ "someval")) Id) [1..10] +-- >>> pl @(Map (If (Lt 3) 'True (FailT _ "someval"))) [1..10] -- Error someval(8) (Map(i=2, a=3) excnt=8) --- FailT "someval(8)" +-- Fail "someval(8)" -- --- >>> pl @(Map (If (Lt 3) 'True 'False) Id) [1..5] +-- >>> pl @(Map (If (Lt 3) 'True 'False)) [1..5] -- Present [True,True,False,False,False] (Map [True,True,False,False,False] | [1,2,3,4,5]) --- PresentT [True,True,False,False,False] +-- Val [True,True,False,False,False] -- -- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) ()) 45 --- Error failing with 45 (If [True]) --- FailT "failing with 45" +-- Error failing with 45 (If True) +-- Fail "failing with 45" -- -- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) (Id * 7)) 3 --- Present 21 (If (false cond) 21) --- PresentT 21 +-- Present 21 (If 'False 21) +-- Val 21 -- --- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) (Id * 7 >> ShowP Id >> Ones Id)) 3 --- Present ["2","1"] (If (false cond) ["2","1"]) --- PresentT ["2","1"] +-- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) (Id * 7 >> ShowP Id >> Ones)) 3 +-- Present ["2","1"] (If 'False ["2","1"]) +-- Val ["2","1"] -- --- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) (ShowP (Id * 7) >> Ones Id)) 19 --- Error failing with 19 (If [True]) --- FailT "failing with 19" +-- >>> pl @(If (Gt 4) (Fail (Hole _) (PrintF "failing with %d" Id)) (ShowP (Id * 7) >> Ones)) 19 +-- Error failing with 19 (If True) +-- Fail "failing with 19" -- -data If p q r +data If p q r deriving Show -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 +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 + case getValueLR NoInline 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 + then eval (Proxy @q) opts a + else eval (Proxy @r) opts a + pure $ case getValueLR Inline 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] + Right ret -> mkNodeCopy opts qqrr (msg0 <> " " <> bool "'False" "'True" b <> " " <> showL opts ret) [hh pp, hh qqrr] type family GuardsT (ps :: [k]) where GuardsT '[] = '[] @@ -140,99 +130,99 @@ --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 '[] = GL.TypeError ('GL.Text "ToGuardsT cannot be empty") ToGuardsT prt '[p] = '(prt,p) : '[] ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps -- | 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) 50 +-- Val "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) 9 +-- Val "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) 3 +-- Val "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 (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 +-- Fail "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 (FailS "asdf" >> Snd >> UnproxyT) '[Lt 4,Lt 10,Same 50] '[PrintF "%d is lt4" Id, PrintF "%d is lt10" Id, PrintF "%d is same50" Id] Id) 99 +-- Fail "asdf" -- --- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "b" --- PresentT "there" +-- >>> pz @(Case (FailT _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "b" +-- Val "there" -- --- >>> pz @(Case (Failt _ "x") '[Id == "a",Id == "b"] '["hey","there"] Id) "a" --- PresentT "hey" +-- >>> pz @(Case (FailT _ "x") '[Id == "a",Id == "b"] '["hey","there"] Id) "a" +-- Val "hey" -- --- >>> pz @(Case (Failt _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "c" --- FailT "x" +-- >>> pz @(Case (FailT _ "x") '[Same "a",Same "b"] '["hey","there"] Id) "c" +-- Fail "x" -- -data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) deriving Show -- ps = conditions -- qs = what to do [one to one with ps] -- r = the value -- e = otherwise -- leave til later --- | tries to match the value \'r\' with a condition in \'ps\' and if there is a match calls the associated \'qs\' entry else run \'e\' +-- | tries to match the value @r@ with a condition in @ps@ and if there is a match calls the associated @qs@ entry else run @e@ -- --- >>> pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 15 --- Present "gt3" (Case(0 of 3) "gt3" | 15) --- PresentT "gt3" +-- >>> pl @(Case (Snd >> FailP "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 15 +-- Present "gt3" (Case(0 of 2) "gt3" | 15) +-- Val "gt3" -- --- >>> pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 1 +-- >>> pl @(Case (Snd >> FailP "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 1 -- Present "lt2" (Case(0) "lt2" | 1) --- PresentT "lt2" +-- Val "lt2" -- --- >>> pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 3 +-- >>> pl @(Case (Snd >> FailP "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 3 -- Present "eq3" (Case(0) "eq3" | 3) --- PresentT "eq3" +-- Val "eq3" -- --- >>> pl @(Case (Snd Id >> Failp "no match") '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 --- Error no match (Case(0) failed rhs) --- FailT "no match" +-- >>> pl @(Case (Snd >> FailP "no match") '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 +-- Error no match (Case:otherwise failed:Proxy) +-- Fail "no match" -- --- >>> pl @(Case (Fail (Snd Id >> Unproxy) (PrintF "no match for %03d" (Fst Id))) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 --- Error no match for 015 (Case(0) failed rhs) --- FailT "no match for 015" +-- >>> pl @(Case (Fail (Snd >> UnproxyT) (PrintF "no match for %03d" Fst)) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 +-- Error no match for 015 (Case:otherwise failed) +-- Fail "no match for 015" -- -- >>> pl @(Case "other" '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 -- Present "other" (Case(0) "other" | 15) --- PresentT "other" +-- Val "other" -- --- >>> pl @(Case (ShowP (Fst Id) >> Id <> Id <> Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 +-- >>> pl @(Case (ShowP Fst >> Id <> Id <> Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 -- Present "151515" (Case(0) "151515" | 15) --- PresentT "151515" +-- Val "151515" -- -data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) deriving Show --- | like 'Case' but uses a generic error message (skips the \'e\' parameter) +-- | like 'Case' but uses a generic error message (skips the @e@ parameter) -- -- >>> pl @(Case' '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 --- Error Case:no match (Case(0) failed rhs) --- FailT "Case:no match" +-- Error Case:no match (Case:otherwise failed:Proxy) +-- Fail "Case:no match" -- -data Case' (ps :: [k]) (qs :: [k1]) (r :: k2) +data Case' (ps :: [k]) (qs :: [k1]) (r :: k2) deriving Show -- | like 'Case' but allows you to use the value in the error message -- -- >>> pl @(Case'' (PrintF "no match for %03d" Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 --- Error no match for 015 (Case(0) failed rhs) --- FailT "no match for 015" +-- Error no match for 015 (Case:otherwise failed) +-- Fail "no match for 015" -- --- >>> pl @(Case'' (PrintF "no match for %03d" Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 --- Error no match for 015 (Case(0) failed rhs) --- FailT "no match for 015" +-- >>> pl @(Case'' (PrintF "no match for %03d" Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 2 +-- Present "eq2" (Case(0) "eq2" | 2) +-- Val "eq2" -- -- >>> pl @(Case'' (PrintF "no match for %04d" Id) '[Between 0 5 Id, Same 6, Between 7 10 Id] '[ 'LT, 'EQ, 'GT] Id) (-12) --- Error no match for -012 (Case(0) failed rhs) --- FailT "no match for -012" +-- Error no match for -012 (Case:otherwise failed) +-- Fail "no match for -012" -- -data Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) +data Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) deriving Show -type CaseT' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd Id >> Failp "Case:no match") ps qs r +type CaseT' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd >> 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 @@ -243,7 +233,7 @@ 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 FailCaseT p = Fail (Snd >> UnproxyT) (Fst >> p) type CaseImplT e ps qs r = CaseImpl (LenT ps) e ps qs r @@ -274,118 +264,114 @@ 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 +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 + let msgbase0 = "Case(" <> show (n-1) <> ")" + n = nat @n @Int rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of + case getValueLR NoInline 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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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 b -> mkNode opts (Val b) (show3 opts msgbase0 b a) (hh rr : hh pp : verboseList opts qq) 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 + pure $ case getValueLR NoInline opts ("Case:otherwise failed" <> nullIf ":" (_ttString ee)) 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] + Right b -> mkNode opts (Val b) (show3 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) - ) +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" + msgbase0 = "Case(" <> show cpos <> " of " <> show (n-1) <> ")" + msgbase1 = "Case(" <> show cpos <> ")" n = nat @n pos = 1 + getLen @ps -- cos p1! rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of + case getValueLR NoInline 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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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 b -> mkNode opts (Val b) (show3 opts msgbase0 b a) (hh rr : hh pp : verboseList opts qq) 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 + pure $ case getValueLR Inline opts "" 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] + Right b -> mkNode opts (Val b) (show3 opts msgbase1 b a) [hh rr, hh pp, hh ww] -data GuardsImpl (n :: Nat) (os :: [(k,k1)]) - --- isbn 10 tests (dont need first guard as Zip enforces same length: handles case insensitive \'x\' as check digit) - +data GuardsImpl (n :: Nat) (os :: [(k,k1)]) deriving Show -- | 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 +-- @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] +-- Val [17,4] -- -- >>> pz @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 5)]) [17,4] --- FailT "arg2 failed" +-- Fail "arg2 failed" -- -- >>> pz @(Guards '[ '("arg1 failed",Gt 99), '("arg2 failed", Same 4)]) [17,4] --- FailT "arg1 failed" +-- Fail "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" +-- Fail "1 3" -- --- >>> pz @(Msg "isbn10" (Resplit "-" Id) >> Concat Id >> 'Just Unsnoc >> Map (ReadP Int (Singleton Id)) Id *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) >> Zip (1...10 >> Reverse) (Fst Id +: Snd Id) >> Map (Fst Id * Snd Id) Id >> Sum >> Guard ("mod 0 oops") (Id `Mod` 11 == 0)) "0-306-40614-X" --- FailT "mod 0 oops" +-- >>> pz @(Msg "isbn10" (Resplit "-") >> Concat >> 'Just Unsnoc >> Map (ReadP Int (Singleton Id)) *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) >> ZipWith (Fst * Snd) (1...10 >> Reverse) (Fst +: Snd) >> Sum >> Guard ("mod 0 oops") (Id `Mod` 11 == 0)) "0-306-40614-X" +-- Fail "mod 0 oops" -- --- >>> pz @(Resplit "-" Id >> Concat Id >> 'Just Unsnoc >> Map (ReadP Int (Singleton Id)) Id *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) >> Zip (1...10 >> Reverse) (Fst Id +: Snd Id) >> Map (Fst Id * Snd Id) Id >> Sum >> Guard ("mod 0 oops") (Id `Mod` 11 == 0)) "0-306-40611-X" --- PresentT 132 +-- >>> pz @(Resplit "-" >> Concat >> 'Just Unsnoc >> Map (ReadP Int (Singleton Id)) *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) >> ZipWith (Fst * Snd) (1...10 >> Reverse) (Fst +: Snd) >> Sum >> Guard ("mod 0 oops") (Id `Mod` 11 == 0)) "0-306-40611-X" +-- Val 132 -- --- >>> pz @(Msg "isbn13" (Resplit "-" Id) >> Concat Id >> Map (ReadP Int (Singleton Id)) Id >> Zip (Cycle 13 [1,3] >> Reverse) Id >> Map (Fst Id * Snd Id) Id >> Sum >> '(Id,Id `Mod` 10) >> Guard (PrintT "sum=%d mod 10=%d" Id) (Snd Id == 0)) "978-0-306-40615-7" --- PresentT (100,0) +-- >>> pz @(Msg "isbn13" (Resplit "-") >> Concat >> Map (ReadP Int (Singleton Id)) >> ZipWith (Fst * Snd) (Cycle 13 [1,3] >> Reverse) Id >> Sum >> '(Id,Id `Mod` 10) >> Guard (PrintT "sum=%d mod 10=%d" Id) (Snd == 0)) "978-0-306-40615-7" +-- Val (100,0) -- --- >>> pz @(Resplit "-" Id >> Concat Id >> Map (ReadP Int (Singleton Id)) Id >> Zip (Cycle 13 [1,3] >> Reverse) Id >> Map (Fst Id * Snd Id) Id >> Sum >> '(Id,Id `Mod` 10) >> Guard (PrintT "sum=%d mod 10=%d" Id) (Snd Id == 0)) "978-0-306-40615-8" --- FailT "sum=101 mod 10=1" +-- >>> pz @(Resplit "-" >> Concat >> Map (ReadP Int (Singleton Id)) >> ZipWith (Fst * Snd) (Cycle 13 [1,3] >> Reverse) Id >> Sum >> '(Id,Id `Mod` 10) >> Guard (PrintT "sum=%d mod 10=%d" Id) (Snd == 0)) "978-0-306-40615-8" +-- Fail "sum=101 mod 10=1" -- --- >>> pz @(Do '[Resplit "-" Id, Concat Id, Zip (Cycle 13 [1,3]) (Map (ReadP Int (Singleton Id)) Id), Map (Fst Id * Snd Id) Id, Sum, Guard (PrintF "%d is not evenly divisible by 10" Id) (Id `Mod` 10 == 0)]) "978-0-7167-0344-9" --- FailT "109 is not evenly divisible by 10" +-- >>> pz @(Do '[Resplit "-", Concat, ZipWith (Fst * Snd) (Cycle 13 [1,3]) (Map (ReadP Int (Singleton Id))), Sum, Guard (PrintF "%d is not evenly divisible by 10" Id) (Id `Mod` 10 == 0)]) "978-0-7167-0344-9" +-- Fail "109 is not evenly divisible by 10" -- --- >>> pz @(Do '[Resplit "-" Id, Concat Id, Zip (Cycle 13 [1,3]) (Map (ReadP Int (Singleton Id)) Id), Map (Fst Id * Snd Id) Id, Sum, Guard (PrintF "%d is not evenly divisible by 10" Id) (Id `Mod` 10 == 0)]) "978-0-7167-0344-0" --- PresentT 100 +-- >>> pz @(Do '[Resplit "-", Concat, ZipWith (Fst * Snd) (Cycle 13 [1,3]) (Map (ReadP Int (Singleton Id))), Sum, Guard (PrintF "%d is not evenly divisible by 10" Id) (Id `Mod` 10 == 0)]) "978-0-7167-0344-0" +-- Val 100 -- -data Guards (ps :: [(k,k1)]) +data Guards (ps :: [(k,k1)]) deriving Show instance ( [a] ~ x , GetLen ps @@ -397,102 +383,103 @@ n = getLen @ps if n /= length as then let msg1 = msg0 <> badLength as n - in pure $ mkNode opts (FailT msg1) "" [] + in pure $ mkNode opts (Fail msg1) "" [] else eval (Proxy @(GuardsImpl (LenT ps) ps)) opts as instance ( [a] ~ x , Show a + , KnownNat n ) => 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 + eval _ _ as@(_:_) = errorInProgram $ "GuardsImpl base case has extra data " ++ show as + + eval _ opts [] = + let n = nat @n @Int + in pure $ mkNode opts (Val []) ("Guards(" ++ show n ++ ")") [] + + +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) x + , PP (GuardsImpl n ps) x ~ x + , 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 + + eval _ _ [] = errorInProgram "GuardsImpl n+1 case has no data" + + eval _ opts (a:as) = do let cpos = n-pos-1 msgbase1 = "Guard(" <> show cpos <> ")" msgbase2 = "Guards" - n :: Int - n = nat @n + n = nat @n @Int pos = getLen @ps - case as' of - a:as -> do - pp <- evalBoolHide @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" + pp <- evalBoolHide @p opts a + case getValueLR NoInline 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 NoInline opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (Fail msgx) (msgbase1 <> " " <> showL opts a) (hh pp : verboseList opts qq) + Right True -> do + ss <- eval (Proxy @(GuardsImpl n ps)) opts as + pure $ case getValueLR Inline opts "" 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 & ttForest %~ (hh pp:) + & ttVal .~ Val (a:zs) -- | GuardsQuick contain a type level list of conditions and one of matching values: on no match will fail using the first parameter -- -- >>> 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" +-- Fail "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" +-- Fail "Guards:invalid length(4) expected 3" -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 11 Id, Between 1 4 Id,Between 3 5 Id]) [10::Int,2,5] --- Present [10,2,5] (Guards) --- PresentT [10,2,5] +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 0 11 Id, Between 1 4 Id,Between 3 5 Id]) [10,2,5] +-- Present [10,2,5] (Guards(3)) +-- Val [10,2,5] -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11,1999::Int] --- Present [31,11,1999] (Guards) --- PresentT [31,11,1999] +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11,1999] +-- Present [31,11,1999] (Guards(3)) +-- Val [31,11,1999] -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11::Int] +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11] -- Error Guards:invalid length(2) expected 3 --- FailT "Guards:invalid length(2) expected 3" +-- Fail "Guards:invalid length(2) expected 3" -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,13,1999::Int] --- Error guard(1) 13 is out of range (Guard(0) ok | rhs failed) --- FailT "guard(1) 13 is out of range" +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,13,1999] +-- Error guard(1) 13 is out of range (Guard(1) 13) +-- Fail "guard(1) 13 is out of range" -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [0,44,1999::Int] --- Error guard(0) 0 is out of range (Guard(0) failed [guard(0) 0 is out of range] 0) --- FailT "guard(0) 0 is out of range" +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [0,44,1999] +-- Error guard(0) 0 is out of range (Guard(0) 0) +-- Fail "guard(0) 0 is out of range" -- --- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11,2000,1,2::Int] +-- >>> pl @(GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id]) [31,11,2000,1,2] -- Error Guards:invalid length(5) expected 3 --- FailT "Guards:invalid length(5) expected 3" +-- Fail "Guards:invalid length(5) expected 3" -- -- >>> pl @(GuardsQuick (PrintT "guard(%d) err %03d" Id) '[W 'True, Ge 12, W 'False, Lt 2]) [1,2,-99,-999] --- Error guard(1) err 002 (Guard(0) ok | rhs failed) --- FailT "guard(1) err 002" +-- Error guard(1) err 002 (Guard(1) 2) +-- Fail "guard(1) err 002" -- -- >>> pl @(GuardsQuick (PrintT "guard(%d) err %03d" Id) '[W 'True, Ge 12, W 'False, Lt 2]) [1,2,-99] -- Error Guards:invalid length(3) expected 4 --- FailT "Guards:invalid length(3) expected 4" +-- Fail "Guards:invalid length(3) expected 4" -- -- >>> pl @(GuardsQuick (PrintT "guard(%d) err %03d" Id) '[W 'True, Ge 12, W 'True, Lt 2]) [1,22,-99,-999,1,1,2] -- Error Guards:invalid length(7) expected 4 --- FailT "Guards:invalid length(7) expected 4" +-- Fail "Guards:invalid length(7) expected 4" -- -data GuardsQuick (prt :: k) (ps :: [k1]) +data GuardsQuick (prt :: k) (ps :: [k1]) deriving Show type GuardsQuickT (prt :: k) (ps :: [k1]) = Guards (ToGuardsT prt ps) instance P (GuardsQuickT prt ps) x => P (GuardsQuick prt ps) x where @@ -505,247 +492,204 @@ -- | boolean guard which checks a given a list of predicates against the list of values -- -- >>> 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 +-- Error Bool(1) [mm] (93 <= 59) +-- Fail "Bool(1) [mm] (93 <= 59)" -- -- >>> 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 +-- Error Bool(2) [<<<2 94>>>] (94 <= 59) +-- Fail "Bool(2) [<<<2 94>>>] (94 <= 59)" -- -- >>> 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 +-- Val True -- -- >>> pl @(Bools '[ '("hours",Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id)]) [12,13,14] -- True (Bools) --- TrueT +-- Val True -- -- >>> 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 +-- Error Bool(1) [minutes] (60 <= 59) +-- Fail "Bool(1) [minutes] (60 <= 59)" -- -- >>> 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 +-- Error Bools:invalid length(4) expected 3 +-- Fail "Bools:invalid length(4) expected 3" -- -data Bools (ps :: [(k,k1)]) +data Bools (ps :: [(k,k1)]) deriving Show -instance ([a] ~ x - , GetLen ps - , P (BoolsImpl (LenT ps) ps) x - , PP (BoolsImpl (LenT ps) ps) x ~ Bool - ) => P (Bools ps) x where +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++")" + msg1 = "Bool(" <> show (n-1) <> ")" n = getLen @ps case chkSize opts msg1 as [] of Left e -> pure e - Right () -> + Right _ -> if n /= length as then let msg2 = msg0 <> badLength as n - in pure $ mkNodeB opts False msg2 [] -- was FailT but now just FalseT + in pure $ mkNode opts (Fail msg2) "" [] else evalBool (Proxy @(BoolsImpl (LenT ps) ps)) opts as -data BoolsImpl (n :: Nat) (os :: [(k,k1)]) +data BoolsImpl (n :: Nat) (os :: [(k,k1)]) deriving Show -instance (KnownNat n - , Show a - , [a] ~ x - ) => P (BoolsImpl n ('[] :: [(k,k1)])) x where +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 + eval _ _ as@(_:_) = errorInProgram $ "BoolsImpl base case has extra data " ++ show as + + eval _ opts [] = + let msg0 = "Bool(" <> show (n-1) <> ")" + n = nat @n @Int + in 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) x ~ Bool + , [a] ~ x + ) => P (BoolsImpl n ('(prt,p) ': ps)) x where type PP (BoolsImpl n ('(prt,p) ': ps)) x = Bool - eval _ opts as' = do + + eval _ _ [] = errorInProgram "BoolsImpl n+1 case has no data" + + eval _ opts (a:as) = do let cpos = n-pos-1 - msgbase1 = "Bool(" <> showIndex cpos <> ")" + msgbase1 = "Bool(" <> show cpos <> ")" msgbase2 = "Bools" - n :: Int = nat @n + n = nat @n @Int pos = getLen @ps - case as' of - a:as -> do - pp <- evalBoolHide @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" + pp <- evalBoolHide @p opts a + case getValueLR NoInline 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 NoInline opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (Fail (msgbase1 <> " [" <> msgx <> "]" <> nullSpace (topMessage pp))) "" (hh pp : verboseList opts qq) + 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 Inline opts "" ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right _ -> ss & ttForest %~ (hh pp:) -data BoolsQuick (prt :: k) (ps :: [k1]) +-- | boolean guard which checks a given a list of predicates against the list of values +-- +-- >>> pl @(BoolsQuick "abc" '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,14] +-- True (Bools) +-- Val True +-- +-- >>> 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) +-- Val True +-- +-- >>> pl @(BoolsQuick (PrintT "id=%d val=%d" Id) '[Between 0 23 Id, Between 0 59 Id, Between 0 59 Id]) [12,13,99] +-- Error Bool(2) [id=2 val=99] (99 <= 59) +-- Fail "Bool(2) [id=2 val=99] (99 <= 59)" +-- +data BoolsQuick (prt :: k) (ps :: [k1]) deriving Show 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 +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 = Bool 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 (0 <..> 0xff)) [121,33,7,256] +-- Error Bool(3) [id=3 must be between 0 and 255, found 256] (256 <= 255) +-- Fail "Bool(3) [id=3 must be between 0 and 255, found 256] (256 <= 255)" -- --- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (Between 0 255 Id)) [121,33,7,44] +-- >>> pl @(BoolsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (0 <..> 0xff)) [121,33,7,44] -- True (Bools) --- TrueT +-- Val True -- -data BoolsN prt (n :: Nat) (p :: k1) +data BoolsN prt (n :: Nat) (p :: k1) deriving Show 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 + type PP (BoolsN prt n p) x = Bool 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" +-- Fail "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" +-- Fail "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] +-- Val [23,59,12] -- -data GuardsDetailImpl (ps :: [(k,k1)]) +data GuardsDetailImpl (ps :: [(k,k1)]) deriving Show -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 +instance ( [a] ~ x + , GetLen ps + , P (GuardsImpl (LenT ps) ps) x + ) => P (GuardsDetailImpl ps) x where + type PP (GuardsDetailImpl 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 @(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 @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" + in pure $ mkNode opts (Fail msg1) "" [] + else eval (Proxy @(GuardsImpl (LenT ps) ps)) opts as -data GuardsDetail prt (ps :: [(k0,k1)]) +data GuardsDetail prt (ps :: [(k0,k1)]) deriving Show 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 os where 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") + ToGuardsDetailT prt '[ '(s,p) ] = '(PrintT prt '(s,Snd), p) : '[] + ToGuardsDetailT prt ( '(s,p) ': ps) = '(PrintT prt '(s,Snd), 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 (0 <..> 0xff)) [121,33,7,256] +-- Fail "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] +-- >>> pz @(GuardsN (PrintT "id=%d must be between 0 and 255, found %d" Id) 4 (0 <..> 0xff)) [121,33,7,44] +-- Val [121,33,7,44] -- --- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (Between 0 255 Id)) [1,2,3,4::Int] --- Present [1,2,3,4] (Guards) --- PresentT [1,2,3,4] +-- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (0 <..> 0xff)) [1,2,3,4] +-- Present [1,2,3,4] (Guards(4)) +-- Val [1,2,3,4] -- --- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (Between 0 255 Id)) [1,2,3,4,5::Int] +-- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (0 <..> 0xff)) [1,2,3,4,5] -- Error Guards:invalid length(5) expected 4 --- FailT "Guards:invalid length(5) expected 4" +-- Fail "Guards:invalid length(5) expected 4" -- --- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (Between 0 255 Id)) [1,2,3::Int] +-- >>> pl @(GuardsN (PrintT "guard(%d) %d is out of range" Id) 4 (0 <..> 0xff)) [1,2,3] -- Error Guards:invalid length(3) expected 4 --- FailT "Guards:invalid length(3) expected 4" +-- Fail "Guards:invalid length(3) expected 4" -- -data GuardsN prt (n :: Nat) p +data GuardsN prt (n :: Nat) p deriving Show type GuardsNT prt (n :: Nat) p = Guards (ToGuardsT prt (RepeatT n p)) instance ( x ~ [a] @@ -754,115 +698,140 @@ 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\' +-- | @p@ is the predicate and on failure of the predicate runs @prt@ -- -- >>> pz @(Guard "expected > 3" (Gt 3)) 17 --- PresentT 17 +-- Val 17 -- -- >>> pz @(Guard "expected > 3" (Gt 3)) 1 --- FailT "expected > 3" +-- Fail "expected > 3" -- -- >>> pz @(Guard (PrintF "%d not > 3" Id) (Gt 3)) (-99) --- FailT "-99 not > 3" +-- Fail "-99 not > 3" -- --- >>> pl @(Map (Guard "someval" (Lt 3) >> 'True) Id) [1::Int ..10] +-- >>> pl @(Map (Guard "someval" (Lt 3) >> 'True)) [1 ..10] -- Error someval(8) (Map(i=2, a=3) excnt=8) --- FailT "someval(8)" +-- Fail "someval(8)" -- -- >>> pl @(Guard "someval" (Len == 2) >> (ShowP Id &&& Id)) ([] :: [Int]) --- Error someval ((>>) lhs failed) --- FailT "someval" +-- Error someval (Guard | []) +-- Fail "someval" -- -- >>> pl @(Guard "someval" (Len == 2) >> (Id &&& ShowP Id)) [2,3] --- Present ([2,3],"[2,3]") ((>>) ([2,3],"[2,3]") | {W '([2,3],"[2,3]")}) --- PresentT ([2,3],"[2,3]") +-- Present ([2,3],"[2,3]") ((>>) ([2,3],"[2,3]") | {'([2,3],"[2,3]")}) +-- Val ([2,3],"[2,3]") -- -- >>> pl @(Guard "someval" (Len == 2) >> (ShowP Id &&& Id)) [2,3,4] --- Error someval ((>>) lhs failed) --- FailT "someval" +-- Error someval (Guard | [2,3,4]) +-- Fail "someval" -- --- >>> pl @(Map (Guard "someval" (Lt 3) >> 'True) Id) [1::Int ..10] +-- >>> pl @(Map (Guard "someval" (Lt 3) >> 'True)) [1 ..10] -- Error someval(8) (Map(i=2, a=3) excnt=8) --- FailT "someval(8)" +-- Fail "someval(8)" -- --- >>> pl @(Guard "oops" (Len > 2) >> Map (Succ Id) Id) [12,15,16] +-- >>> pl @(Guard "oops" (Len > 2) >> Map Succ) [12,15,16] -- Present [13,16,17] ((>>) [13,16,17] | {Map [13,16,17] | [12,15,16]}) --- PresentT [13,16,17] +-- Val [13,16,17] -- --- >>> pl @(Guard "err" (Len > 2) >> Map (Succ Id) Id) [12] --- Error err ((>>) lhs failed) --- FailT "err" +-- >>> pl @(Guard "err" (Len > 2) >> Map Succ) [12] +-- Error err (Guard | [12]) +-- Fail "err" -- --- >>> pl @(Guard (PrintF "err found len=%d" Len) (Len > 5) >> Map (Succ Id) Id) [12,15,16] --- Error err found len=3 ((>>) lhs failed) --- FailT "err found len=3" +-- >>> pl @(Guard (PrintF "err found len=%d" Len) (Len > 5) >> Map Succ) [12,15,16] +-- Error err found len=3 (Guard | [12,15,16]) +-- Fail "err found len=3" -- -data Guard prt p +data Guard prt p deriving Show -instance (Show a - , P prt a - , PP prt a ~ String - , P p a - , PP p a ~ Bool - ) => P (Guard prt p) a where +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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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 + Right ee -> mkNode opts (Fail ee) (msg0 <> " | " <> showL opts a) (hh pp : verboseList opts qq) + Right True -> pure $ mkNode opts (Val a) (msg0 <> "(ok) | " <> showL opts a) [hh pp] -- dont show the guard message if successful --- | uses 'Guard' but negates \'p\' +-- | boolean guard -- --- >>> pl @(HeadFail "failedn" Id &&& (Len == 1 >> ExitWhen "ExitWhen" Id) >> Fst Id) [3] --- Error ExitWhen ((>>) lhs failed) --- FailT "ExitWhen" +-- >>> pl @(GuardBool (PrintF "bad length = %d" Len) (Len > 9)) [3..8] +-- Error bad length = 6 (GuardBool (6 > 9)) +-- Fail "bad length = 6" -- --- >>> pl @(Head Id &&& (Len == 1 >> Not Id >> ExitWhen "ExitWhen" Id) >> Fst Id) [3] +data GuardBool prt p deriving Show + +instance ( P prt a + , PP prt a ~ String + , P p a + , PP p a ~ Bool + ) => P (GuardBool prt p) a where + type PP (GuardBool prt p) a = Bool + eval _ opts a = do + let msg0 = "GuardBool" + pp <- evalBool (Proxy @p) opts a + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts a + pure $ case getValueLR NoInline opts (msg0 <> " Msg") qq [hh pp] of + Left e -> e + Right ee -> mkNode opts (Fail ee) (msg0 <> nullSpace (topMessage pp)) [hh pp, hh qq] + Right True -> pure $ mkNodeB opts True "" [hh pp] -- dont show the guard message if successful + +-- | uses 'Guard' but negates @p@ +-- +-- >>> pl @(HeadFail "failedn" Id &&& (Len == 1 >> ExitWhen "ExitWhen" Id) >> Fst) [3] +-- Error ExitWhen (Guard | True | True | '(,)) +-- Fail "ExitWhen" +-- +-- >>> pl @(Head &&& (Len == 1 >> Not Id >> ExitWhen "ExitWhen" Id) >> Fst) [3] -- Present 3 ((>>) 3 | {Fst 3 | (3,False)}) --- PresentT 3 +-- Val 3 -- --- >>> pl @(Head Id &&& (Len == 1 >> ExitWhen "ExitWhen" (Not Id)) >> Fst Id) [3] +-- >>> pl @(Head &&& (Len == 1 >> ExitWhen "ExitWhen" (Not Id)) >> Fst) [3] -- Present 3 ((>>) 3 | {Fst 3 | (3,True)}) --- PresentT 3 +-- Val 3 -- --- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head Id) [3,1] --- Error ExitWhen ((>>) lhs failed) --- FailT "ExitWhen" +-- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head) [3,1] +-- Error ExitWhen (Guard | [3,1]) +-- Fail "ExitWhen" -- --- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head Id) [3] +-- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head) [3] -- Present 3 ((>>) 3 | {Head 3 | [3]}) --- PresentT 3 +-- Val 3 -- --- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head Id >> Gt (20 -% 1)) [3] +-- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head >> Gt (20 -% 1)) [3] -- True ((>>) True | {3 % 1 > (-20) % 1}) --- TrueT +-- Val True -- --- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head Id >> Gt (20 -% 1)) [-23] +-- >>> pl @(ExitWhen "ExitWhen" (Len /= 1) >> Head >> Gt (20 -% 1)) [-23] -- False ((>>) False | {(-23) % 1 > (-20) % 1}) --- FalseT +-- Val False -- --- >>> pl @(Map (ExitWhen "ExitWhen" (Gt 10) >> Gt 2) Id) [1..5] +-- >>> pl @(Map (ExitWhen "ExitWhen" (Gt 10) >> Gt 2)) [1..5] -- Present [False,False,True,True,True] (Map [False,False,True,True,True] | [1,2,3,4,5]) --- PresentT [False,False,True,True,True] +-- Val [False,False,True,True,True] -- --- >>> pl @(ExitWhen "err" (Len > 2) >> Map (Succ Id) Id) [12,15,16] --- Error err ((>>) lhs failed) --- FailT "err" +-- >>> pl @(ExitWhen "err" (Len > 2) >> Map Succ) [12,15,16] +-- Error err (Guard | [12,15,16]) +-- Fail "err" -- --- >>> pl @(ExitWhen "err" (Len > 2) >> Map (Succ Id) Id) [12] +-- >>> pl @(ExitWhen "err" (Len > 2) >> Map Succ) [12] -- Present [13] ((>>) [13] | {Map [13] | [12]}) --- PresentT [13] +-- Val [13] -- - -data ExitWhen prt p +data ExitWhen prt p deriving Show type ExitWhenT prt p = Guard prt (Not p) instance P (ExitWhenT prt p) x => P (ExitWhen prt p) x where @@ -871,51 +840,45 @@ -- | 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])" +-- >>> pz @(GuardSimple IsLuhn) [1..4] +-- Fail "(IsLuhn 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 +-- >>> pl @IsLuhn [1..4] +-- False (IsLuhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4]) +-- Val False -- --- >>> pz @(GuardSimple (Luhn Id)) [1,2,3,0] --- PresentT [1,2,3,0] +-- >>> pz @(GuardSimple IsLuhn) [1,2,3,0] +-- Val [1,2,3,0] -- -- >>> pz @(GuardSimple (Len > 30)) [1,2,3,0] --- FailT "(4 > 30)" +-- Fail "(4 > 30)" -- --- >>> pl @(Map (GuardSimple (Lt 3) >> 'True) Id) [1::Int .. 10] +-- >>> pl @(Map (GuardSimple (Lt 3) >> 'True)) [1 .. 10] -- Error (3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3) (Map(i=2, a=3) excnt=8) --- FailT "(3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3)" +-- Fail "(3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3)" -- --- >>> pl @(Map (GuardSimple (Ge 1) >> 'True) Id) [1::Int .. 10] +-- >>> pl @(Map (GuardSimple (Ge 1) >> 'True)) [1 .. 10] -- Present [True,True,True,True,True,True,True,True,True,True] (Map [True,True,True,True,True,True,True,True,True,True] | [1,2,3,4,5,6,7,8,9,10]) --- PresentT [True,True,True,True,True,True,True,True,True,True] +-- Val [True,True,True,True,True,True,True,True,True,True] -- --- >>> pl @(Map (GuardSimple (Lt 3) >> 'True) Id) [1::Int .. 10] +-- >>> pl @(Map (GuardSimple (Lt 3) >> 'True)) [1 .. 10] -- Error (3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3) (Map(i=2, a=3) excnt=8) --- FailT "(3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3)" --- --- >>> pl @(Map (GuardSimple (Ge 1) >> 'True) Id) [1::Int .. 10] --- Present [True,True,True,True,True,True,True,True,True,True] (Map [True,True,True,True,True,True,True,True,True,True] | [1,2,3,4,5,6,7,8,9,10]) --- PresentT [True,True,True,True,True,True,True,True,True,True] +-- Fail "(3 < 3) | (4 < 3) | (5 < 3) | (6 < 3) | (7 < 3) | (8 < 3) | (9 < 3) | (10 < 3)" -- -data GuardSimple p +data GuardSimple p deriving Show -instance (Show a - , P p a - , PP p a ~ Bool - ) => P (GuardSimple p) a where +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 + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e Right False -> let msgx = topMessage pp - in mkNode opts (FailT msgx) (msg0 <> " | " <> showL opts a) [hh pp] + in mkNode opts (Fail msgx) (msg0 <> " | " <> showL opts a) [hh pp] Right True -> - mkNode opts (PresentT a) (msg0 <> "(ok) | " <> showL opts a) [hh pp] + mkNode opts (Val a) (msg0 <> "(ok) | " <> showL opts a) [hh pp]
src/Predicate/Data/DateTime.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -20,15 +14,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted date time functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted date time functions module Predicate.Data.DateTime ( -- ** format FormatTimeP + , FormatTimeP' -- ** constructors , ParseTimeP @@ -42,6 +35,8 @@ , MkTime , MkTime' , PosixToUTCTime + , DiffUTCTime + , DiffLocalTime -- ** destructors , UnMkDay @@ -51,17 +46,18 @@ , ToTime , UnMkTime , UTCTimeToPosix + , LocalTimeToUTC ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Control.Lens hiding (iall) -import Data.Proxy -import Data.Typeable +import Control.Lens +import Data.Typeable (Typeable, Proxy(Proxy)) import Data.Kind (Type) -import Data.Maybe +import Data.Maybe (catMaybes) import Data.Time -import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.WeekDate (toWeekDate) import qualified Data.Time.Clock.System as CP import qualified Data.Time.Clock.POSIX as P -- $setup @@ -69,135 +65,146 @@ -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Text as T -- >>> import Predicate.Prelude -- >>> import Safe (readNote) -- | type level expression representing a formatted time --- similar to 'Data.Time.formatTime' using a type level 'GHC.TypeLits.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" +-- similar to 'Data.Time.formatTime' using a type level 'GHC.TypeLits.Symbol' to get the formatting string -- --- >>> pl @(FormatTimeP "%Y-%m-%d" Id) (readNote @Day "invalid day" "2019-08-17") --- Present "2019-08-17" (FormatTimeP (%Y-%m-%d) 2019-08-17 | 2019-08-17) --- PresentT "2019-08-17" +-- >>> pz @(FormatTimeP' Fst Snd) ("the date is %d/%m/%Y", readNote @Day "invalid day" "2019-05-24") +-- Val "the date is 24/05/2019" -- -data FormatTimeP p q +data FormatTimeP' p q deriving Show -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 +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 [] + lr <- runPQ NoInline 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] + in mkNode opts (Val 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 +-- | type level expression representing a formatted time -- --- >>> pz @(ParseTimeP LocalTime "%F %T" Id) "2019-05-24 05:19:59" --- PresentT 2019-05-24 05:19:59 +-- >>> pz @(FormatTimeP "%F %T") (readNote @LocalTime "invalid localtime" "2019-05-24 05:19:59") +-- Val "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 +-- >>> pl @(FormatTimeP "%Y-%m-%d") (readNote @Day "invalid day" "2019-08-17") +-- Present "2019-08-17" (FormatTimeP (%Y-%m-%d) 2019-08-17 | 2019-08-17) +-- Val "2019-08-17" -- --- keeping \'q\' as we might want to extract from a tuple -data ParseTimeP' t p q +data FormatTimeP p deriving Show +type FormatTimePT p = FormatTimeP' p Id -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 +instance P (FormatTimePT p) x => P (FormatTimeP p) x where + type PP (FormatTimeP p) x = PP (FormatTimePT p) x + eval _ = eval (Proxy @(FormatTimePT p)) + + + +-- | 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 +-- keeping @q@ as we might want to extract from a tuple +data ParseTimeP' t p q deriving Show + +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 [] + lr <- runPQ NoInline 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 + Just b -> mkNode opts (Val b) (lit3 opts msg1 b "fmt=" p <> showVerbose opts " | " q) hhs + Nothing -> mkNode opts (Fail (msg1 <> " failed to parse")) "" hhs -- | similar to 'Date.Time.parseTimeM' -- --- >>> pl @(ParseTimeP TimeOfDay "%H:%M%S" Id) "14:04:61" +-- >>> pz @(ParseTimeP LocalTime "%F %T") "2019-05-24 05:19:59" +-- Val 2019-05-24 05:19:59 +-- +-- >>> pz @("2019-05-24 05:19:59" >> ParseTimeP LocalTime "%F %T") (Right "never used") +-- Val 2019-05-24 05:19:59 +-- +-- >>> pl @(ParseTimeP TimeOfDay "%H:%M%S") "14:04:61" -- Error ParseTimeP TimeOfDay (%H:%M%S) failed to parse --- FailT "ParseTimeP TimeOfDay (%H:%M%S) failed to parse" +-- Fail "ParseTimeP TimeOfDay (%H:%M%S) failed to parse" -- --- >>> pl @(ParseTimeP UTCTime "%F %T" Id) "1999-01-01 12:12:12" +-- >>> pl @(ParseTimeP UTCTime "%F %T") "1999-01-01 12:12:12" -- Present 1999-01-01 12:12:12 UTC (ParseTimeP UTCTime (%F %T) 1999-01-01 12:12:12 UTC | fmt=%F %T | "1999-01-01 12:12:12") --- PresentT 1999-01-01 12:12:12 UTC +-- Val 1999-01-01 12:12:12 UTC -- - -data ParseTimeP (t :: Type) p q -type ParseTimePT (t :: Type) p q = ParseTimeP' (Hole t) p q +-- >>> pz @(ParseTimeP ZonedTime "%s%Q%z") "153014400.000+0530" +-- Val 1974-11-07 05:30:00 +0530 +-- +data ParseTimeP (t :: Type) p deriving Show +type ParseTimePT (t :: Type) p = ParseTimeP' (Hole t) p Id -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)) +instance P (ParseTimePT t p) x => P (ParseTimeP t p) x where + type PP (ParseTimeP t p) x = PP (ParseTimePT t p) x + eval _ = eval (Proxy @(ParseTimePT t p)) -- | A convenience method to match against many different datetime formats to find the first match -data ParseTimes' t p q +data ParseTimes' t p q deriving Show -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 +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 [] + lr <- runPQ NoInline 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 + [] -> mkNode opts (Fail ("no match on (" ++ q ++ ")")) msg0 hhs + (d,b):_ -> mkNode opts (Val b) (lit3 opts msg0 b "fmt=" d <> showVerbose opts " | " q) hhs -- | A convenience method to match against many different datetime formats to find the first 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 +-- Val 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 +-- >>> pz @(ParseTimes LocalTime Fst Snd) (["%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") +-- Val 2019-03-11 01:22:33 -- --- >>> pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/0x7"] +-- >>> pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id)) ["2001-01-01", "Jan 24 2009", "03/29/0x7"] -- Error no match on (03/29/0x7) (Map(i=2, a="03/29/0x7") excnt=1) --- FailT "no match on (03/29/0x7)" +-- Fail "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/07"] +-- >>> pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id)) ["2001-01-01", "Jan 24 2009", "03/29/07"] -- Present [2001-01-01,2009-01-24,2007-03-29] (Map [2001-01-01,2009-01-24,2007-03-29] | ["2001-01-01","Jan 24 2009","03/29/07"]) --- PresentT [2001-01-01,2009-01-24,2007-03-29] +-- Val [2001-01-01,2009-01-24,2007-03-29] -- -data ParseTimes (t :: Type) p q +data ParseTimes (t :: Type) p q deriving Show 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 @@ -206,49 +213,49 @@ -- | create a 'Day' from three int values passed in as year month and day -- --- >>> pz @(MkDay' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) --- PresentT Nothing +-- >>> pz @(MkDay' Fst Snd Thd) (2019,99,99999) +-- Val Nothing -- -data MkDay' p q r +data MkDay' p q r deriving Show -instance (P p x - , P q x - , P r x - , PP p x ~ Int - , PP q x ~ Int - , PP r x ~ Int +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 [] + lr <- runPQ NoInline 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 + pure $ case getValueLR NoInline 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]) + in mkNode opts (Val mday) (show3' opts msg0 mday "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) -- | 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 +-- Val 0001-02-03 -- --- >>> pz @(Just (MkDay '(1,2,3))) 1 --- PresentT 0001-02-03 +-- >>> pz @('Just (MkDay '(1,2,3))) 1 +-- Val 0001-02-03 -- -- >>> pz @(MkDay Id) (2019,12,30) --- PresentT (Just 2019-12-30) +-- Val (Just 2019-12-30) -- -- >>> pz @(MkDay Id) (1999,3,13) --- PresentT (Just 1999-03-13) +-- Val (Just 1999-03-13) -- -data MkDay p -type MkDayT p = MkDay' (Fst p) (Snd p) (Thd p) +data MkDay p deriving Show +type MkDayT p = p >> MkDay' Fst Snd Thd instance P (MkDayT p) x => P (MkDay p) x where type PP (MkDay p) x = PP (MkDayT p) x @@ -257,9 +264,9 @@ -- | uncreate a 'Day' returning year month and day -- -- >>> pz @(UnMkDay Id) (readNote "invalid day" "2019-12-30") --- PresentT (2019,12,30) +-- Val (2019,12,30) -- -data UnMkDay p +data UnMkDay p deriving Show instance ( PP p x ~ Day , P p x @@ -268,62 +275,62 @@ eval _ opts x = do let msg0 = "UnMkDay" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] -- | create a 'Day', week number, and the day of the week from three numbers passed in as year month and day -- --- >>> pz @(MkDayExtra' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) --- PresentT Nothing +-- >>> pz @(MkDayExtra' Fst Snd Thd) (2019,99,99999) +-- Val Nothing -- -data MkDayExtra' p q r +data MkDayExtra' p q r deriving Show -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 +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 [] + lr <- runPQ NoInline 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 + pure $ case getValueLR NoInline 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]) + in mkNode opts (Val b) (show3' opts msg0 b "(y,m,d)=" (p,q,r)) (hhs <> [hh rr]) -- | create a 'Day', week number, and the day of the week from three numbers passed in as year month and day -- --- >>> pz @(MkDayExtra '(1,2,3) >> 'Just Id >> Fst Id) () --- PresentT 0001-02-03 +-- >>> pz @(MkDayExtra '(1,2,3) >> 'Just Id >> Fst) () +-- Val 0001-02-03 -- --- >>> pz @(Fst (Just (MkDayExtra '(1,2,3)))) 1 --- PresentT 0001-02-03 +-- >>> pz @(L1 (Just (MkDayExtra '(1,2,3)))) 1 +-- Val 0001-02-03 -- -- >>> pz @(MkDayExtra Id) (2019,12,30) --- PresentT (Just (2019-12-30,1,1)) +-- Val (Just (2019-12-30,1,1)) -- -- >>> pz @(MkDayExtra Id) (1999,3,13) --- PresentT (Just (1999-03-13,10,6)) +-- Val (Just (1999-03-13,10,6)) -- -data MkDayExtra p -type MkDayExtraT p = MkDayExtra' (Fst p) (Snd p) (Thd p) +data MkDayExtra p deriving Show +type MkDayExtraT p = p >> MkDayExtra' Fst Snd Thd instance P (MkDayExtraT p) x => P (MkDayExtra p) x where type PP (MkDayExtra p) x = PP (MkDayExtraT p) x @@ -331,10 +338,10 @@ -- | get the day of the week -- --- >>> pz @(Just (MkDay '(2020,7,11)) >> '(UnMkDay Id, ToWeekYear Id,ToWeekDate Id)) () --- PresentT ((2020,7,11),28,(6,"Saturday")) +-- >>> pz @('Just (MkDay '(2020,7,11)) >> '(UnMkDay Id, ToWeekYear Id,ToWeekDate Id)) () +-- Val ((2020,7,11),28,(6,"Saturday")) -- -data ToWeekDate p +data ToWeekDate p deriving Show instance ( P p x , PP p x ~ Day @@ -343,28 +350,27 @@ eval _ opts x = do let msg0 = "ToWeekDate" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + dowString = case dow `mod` 7 of + 0 -> "Sunday" + 1 -> "Monday" + 2 -> "Tuesday" + 3 -> "Wednesday" + 4 -> "Thursday" + 5 -> "Friday" + 6 -> "Saturday" + o -> errorInProgram $ "ToWeekDate:" ++ show o + in mkNode opts (Val (dow,dowString)) (show3 opts msg0 dow p) [hh pp] -- | get week number of the year -- --- >>> pz @(Just (MkDay '(2020,7,11)) >> ToWeekYear Id) () --- PresentT 28 +-- >>> pz @('Just (MkDay '(2020,7,11)) >> ToWeekYear Id) () +-- Val 28 -- -data ToWeekYear p +data ToWeekYear p deriving Show instance ( P p x , PP p x ~ Day @@ -373,11 +379,11 @@ eval _ opts x = do let msg0 = "ToWeekYear" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val week) (show3 opts msg0 week p) [hh pp] class ToDayC a where getDay :: a -> Day @@ -413,89 +419,78 @@ -- | extract 'Day' from a DateTime -- --- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" --- PresentT 2020-07-06 +-- >>> pz @(ReadP UTCTime Id >> ToDay) "2020-07-06 12:11:13Z" +-- Val 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 +data ToDay deriving Show +instance ( ToDayC x + , Show x + ) => P ToDay x where + type PP ToDay x = Day + eval _ opts x = 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] + ret = getDay x + in pure $ mkNode opts (Val ret) (show3 opts msg0 ret x) [] -- | extract 'TimeOfDay' from DateTime -- --- >>> pz @(ReadP UTCTime Id >> ToDay Id) "2020-07-06 12:11:13Z" --- PresentT 2020-07-06 +-- >>> pz @(ReadP UTCTime Id >> ToTime) "2020-07-06 12:11:13Z" +-- Val 12:11:13 -- -data ToTime p +data ToTime deriving Show -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 +instance ( ToTimeC x + , Show x + ) => P ToTime x where + type PP ToTime x = TimeOfDay + eval _ opts x = 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] + ret = getTime x + in pure $ mkNode opts (Val ret) (show3 opts msg0 ret x) [] -- | 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 +-- >>> pz @(MkTime' Fst Snd Thd) (13,99,99999) +-- Val 13:99:99999 -- -data MkTime' p q r +data MkTime' p q r deriving Show -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 +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 [] + lr <- runPQ NoInline 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 + pure $ case getValueLR NoInline 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]) + in mkNode opts (Val mtime) (show3' 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 +-- Val 01:02:00.000243013365 -- -- >>> pz @(MkTime Id) (12,13,65) --- PresentT 12:13:65 +-- Val 12:13:65 -- -- >>> pz @(MkTime Id) (17,3,13) --- PresentT 17:03:13 +-- Val 17:03:13 -- -data MkTime p -type MkTimeT p = MkTime' (Fst p) (Snd p) (Thd p) +data MkTime p deriving Show +type MkTimeT p = p >> MkTime' Fst Snd Thd instance P (MkTimeT p) x => P (MkTime p) x where type PP (MkTime p) x = PP (MkTimeT p) x @@ -504,16 +499,16 @@ -- | 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 "2019-01-01 12:13:14.1234Z" >> ToTime >> UnMkTime Id) () +-- Val (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 UTCTime Id >> ToTime >> UnMkTime Id) "2020-07-22 08:01:14.127Z" +-- Val (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)) +-- >>> pz @(ReadP ZonedTime Id >> '(UnMkDay ToDay, UnMkTime ToTime)) "2020-07-11 11:41:12.333+0400" +-- Val ((2020,7,11),(11,41,12333 % 1000)) -- -data UnMkTime p +data UnMkTime p deriving Show instance ( PP p x ~ TimeOfDay , P p x @@ -522,12 +517,12 @@ eval _ opts x = do let msg0 = "UnMkTime" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] -- microsoft json date is x*1000 ie milliseconds @@ -536,24 +531,24 @@ -- -- >>> 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 +-- Val 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) +-- Val (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 +-- Val 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 +-- Val 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 +-- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" >> Head >> Snd >> ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) "Date(1530144000000+0530)" +-- Val 2018-06-28 00:00:00 UTC -- -data PosixToUTCTime p +data PosixToUTCTime p deriving Show instance ( PP p x ~ Rational , P p x @@ -562,27 +557,22 @@ eval _ opts x = do let msg0 = "PosixToUTCTime" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (show3 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 +-- Val (1593384312 % 1) -- --- >>> pz @(ParseTimeP ZonedTime "%s%Q%z" Id) "153014400.000+0530" --- PresentT 1974-11-07 05:30:00 +0530 +-- >>> pz @(Rescan "^Date\\((\\d+)([^\\)]+)\\)" >> Head >> Snd >> ((ReadP Integer (Id !! 0) >> PosixToUTCTime (Id % 1000)) &&& ReadP TimeZone (Id !! 1))) "Date(1530144000000+0530)" +-- Val (2018-06-28 00:00:00 UTC,+0530) -- -data UTCTimeToPosix p +data UTCTimeToPosix p deriving Show instance ( PP p x ~ UTCTime , P p x @@ -591,9 +581,61 @@ eval _ opts x = do let msg0 = "UTCTimeToPosix" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + + +-- | similar to 'Data.Time.diffUTCTime' +-- +-- >>> pz @(DiffUTCTime Fst Snd) (read "2020-11-08 12:12:03Z", read "2020-11-08 11:12:00Z") +-- Val 3603s +-- +data DiffUTCTime p q deriving Show + +instance ( PP p x ~ UTCTime + , PP q x ~ UTCTime + , P p x + , P q x + ) => P (DiffUTCTime p q) x where + type PP (DiffUTCTime p q) x = NominalDiffTime + eval _ opts x = do + let msg0 = "DiffUTCTime" + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = diffUTCTime p q + in mkNode opts (Val b) (msg0 <> " " <> showL opts b <> showVerbose opts " | " p <> showVerbose opts " | " q) [hh pp, hh qq] + +-- | similar to 'Data.Time.diffLocalTime' +-- +-- >>> pz @(DiffLocalTime Fst Snd) (read "2020-11-08 12:12:03", read "2020-11-05 15:12:00") +-- Val 248403s +-- +data DiffLocalTime p q deriving Show +type DiffLocalTimeT p q = DiffUTCTime (LocalTimeToUTC p) (LocalTimeToUTC q) + +instance P (DiffLocalTimeT p q) x => P (DiffLocalTime p q) x where + type PP (DiffLocalTime p q) x = PP (DiffLocalTimeT p q) x + eval _ = eval (Proxy @(DiffLocalTimeT p q)) + + +-- | similar to 'Data.Time.localTimeToUTC' +data LocalTimeToUTC p deriving Show + +instance ( PP p x ~ LocalTime + , P p x + ) => P (LocalTimeToUTC p) x where + type PP (LocalTimeToUTC p) x = UTCTime + eval _ opts x = do + let msg0 = "LocalTimeToUTC" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = localTimeToUTC utc p + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp]
src/Predicate/Data/Either.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,11 +12,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted 'Either' functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted 'Either' functions module Predicate.Data.Either ( -- ** boolean predicates @@ -43,264 +35,245 @@ , RightDef , RightFail , EitherBool - , EitherIn , PartitionEithers -- ** miscellaneous , type (|||) , type (+++) + , EitherX ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import GHC.TypeLits (ErrorMessage((:$$:),(:<>:))) import qualified GHC.TypeLits as GL -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import Data.Kind (Type) -import Data.Either +import Data.Either (isLeft, isRight, partitionEithers) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Text as T -- >>> import Predicate.Prelude -- >>> import qualified Data.Semigroup as SG -- | extracts the left value from an 'Either' -- --- >>> pz @(Left' >> Succ Id) (Left 20) --- PresentT 21 +-- >>> pz @(Left' >> Succ) (Left 20) +-- Val 21 -- --- >>> pz @(Left' >> Succ Id) (Right 'a') --- FailT "Left' found Right" +-- >>> pz @(Left' >> Succ) (Right 'a') +-- Fail "Left' found Right" -- -data Left' -instance (Show a - ) => P Left' (Either a x) where +data Left' deriving Show +instance Show a => P Left' (Either a x) where type PP Left' (Either a x) = a eval _ opts lr = let msg0 = "Left'" in pure $ case lr of - Right _ -> mkNode opts (FailT (msg0 <> " found Right")) "" [] - Left a -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + Right _ -> mkNode opts (Fail (msg0 <> " found Right")) "" [] + Left a -> mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -- | extracts the right value from an 'Either' -- --- >>> pz @(Right' >> Succ Id) (Right 20) --- PresentT 21 +-- >>> pz @(Right' >> Succ) (Right 20) +-- Val 21 -- --- >>> pz @(Right' >> Succ Id) (Left 'a') --- FailT "Right' found Left" +-- >>> pz @(Right' >> Succ) (Left 'a') +-- Fail "Right' found Left" -- -data Right' -instance (Show a - ) => P Right' (Either x a) where +data Right' deriving Show +instance Show a => P Right' (Either x a) where type PP Right' (Either x a) = a eval _ opts lr = let msg0 = "Right'" in pure $ case lr of - Left _ -> mkNode opts (FailT (msg0 <> " found Left")) "" [] - Right a -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + Left _ -> mkNode opts (Fail (msg0 <> " found Left")) "" [] + Right a -> mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -- | similar 'Control.Arrow.|||' -- --- >>> pz @(Pred Id ||| Id) (Left 13) --- PresentT 12 +-- >>> pz @(Pred ||| Id) (Left 13) +-- Val 12 -- -- >>> pz @(ShowP Id ||| Id) (Right "hello") --- PresentT "hello" +-- Val "hello" -- -- >>> pl @('True ||| 'False) (Left "someval") -- True ((|||) Left True | "someval") --- TrueT +-- Val True -- -- >>> pl @('True ||| 'False) (Right "someval") -- False ((|||) Right False | "someval") --- FalseT +-- Val False -- --- >>> pl @(ShowP (Succ Id) ||| ShowP Id) (Left 123) +-- >>> pl @(ShowP Succ ||| ShowP Id) (Left 123) -- Present "124" ((|||) Left "124" | 123) --- PresentT "124" +-- Val "124" -- --- >>> pl @(ShowP (Succ Id) ||| ShowP Id) (Right True) +-- >>> pl @(ShowP Succ ||| ShowP Id) (Right True) -- Present "True" ((|||) Right "True" | True) --- PresentT "True" +-- Val "True" -- --- >>> pl @(EitherIn (Not Id) Id) (Right True) +-- >>> pl @(Not Id ||| Id) (Right True) -- Present True ((|||) Right True | True) --- PresentT True +-- Val True -- --- >>> pl @(EitherIn (Not Id) Id) (Left True) +-- >>> pl @(Not Id ||| Id) (Left True) -- False ((|||) Left False | True) --- FalseT +-- Val False -- -data p ||| q +data p ||| q deriving Show 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 +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 + pure $ case getValueLR NoInline 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] + in mkNodeCopy opts pp (show3 opts msg1 a1 a) [hh pp] Right a -> do qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [] of + pure $ case getValueLR NoInline 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] + in mkNodeCopy opts qq (show3 opts msg1 a1 a) [hh qq] -- | similar to 'isLeft' -- --- >>> pz @(IsLeft Id) (Right 123) --- FalseT +-- >>> pz @IsLeft (Right 123) +-- Val False -- --- >>> pz @(IsLeft Id) (Left 'a') --- TrueT +-- >>> pz @IsLeft (Left 'a') +-- Val True -- -data IsLeft p +data IsLeft deriving Show -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 +instance x ~ Either a b + => P IsLeft x where + type PP IsLeft x = Bool + eval _ opts x = pure $ mkNodeB opts (isLeft x) "IsLeft" [] -- | similar to 'isRight' -- --- >>> pz @(IsRight Id) (Right 123) --- TrueT +-- >>> pz @IsRight (Right 123) +-- Val True -- --- >>> pz @(IsRight Id) (Left "aa") --- FalseT +-- >>> pz @IsRight (Left "aa") +-- Val False -- -data IsRight p +data IsRight deriving Show -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 +instance x ~ Either a b + => P IsRight x where + type PP IsRight x = Bool + eval _ opts x = pure $ mkNodeB opts (isRight x) "IsRight" [] -- | similar 'Control.Arrow.+++' -- --- >>> pz @(Pred Id +++ Id) (Left 13) --- PresentT (Left 12) +-- >>> pz @(Pred +++ Id) (Left 13) +-- Val (Left 12) -- -- >>> pz @(ShowP Id +++ Reverse) (Right "hello") --- PresentT (Right "olleh") +-- Val (Right "olleh") -- -- >>> pl @(HeadDef 'False Id +++ Id) (Right @[Bool] 1) -- need @[Bool] cos we said 'False! -- Present Right 1 ((+++) Right 1 | 1) --- PresentT (Right 1) +-- Val (Right 1) -- -- >>> pl @(HeadDef 'False Id +++ Id) (Left [True,False]) -- need @[Bool] cos we said 'False! -- Present Left True ((+++) Left True | [True,False]) --- PresentT (Left True) +-- Val (Left True) -- -- >>> pl @(Not Id +++ Id) (Right True) -- Present Right True ((+++) Right True | True) --- PresentT (Right True) +-- Val (Right True) -- -- >>> pl @(Not Id +++ Id) (Right 12) -- Present Right 12 ((+++) Right 12 | 12) --- PresentT (Right 12) +-- Val (Right 12) -- -- >>> pl @(HeadDef () Id +++ Id) (Right @[()] 1) -- breaks otherwise: Id says () -> () so has to be a list of [()] -- Present Right 1 ((+++) Right 1 | 1) --- PresentT (Right 1) +-- Val (Right 1) -- -- >>> pl @(HeadDef () Id +++ Id) (Right @[()] 1) -- this breaks! cos Left doesnt have a type -- Present Right 1 ((+++) Right 1 | 1) --- PresentT (Right 1) +-- Val (Right 1) -- -- >>> pl @(Not Id +++ Id) (Right @Bool 12) -- Present Right 12 ((+++) Right 12 | 12) --- PresentT (Right 12) +-- Val (Right 12) -- -data p +++ q +data p +++ q deriving Show 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 +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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val (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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val (Right a1)) (msg1 <> " " <> showL opts a1 <> showVerbose opts " | " a) [hh qq] -- | similar to 'partitionEithers' -- -- >>> pz @PartitionEithers [Left 'a',Right 2,Left 'c',Right 4,Right 99] --- PresentT ("ac",[2,4,99]) +-- Val ("ac",[2,4,99]) -- -- >>> pz @PartitionEithers [Right 2,Right 4,Right 99] --- PresentT ([],[2,4,99]) +-- Val ([],[2,4,99]) -- -- >>> pz @PartitionEithers [Left 'a',Left 'c'] --- PresentT ("ac",[]) +-- Val ("ac",[]) -- -- >>> pz @PartitionEithers ([] :: [Either () Int]) --- PresentT ([],[]) +-- Val ([],[]) -- -- >>> pl @PartitionEithers [Left 4, Right 'x', Right 'y',Left 99] -- Present ([4,99],"xy") (PartitionEithers ([4,99],"xy") | [Left 4,Right 'x',Right 'y',Left 99]) --- PresentT ([4,99],"xy") +-- Val ([4,99],"xy") -- -- >>> pl @PartitionEithers [Left 'x', Right 1,Left 'a', Left 'b',Left 'z', Right 10] -- Present ("xabz",[1,10]) (PartitionEithers ("xabz",[1,10]) | [Left 'x',Right 1,Left 'a',Left 'b',Left 'z',Right 10]) --- PresentT ("xabz",[1,10]) +-- Val ("xabz",[1,10]) -- -data PartitionEithers +data PartitionEithers deriving Show instance ( Show a , Show b @@ -309,106 +282,106 @@ eval _ opts as = let msg0 = "PartitionEithers" b = partitionEithers as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + in pure $ mkNode opts (Val b) (show3 opts msg0 b as) [] --- | Convenient method to convert a \'p\' or \'q\' to a 'Either' based on a predicate \'b\' --- if \'b\' then Right \'p\' else Left \'q\' +-- | 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 > 4) L21 L22) (24,(-1,999)) +-- Val (Right 999) -- --- >>> pz @(EitherBool (Fst Id > 4) (Fst (Snd Id)) (Snd (Snd Id))) (1,(-1,999)) --- PresentT (Left (-1)) +-- >>> pz @(EitherBool (Fst > 4) L21 L22) (1,(-1,999)) +-- Val (Left (-1)) -- --- >>> pl @(EitherBool (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (7,('x',99)) +-- >>> pl @(EitherBool (Fst > 10) L21 L22) (7,('x',99)) -- Present Left 'x' (EitherBool(False) Left 'x') --- PresentT (Left 'x') +-- Val (Left 'x') -- --- >>> pl @(EitherBool (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (11,('x',99)) +-- >>> pl @(EitherBool (Fst > 10) L21 L22) (11,('x',99)) -- Present Right 99 (EitherBool(True) Right 99) --- PresentT (Right 99) +-- Val (Right 99) -- -- >>> pl @(EitherBool (Gt 10) "found left" 99) 12 -- Present Right 99 (EitherBool(True) Right 99) --- PresentT (Right 99) +-- Val (Right 99) -- -- >>> pl @(EitherBool (Gt 10) "found left" 99) 7 -- Present Left "found left" (EitherBool(False) Left "found left") --- PresentT (Left "found left") +-- Val (Left "found left") -- -data EitherBool b p q +data EitherBool b p q deriving Show -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 +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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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 p -> mkNode opts (Val (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 + pure $ case getValueLR NoInline 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] + Right q -> mkNode opts (Val (Right q)) (msg0 <> "(True) Right " <> showL opts q) [hh bb, hh qq] --- | similar to 'Control.Arrow.|||' but additionally gives \'p\' and \'q\' the original input +-- | 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 (L11 + Snd)) (ShowP Id) Snd) (9,Left 123) +-- Val "132" -- --- >>> pz @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Right 'x') --- PresentT "((9,Right 'x'),'x')" +-- >>> pz @(EitherX (ShowP (L11 + Snd)) (ShowP Id) Snd) (9,Right 'x') +-- Val "((9,Right 'x'),'x')" -- --- >>> pz @(EitherX (ShowP Id) (ShowP (Second (Succ Id))) (Snd Id)) (9,Right 'x') --- PresentT "((9,Right 'x'),'y')" +-- >>> pz @(EitherX (ShowP Id) (ShowP (Second Succ)) Snd) (9,Right 'x') +-- Val "((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 +data EitherX p q r deriving Show +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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline opts msg1 pp [hh rr] of Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh rr, hh pp] + Right _ -> mkNodeCopy opts 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 + pure $ case getValueLR NoInline opts msg1 qq [hh rr] of Left e -> e - Right _ -> mkNode opts (_tBool qq) msg1 [hh rr, hh qq] + Right _ -> mkNodeCopy opts qq msg1 [hh rr, hh qq] type family EitherXT lr x p where - EitherXT (Either a b) x p = PP p (x,a) + 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) -- | 'Data.Either.Left' constructor -data MkLeft' t p +data MkLeft' t p deriving Show instance ( Show (PP p x) , P p x @@ -417,18 +390,18 @@ eval _ opts x = do let msg0 = "MkLeft" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " Left " <> showL opts p) [hh pp] -- | 'Data.Either.Left' constructor -- -- >>> pz @(MkLeft _ Id) 44 --- PresentT (Left 44) +-- Val (Left 44) -- -data MkLeft (t :: Type) p +data MkLeft (t :: Type) p deriving Show type MkLeftT (t :: Type) p = MkLeft' (Hole t) p instance P (MkLeftT t p) x => P (MkLeft t p) x where @@ -436,7 +409,7 @@ eval _ = eval (Proxy @(MkLeftT t p)) -- | 'Data.Either.Right' constructor -data MkRight' t p +data MkRight' t p deriving Show instance ( Show (PP p x) , P p x @@ -445,18 +418,18 @@ eval _ opts x = do let msg0 = "MkRight" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " Right " <> showL opts p) [hh pp] -- | 'Data.Either.Right' constructor -- -- >>> pz @(MkRight _ Id) 44 --- PresentT (Right 44) +-- Val (Right 44) -- -data MkRight (t :: Type) p +data MkRight (t :: Type) p deriving Show type MkRightT (t :: Type) p = MkRight' (Hole t) p instance P (MkRightT t p) x => P (MkRight t p) x where @@ -465,24 +438,24 @@ -- | extract the Left value from an 'Either' otherwise use the default value: similar to 'Data.Either.fromLeft' -- --- if there is no Left value then \p\ is passed the Right value and the whole context +-- 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) +-- Val (102 % 5) -- -- >>> pz @(LeftDef (1 % 4) Id) (Right "aa") --- PresentT (1 % 4) +-- Val (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 (PrintT "found right=%s fst=%d" '(Fst,L21)) Snd) (123,Right "xy") +-- Val "found right=xy fst=123" -- -- >>> pz @(LeftDef (MEmptyT _) Id) (Right 222) --- PresentT () +-- Val () -- -- >>> pz @(LeftDef (MEmptyT (SG.Sum _)) Id) (Right 222) --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -data LeftDef p q +data LeftDef p q deriving Show instance ( PP q x ~ Either a b , PP p (b,x) ~ a @@ -493,37 +466,37 @@ eval _ opts x = do let msg0 = "LeftDef" qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Left a -> pure $ mkNode opts (PresentT a) (msg0 <> " Left") [hh qq] + Left a -> pure $ mkNode opts (Val a) (msg0 <> " Left") [hh qq] Right b -> do pp <- eval (Proxy @p) opts (b,x) - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " Right") [hh qq, hh pp] + Right p -> mkNode opts (Val p) (msg0 <> " Right") [hh qq, hh pp] -- | extract the Right value from an 'Either': similar to 'Data.Either.fromRight' -- --- if there is no Right value then \p\ is passed the Left value and the whole context +-- 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) +-- Val (102 % 5) -- -- >>> pz @(RightDef (1 % 4) Id) (Left "aa") --- PresentT (1 % 4) +-- Val (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 (PrintT "found left=%s fst=%d" '(Fst,L21)) Snd) (123,Left "xy") +-- Val "found left=xy fst=123" -- -- >>> pz @(RightDef (MEmptyT _) Id) (Left 222) --- PresentT () +-- Val () -- -- >>> pz @(RightDef (MEmptyT (SG.Sum _)) Id) (Left 222) --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -data RightDef p q +data RightDef p q deriving Show instance ( PP q x ~ Either a b , PP p (a,x) ~ b @@ -534,111 +507,113 @@ eval _ opts x = do let msg0 = "RightDef" qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Right b -> pure $ mkNode opts (PresentT b) (msg0 <> " Right") [hh qq] + Right b -> pure $ mkNode opts (Val b) (msg0 <> " Right") [hh qq] Left a -> do pp <- eval (Proxy @p) opts (a,x) - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " Left") [hh qq, hh pp] + Right p -> mkNode opts (Val 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 +-- 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 +-- Val 20.4 -- -- >>> pz @(LeftFail "oops" Id) (Right "aa") --- FailT "oops" +-- Fail "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 (PrintT "found right=%s fst=%d" '(Fst,L21)) Snd) (123,Right "xy") +-- Fail "found right=xy fst=123" -- -- >>> pz @(LeftFail (MEmptyT _) Id) (Right 222) --- FailT "" +-- Fail "" -- --- >>> pl @(LeftFail (PrintF "someval=%d" (Fst (Snd Id))) (Snd Id)) (13::Int,Right @(SG.Sum Int) "abc") +-- >>> pl @(LeftFail (PrintF "someval=%d" L21) Snd) (13::Int,Right @(SG.Sum Int) "abc") -- Error someval=13 (LeftFail Right) --- FailT "someval=13" +-- Fail "someval=13" -- --- >>> pl @(LeftFail (PrintF "someval=%s" (Fst Id)) Id) (Right @(SG.Sum Int) ("abc" :: String)) +-- >>> pl @(LeftFail (PrintF "someval=%s" Fst) Id) (Right @(SG.Sum Int) "abc") -- Error someval=abc (LeftFail Right) --- FailT "someval=abc" +-- Fail "someval=abc" -- --- >>> pl @(LeftFail (PrintF "found rhs=%d" (Fst Id)) Id) (Right @String @Int 10) +-- >>> pl @(LeftFail (PrintF "found rhs=%d" Fst) Id) (Right @String @Int 10) -- Error found rhs=10 (LeftFail Right) --- FailT "found rhs=10" +-- Fail "found rhs=10" -- --- >>> pl @(LeftFail (PrintF "found rhs=%d" (Snd Id >> Snd Id >> Snd Id)) (Snd Id >> Fst Id)) ('x',(Right 10,23::Int)) +-- >>> pl @(LeftFail (PrintF "found rhs=%d" (Snd >> L22)) L21) ('x',(Right 10,23)) -- Error found rhs=23 (LeftFail Right) --- FailT "found rhs=23" +-- Fail "found rhs=23" -- --- >>> pl @(LeftFail (PrintF "found rhs=%d" (Snd (Snd (Snd Id)))) (Fst (Snd Id))) ('x',(Left "abc",23::Int)) +-- >>> pl @(LeftFail (PrintF "found rhs=%d" (L2 L22)) L21) ('x',(Left "abc",23)) -- Present "abc" (Left) --- PresentT "abc" +-- Val "abc" -- -data LeftFail p q +data LeftFail p q deriving Show instance ( PP p (b,x) ~ String , PP q x ~ Either a b , P p (b,x) - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Left a -> pure $ mkNode opts (PresentT a) "Left" [hh qq] + Left a -> pure $ mkNode opts (Val a) "Left" [hh qq] Right b -> do pp <- eval (Proxy @p) opts (b,x) - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Right") [hh qq, hh pp] + Right p -> mkNode opts (Fail 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 +-- 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 +-- Val 20.4 -- -- >>> pz @(RightFail "oops" Id) (Left "aa") --- FailT "oops" +-- Fail "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 (PrintT "found left=%s fst=%d" '(Fst,L21)) Snd) (123,Left "xy") +-- Fail "found left=xy fst=123" -- -- >>> pz @(RightFail (MEmptyT _) Id) (Left 222) --- FailT "" +-- Fail "" -- -data RightFail p q +data RightFail p q deriving Show instance ( PP p (a,x) ~ String , PP q x ~ Either a b , P p (a,x) - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Right b -> pure $ mkNode opts (PresentT b) "Right" [hh qq] + Right b -> pure $ mkNode opts (Val b) "Right" [hh qq] Left a -> do pp <- eval (Proxy @p) opts (a,x) - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Left") [hh qq, hh pp] + Right p -> mkNode opts (Fail p) (msg0 <> " Left") [hh qq, hh pp]
src/Predicate/Data/Enum.hs view
@@ -1,9 +1,5 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -18,18 +14,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted enum functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted enum functions module Predicate.Data.Enum ( - -- *** constructors + -- ** constructors type (...) , EnumFromTo , EnumFromThenTo , FromEnum + , FromEnum' + , Universe + , Universe' -- ** bounded enums , SuccB @@ -40,7 +37,7 @@ , ToEnumBDef' , ToEnumBFail - -- ** unsafe enum expressions + -- ** unsafe enums , Succ , SuccN , Pred @@ -51,66 +48,85 @@ import Predicate.Core import Predicate.Util import Safe (succMay, predMay, toEnumMay) -import Data.Proxy -import qualified Control.Exception as E +import Data.Proxy (Proxy(..)) import Data.Kind (Type) - +import Data.Tree (Tree) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Text as T -- >>> import Predicate.Prelude -- >>> import qualified Data.Semigroup as SG -- >>> import Data.Time -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 +-- | bounded 'succ' function +-- +-- >>> pz @(SuccB 'LT Id) GT +-- Val LT +-- +-- >>> pz @(SuccB 'LT 'GT) () +-- Val LT +-- +-- >>> pz @(SuccB 'GT 'LT) () +-- Val EQ +-- +-- >>> pl @(SuccB 'LT Id) GT +-- Present LT (SuccB out of range) +-- Val LT +-- +data SuccB p q deriving Show + +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 + case getValueLR NoInline 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] + Nothing -> _enumDefault @p @a opts msg0 (hh qq) + Just n -> pure $ mkNode opts (Val n) (show3 opts msg0 n q) [hh qq] --- | bounded 'succ' function --- --- >>> pz @(SuccB 'LT Id) GT --- PresentT LT --- -data SuccB p q +_enumDefault :: forall p a m + . ( MonadEval m + , P p (Proxy a) + , PP p (Proxy a) ~ a + ) + => POpts + -> String + -> Tree PE + -> m (TT a) +_enumDefault opts msg0 hhqq = do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @p) opts (Proxy @a) + pure $ case getValueLR NoInline opts msg1 pp [hhqq] of + Left e -> e + Right _ -> mkNodeCopy opts pp msg1 [hhqq, hh pp] -- | bounded 'succ' function -- -- >>> pz @(SuccB' Id) GT --- FailT "Succ bounded" +-- Fail "Succ bounded" -- -- >>> pz @(SuccB' Id) (13 :: Int) --- PresentT 14 +-- Val 14 -- -- >>> pz @(SuccB' Id) LT --- PresentT EQ +-- Val EQ -- -data SuccB' q -type SuccBT' q = SuccB (Failp "Succ bounded") q +data SuccB' q deriving Show +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 @@ -119,163 +135,151 @@ -- | bounded 'pred' function -- -- >>> pz @(PredB' Id) (13 :: Int) --- PresentT 12 +-- Val 12 -- -- >>> pz @(PredB' Id) LT --- FailT "Pred bounded" +-- Fail "Pred bounded" -- -- >>> pl @(PredB' Id) GT -- Present EQ (PredB EQ | GT) --- PresentT EQ +-- Val EQ -- -- >>> pl @(PredB' Id) LT -- Error Pred bounded (PredB out of range) --- FailT "Pred bounded" +-- Fail "Pred bounded" -- -data PredB' q -type PredBT' q = PredB (Failp "Pred bounded") q +data PredB' q deriving Show +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 +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 + case getValueLR NoInline 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] + Nothing -> _enumDefault @p @a opts msg0 (hh qq) + Just n -> pure $ mkNode opts (Val n) (show3 opts msg0 n q) [hh qq] -- | unbounded 'succ' function -- --- >>> pz @(Succ Id) 13 --- PresentT 14 +-- >>> pz @Succ 13 +-- Val 14 -- --- >>> pz @(Succ Id) LT --- PresentT EQ +-- >>> pz @Succ LT +-- Val EQ -- --- >>> pz @(Succ Id) GT --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" +-- >>> pz @Succ GT +-- Fail "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" -- --- >>> pl @(Succ Id) 10 +-- >>> pl @Succ 10 -- Present 11 (Succ 11 | 10) --- PresentT 11 +-- Val 11 -- --- >>> pl @(Succ Id) True -- captures the exception +-- >>> pl @Succ True -- captures the exception -- Error Succ IO e=Prelude.Enum.Bool.succ: bad argument (True) --- FailT "Succ IO e=Prelude.Enum.Bool.succ: bad argument" +-- Fail "Succ IO e=Prelude.Enum.Bool.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 +-- >>> pz @Succ (Proxy @44) +-- Fail "Succ IO e=Proxy.succ" +-- +data Succ deriving Show +{- +>print $! (succ Proxy) +*** Exception: Proxy.succ +-} +instance ( Show x + , Enum x + ) => P Succ x where + type PP Succ x = 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] + lr <- catchit (succ x) + pure $ case lr of + Left e -> mkNode opts (Fail (msg0 <> " " <> e)) (showL opts x) [] + Right n -> mkNode opts (Val n) (show3 opts msg0 n x) [] -- | SuccN n p (unsafe) increments an enum p by the given integral n -- -- >>> pz @(ReadP Day Id >> Id ... SuccN 5 Id) "2020-07-27" --- PresentT [2020-07-27,2020-07-28,2020-07-29,2020-07-30,2020-07-31,2020-08-01] +-- Val [2020-07-27,2020-07-28,2020-07-29,2020-07-30,2020-07-31,2020-08-01] -- -- >>> pz @(ReadP Day Id >> SuccN (Negate 5) Id) "2020-07-27" --- PresentT 2020-07-22 +-- Val 2020-07-22 -- -- >>> pl @(SuccN 3 'LT) () -- Error SuccN IO e=Prelude.Enum.Ordering.toEnum: bad argument (SuccN 3 LT) --- FailT "SuccN IO e=Prelude.Enum.Ordering.toEnum: bad argument" +-- Fail "SuccN IO e=Prelude.Enum.Ordering.toEnum: bad argument" -- -- >>> pz @(SuccN 2 'LT) () --- PresentT GT +-- Val GT -- -data SuccN n p +data SuccN n p deriving Show -instance (Show a - , Enum a - , Integral (PP n x) - , P n x - , PP p x ~ a - , P p x - ) => P (SuccN n p) x where +instance ( Show a + , Enum a + , Integral (PP n x) + , P n x + , PP p x ~ a + , P p x + ) => P (SuccN n p) x where type PP (SuccN n p) x = PP p x eval _ opts x = do let msg0 = "SuccN" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts x [] + lr <- runPQ NoInline msg0 (Proxy @n) (Proxy @p) opts x [] case lr of Left e -> pure e - Right (n,p,nn,pp) -> do - lr1 <- catchit @_ @E.SomeException (toEnum (fromEnum p + fromIntegral n)) + Right (fromIntegral -> n :: Int,p,nn,pp) -> do + lr1 <- catchit (toEnum (fromEnum p + n)) pure $ case lr1 of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) (litL opts (msg0 <> " " <> show (fromIntegral @_ @Integer n) <> " " <> show p)) [hh nn, hh pp] - Right r -> mkNode opts (PresentT r) (litL opts (msg0 <> " " <> show (fromIntegral @_ @Integer n) <> " " <> show p)) [hh nn, hh pp] + Left e -> mkNode opts (Fail (msg0 <> " " <> e)) (litL opts (msg0 <> " " <> show n <> " " <> show p)) [hh nn, hh pp] + Right r -> mkNode opts (Val r) (litL opts (msg0 <> " " <> show n <> " " <> show p)) [hh nn, hh pp] -- | unbounded 'pred' function -- --- >>> pz @(Pred Id) 13 --- PresentT 12 +-- >>> pz @Pred 13 +-- Val 12 -- --- >>> pz @(Pred Id) LT --- FailT "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" +-- >>> pz @Pred LT +-- Fail "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" -- -data Pred p +data Pred deriving Show -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 +instance ( Show x + , Enum x + ) => P Pred x where + type PP Pred x = 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] + lr <- catchit (pred x) + pure $ case lr of + Left e -> mkNode opts (Fail (msg0 <> " " <> e)) (showL opts x) [] + Right n -> mkNode opts (Val n) (show3 opts msg0 n x) [] -- | bounded 'pred' function -- -- >>> pl @(PredB 'GT Id) LT -- Present GT (PredB out of range) --- PresentT GT +-- Val GT -- -- >>> pl @(PredB 'LT Id) GT -- Present EQ (PredB EQ | GT) --- PresentT EQ +-- Val EQ -- - -data PredB p q +data PredB p q deriving Show instance P (PredBT' q) x => P (PredB' q) x where type PP (PredB' q) x = PP (PredBT' q) x @@ -284,89 +288,117 @@ -- | 'fromEnum' function -- --- >>> pz @(FromEnum Id) 'x' --- PresentT 120 +-- >>> pz @(FromEnum' Id) 'x' +-- Val 120 -- --- >>> pl @(FromEnum ("aa" ==! Id) >> Same 1) "aaaa" +-- >>> pl @(FromEnum' ("aa" ==! Id) >> Same 1) "aaaa" -- False ((>>) False | {0 == 1}) --- FalseT +-- Val False -- --- >>> pl @(FromEnum ("aa" ==! Id) >> ToEnum OrderingP Id) "aaaa" +-- >>> pl @(FromEnum' ("aa" ==! Id) >> ToEnum OrderingP) "aaaa" -- Present CGt ((>>) CGt | {ToEnum CGt | 0}) --- PresentT CGt +-- Val CGt -- --- >>> pl @(Map (FromEnum Id) Id >> Map (ToEnum Char Id) Id) ("abcd" :: String) +-- >>> pl @(Map (FromEnum' Id) >> Map (ToEnum Char)) "abcd" -- Present "abcd" ((>>) "abcd" | {Map "abcd" | [97,98,99,100]}) --- PresentT "abcd" +-- Val "abcd" -- - -data FromEnum p +data FromEnum' p deriving Show -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (FromEnum p) x where - type PP (FromEnum p) x = Int +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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val n) (show3 opts msg0 n p) [hh pp] --- | unsafe 'toEnum' function --- --- >>> pz @(ToEnum Char Id) 120 --- PresentT 'x' +-- | 'fromEnum' function -- --- >>> pl @(Map (FromEnum Id) Id >> Map (Id - 97 >> ToEnum Ordering Id) Id) ("abcde" :: String) --- Error ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2) ([97,98,99,100,101] (>>) rhs failed) --- FailT "ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2)" +-- >>> pz @FromEnum 'x' +-- Val 120 -- --- >>> pl @((ToEnum Day Id *** ToEnum Day Id) >> EnumFromTo (Fst Id) (Snd Id)) (0,5) --- Present [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] ((>>) [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] | {1858-11-17 ... 1858-11-22}) --- PresentT [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] +data FromEnum deriving Show + +instance ( Show x + , Enum x + ) => P FromEnum x where + type PP FromEnum x = Int + eval _ opts x = + let msg0 = "FromEnum" + n = fromEnum x + in pure $ mkNode opts (Val n) (show3 opts msg0 n x) [] + + +-- | unsafe 'toEnum' function that allows you to specify the target @p@ and a pointer to a type @t@ -- -data ToEnum' t p +data ToEnum' t p deriving Show -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 +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 + case getValueLR NoInline opts msg0 pp [] of Left e -> pure e Right p -> do - lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral p) + lr <- catchit (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] + Left e -> mkNode opts (Fail (msg0 <> " " <> e)) (showL opts p) [hh pp] + Right n -> mkNode opts (Val n) (show3 opts msg0 n p) [hh pp] -data ToEnum (t :: Type) p -type ToEnumT (t :: Type) p = ToEnum' (Hole t) p +-- | unsafe 'toEnum' function +-- +-- >>> pz @(ToEnum Char) 120 +-- Val 'x' +-- +-- >>> pl @(Map FromEnum >> Map (Id - 97 >> ToEnum Ordering)) "abcde" +-- Error ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2) (Map(i=3, a=100) excnt=2) +-- Fail "ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2)" +-- +-- >>> pl @((ToEnum Day *** ToEnum Day) >> EnumFromTo Fst Snd) (0,5) +-- Present [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] ((>>) [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] | {1858-11-17 ... 1858-11-22}) +-- Val [1858-11-17,1858-11-18,1858-11-19,1858-11-20,1858-11-21,1858-11-22] +-- +-- >>> pz @(ToEnum (Proxy ())) 0 +-- Val Proxy +-- +-- >>> pz @(ToEnum (Proxy ())) 1 +-- Fail "ToEnum IO e=Proxy.toEnum: 0 expected" +-- +-- >>> pz @(ToEnum (Proxy "sss") >> Pop0 Id ()) 0 +-- Val "sss" +-- +data ToEnum (t :: Type) deriving Show +type ToEnumT (t :: Type) = ToEnum' (Hole t) Id -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)) -data ToEnumBDef' t def +instance P (ToEnumT t) x => P (ToEnum t) x where + type PP (ToEnum t) x = PP (ToEnumT t) x + eval _ = eval (Proxy @(ToEnumT t)) -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 +data ToEnumBDef' t def deriving Show + +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" @@ -374,29 +406,28 @@ Nothing -> do let msg1 = msg0 <> " out of range" pp <- eval (Proxy @def) opts (Proxy @(PP t a)) - pure $ case getValueLR opts msg1 pp [] of + pure $ case getValueLR NoInline 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) [] + Right _ -> mkNodeCopy opts pp msg1 [hh pp] + Just n -> pure $ mkNode opts (Val n) (show3 opts msg0 n a) [] -- | bounded 'toEnum' function -- -- >>> pz @(ToEnumBDef Ordering LT) 2 --- PresentT GT +-- Val GT -- -- >>> pz @(ToEnumBDef Ordering LT) 6 --- PresentT LT +-- Val LT -- -- >>> pl @(ToEnumBDef Ordering 'LT) 123 -- Present LT (ToEnumBDef out of range) --- PresentT LT +-- Val LT -- -- >>> pl @(ToEnumBDef Ordering 'GT) 1 -- Present EQ (ToEnumBDef EQ | 1) --- PresentT EQ +-- Val EQ -- - -data ToEnumBDef (t :: Type) def +data ToEnumBDef (t :: Type) def deriving Show type ToEnumBDefT (t :: Type) def = ToEnumBDef' (Hole t) def instance P (ToEnumBDefT t def) x => P (ToEnumBDef t def) x where @@ -406,18 +437,18 @@ -- | bounded 'toEnum' function -- -- >>> pz @(ToEnumBFail Ordering) 6 --- FailT "ToEnum bounded" +-- Fail "ToEnum bounded" -- -- >>> pl @(ToEnumBFail Ordering) 1 -- Present EQ (ToEnumBDef EQ | 1) --- PresentT EQ +-- Val EQ -- -- >>> pl @(ToEnumBFail Ordering) 44 -- Error ToEnum bounded (ToEnumBDef out of range) --- FailT "ToEnum bounded" +-- Fail "ToEnum bounded" -- -data ToEnumBFail (t :: Type) -type ToEnumBFailT (t :: Type) = ToEnumBDef' (Hole t) (Failp "ToEnum bounded") +data ToEnumBFail (t :: Type) deriving Show +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 @@ -426,37 +457,37 @@ -- | similar to 'enumFromTo' -- -- >>> pz @(EnumFromTo 'GT 'LT) () --- PresentT [] +-- Val [] -- --- >>> pz @(EnumFromTo (Pred Id) (Succ Id)) (SG.Max 10) --- PresentT [Max {getMax = 9},Max {getMax = 10},Max {getMax = 11}] +-- >>> pz @(EnumFromTo Pred Succ) (SG.Max 10) +-- Val [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")] +-- >>> pz @(EnumFromTo 1 20 >> Map '(Id, (If (Id `Mod` 3 == 0) "Fizz" "" <> If (Id `Mod` 5 == 0) "Buzz" ""))) 123 +-- Val [(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")] -- -- >>> pl @(EnumFromTo (Pure SG.Min 9) (Pure _ 13)) () -- Present [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] (Min {getMin = 9} ... Min {getMin = 13}) --- PresentT [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] +-- Val [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] -- -- >>> pl @(EnumFromTo (Wrap (SG.Min _) 9) (Wrap _ 13)) () -- Present [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] (Min {getMin = 9} ... Min {getMin = 13}) --- PresentT [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] +-- Val [Min {getMin = 9},Min {getMin = 10},Min {getMin = 11},Min {getMin = 12},Min {getMin = 13}] -- -data EnumFromTo p q +data EnumFromTo p q deriving Show -- | similar to 'enumFromTo' -- -- >>> pz @(2 ... 5) () --- PresentT [2,3,4,5] +-- Val [2,3,4,5] -- -- >>> pz @('LT ... 'GT) () --- PresentT [LT,EQ,GT] +-- Val [LT,EQ,GT] -- -- >>> pz @('Just (MkDay '(2020, 1, 2)) ... 'Just (MkDay '(2020, 1, 7))) () --- PresentT [2020-01-02,2020-01-03,2020-01-04,2020-01-05,2020-01-06,2020-01-07] +-- Val [2020-01-02,2020-01-03,2020-01-04,2020-01-05,2020-01-06,2020-01-07] -- -data p ... q -infix 4 ... +data p ... q deriving Show +infix 7 ... type EnumFromToT p q = EnumFromTo p q @@ -464,49 +495,84 @@ 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 +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 [] + lr <- runPQ NoInline 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] + Right (p,q,pp,qq) -> mkNode opts (Val (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 (10 >> ToEnum Day) (20 >> ToEnum Day) (70 >> ToEnum Day)) () +-- Val [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] +-- Val [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 +data EnumFromThenTo p q r deriving Show -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 +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 [] + lr <- runPQ NoInline 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 + pure $ case getValueLR NoInline 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] + mkNode opts (Val (enumFromThenTo p q r)) (msg0 <> " [" <> showL opts p <> ", " <> showL opts q <> " .. " <> showL opts r <> "]") [hh pp, hh qq, hh rr] + +-- | universe of enum using the type pointed to by @p@ +-- +-- >>> pl @(Universe' Id) LT +-- Present [LT,EQ,GT] (Universe [LT .. GT]) +-- Val [LT,EQ,GT] +-- +data Universe' p deriving Show + +instance ( PP p x ~ a + , Show a + , Enum a + , Bounded a + ) => P (Universe' p) x where + type PP (Universe' p) x = [PP p x] + eval _ opts _ = + let msg0 = "Universe" + u = [mn .. mx] + mn = minBound @a + mx = maxBound @a + in pure $ mkNode opts (Val u) (msg0 <> " [" <> showL opts mn <> " .. " <> showL opts mx <> "]") [] + +-- | get universe of an enum of type @t@ +-- +-- >>> pz @(Universe Ordering) () +-- Val [LT,EQ,GT] +-- +data Universe (t :: Type) deriving Show +type UniverseT (t :: Type) = Universe' (Hole t) + +instance P (UniverseT t) x => P (Universe t) x where + type PP (Universe t) x = PP (UniverseT t) x + eval _ = eval (Proxy @(UniverseT t)) + +
src/Predicate/Data/Extra.hs view
@@ -1,1053 +1,549 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} -{-# LANGUAGE NoStarIsType #-} -{- | - extra promoted functions --} -module Predicate.Data.Extra ( - - Pure2 - , type (<$) - , type (<*) - , type (*>) - , FMapFst - , FMapSnd - , Sequence - , Traverse - , Join - , type (<|>) - , Extract - , Duplicate - - , type ($$) - , type ($&) - , Skip - , type (|>) - , type (>|) - , type (>|>) - - , HeadDef - , HeadFail - , TailDef - , TailFail - , LastDef - , LastFail - , InitDef - , InitFail - - , Coerce2 - - , ProxyT - , ProxyT' - - , Prime - , PrimeNext - , Luhn - - , Catch - , Catch' - , Dot - , RDot - , K - ) where -import Predicate.Core -import Predicate.Util -import Predicate.Data.List (Uncons, Unsnoc) -import Predicate.Data.Maybe (JustDef, JustFail) -import GHC.TypeLits (ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import Data.Proxy -import Control.Applicative -import Control.Monad (join) -import Data.Kind (Type) -import Control.Comonad -import Data.Coerce -import Control.Lens hiding (iall) - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> import qualified Data.Text as T --- >>> import qualified Data.Sequence as Seq --- >>> import Predicate.Prelude --- >>> import qualified Data.Semigroup as SG --- >>> import Data.Functor.Identity --- >>> import Data.These - --- | lift pure over a Functor --- --- >>> pz @(Pure2 (Either String)) [1,2,4] --- PresentT [Right 1,Right 2,Right 4] --- --- >>> pl @(Pure2 []) (Just 10) --- Present Just [10] (Pure2 Just [10] | Just 10) --- PresentT (Just [10]) --- --- >>> pl @(Pure2 SG.Sum) (Just 20) --- Present Just (Sum {getSum = 20}) (Pure2 Just (Sum {getSum = 20}) | Just 20) --- PresentT (Just (Sum {getSum = 20})) --- -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 'Control.Applicative.<$' --- --- >>> pz @(Fst Id <$ Snd Id) ("abc",Just 20) --- PresentT (Just "abc") --- --- >>> pl @(Fst Id <$ Snd Id) (4,These "xxx" 'a') --- Present These "xxx" 4 ((<$) 4) --- PresentT (These "xxx" 4) --- --- >>> pl @(Fst Id <$ Snd Id) (4,This 'a') --- Present This 'a' ((<$) 4) --- PresentT (This 'a') --- --- >>> pl @(Fst Id <$ Snd Id) (4,Just 'a') --- Present Just 4 ((<$) 4) --- PresentT (Just 4) --- --- >>> pl @(Fst Id <$ Snd Id) (4,Nothing @Int) --- Present Nothing ((<$) 4) --- PresentT Nothing --- --- >>> pl @('True <$ Id) [1..4] --- Present [True,True,True,True] ((<$) True) --- PresentT [True,True,True,True] --- --- >>> import Data.Functor.Compose --- >>> pl @(Char1 "ab" <$ Id) (Compose $ Just [1..4]) --- Present Compose (Just "aaaa") ((<$) 'a') --- PresentT (Compose (Just "aaaa")) --- --- >>> pl @(Snd Id <$ Fst Id) (Just 10,'x') --- Present Just 'x' ((<$) 'x') --- PresentT (Just 'x') --- -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] - --- | similar to Applicative 'Control.Applicative.<*' --- --- >>> pl @(Fst Id <* Snd Id) (Just 4,Just 'a') --- Present Just 4 ((<*) Just 4 | p=Just 4 | q=Just 'a') --- PresentT (Just 4) --- --- >>> pz @(Fst Id <* Snd Id) (Just "abc",Just 20) --- PresentT (Just "abc") --- -data p <* q -infixl 4 <* - -type ArrowRT p q = q <* p - --- | similar to Applicative 'Control.Applicative.*>' --- --- >>> pl @(Fst Id *> Snd Id) (Just 4,Just 'a') --- Present Just 'a' ((<*) Just 'a' | p=Just 'a' | q=Just 4) --- PresentT (Just 'a') --- -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 --- --- >>> pl @(Fst Id <|> Snd Id) (Just "cdef",Just "ab") --- Present Just "cdef" ((<|>) Just "cdef" | p=Just "cdef" | q=Just "ab") --- PresentT (Just "cdef") --- --- >>> pl @(Fst Id <|> Snd Id) ("cdef","ab"::String) --- Present "cdefab" ((<|>) "cdefab" | p="cdef" | q="ab") --- PresentT "cdefab" --- -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 --- --- >>> pl @Extract (10,"hello") --- Present "hello" (Extract "hello" | (10,"hello")) --- PresentT "hello" --- -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.$' --- --- >>> :m + Text.Show.Functions --- >>> 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.&' --- --- >>> :m + Text.Show.Functions --- >>> 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 '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 msg = "Sequence" - d = sequenceA tfa - in pure $ mkNode opts (PresentT d) (msg <> " " <> showL opts d <> showVerbose opts " | " tfa) [] - --- | like 'traverse' --- --- >>> pl @(Traverse (If (Gt 3) (Pure Maybe Id) (EmptyT Maybe Id)) Id) [1..5] --- Present Nothing ((>>) Nothing | {Sequence Nothing | [Nothing,Nothing,Nothing,Just 4,Just 5]}) --- PresentT Nothing --- --- >>> pl @(Traverse (MaybeBool (Le 3) Id) Id) [1..5] --- Present Nothing ((>>) Nothing | {Sequence Nothing | [Just 1,Just 2,Just 3,Nothing,Nothing]}) --- PresentT Nothing --- --- >>> pl @(Traverse (If (Gt 0) (Pure Maybe Id) (EmptyT Maybe Id)) Id) [1..5] --- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) --- PresentT (Just [1,2,3,4,5]) --- --- >>> pl @(Traverse (If (Gt 0) (Pure Maybe Id) (MkNothing _)) Id) [1..5] --- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) --- PresentT (Just [1,2,3,4,5]) --- --- >>> pl @(Traverse (MaybeBool (Id >= 0) Id) Id) [1..5] --- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) --- PresentT (Just [1,2,3,4,5]) --- --- >>> pl @(Traverse (MaybeBool (Id <= 3) Id) Id) [1..5] --- Present Nothing ((>>) Nothing | {Sequence Nothing | [Just 1,Just 2,Just 3,Nothing,Nothing]}) --- PresentT Nothing --- -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 fmap fst --- --- >>> pz @FMapFst (Just (13,"Asf")) --- PresentT (Just 13) --- --- >>> pl @FMapFst (Just (1,'x')) --- Present Just 1 (FMapFst) --- PresentT (Just 1) --- --- >>> pl @FMapFst [(1,'x'), (2,'y'), (3,'z')] --- Present [1,2,3] (FMapFst) --- PresentT [1,2,3] --- - --- 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) --- --- >>> pl @FMapSnd (Just (1,'x')) --- Present Just 'x' (FMapSnd) --- PresentT (Just 'x') --- --- >>> pl @FMapSnd (Nothing @(Char,Int)) --- Present Nothing (FMapSnd) --- PresentT Nothing --- --- >>> pl @FMapSnd (Right (1,'x')) --- Present Right 'x' (FMapSnd) --- PresentT (Right 'x') --- --- >>> pl @FMapSnd (Left @_ @(Int,Double) "x") --- Present Left "x" (FMapSnd) --- PresentT (Left "x") --- - -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" [] - --- | just run the effect ignoring the result passing the original value through --- 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] - --- | run \'p\' for the effect and then run \'q\' using that original value -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)) - --- | run run \'p\' and then \'q\' for the effect but using the result from \'p\' -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)) - --- | run both \'p\' and \'q\' for their effects but ignoring the results -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)) - --- | takes the head of a list-like object or uses the given default value --- --- 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' --- --- >>> 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 () --- --- >>> pl @(HeadDef 9 (Fst Id)) ([],True) --- Present 9 (JustDef Nothing) --- PresentT 9 --- --- >>> pl @(HeadDef 9 (Fst Id)) ([1..5],True) --- Present 1 (JustDef Just) --- PresentT 1 --- --- >>> pl @(HeadDef 3 (Fst Id)) ([10..15],True) --- Present 10 (JustDef Just) --- PresentT 10 --- --- >>> pl @(HeadDef 12 (Fst Id) >> Le 6) ([],True) --- False ((>>) False | {12 <= 6}) --- FalseT --- --- >>> pl @(HeadDef 1 (Fst Id) >> Le 6) ([],True) --- True ((>>) True | {1 <= 6}) --- TrueT --- --- >>> pl @(HeadDef 10 (Fst Id) >> Le 6) ([],True) --- False ((>>) False | {10 <= 6}) --- FalseT --- --- >>> pl @(HeadDef (MEmptyT _) Id) (map (:[]) ([] :: [Int])) --- Present [] (JustDef Nothing) --- PresentT [] --- --- >>> pl @(HeadDef (MEmptyT _) Id) (map (:[]) ([10..14] :: [Int])) --- Present [10] (JustDef Just) --- PresentT [10] --- --- >>> pl @(HeadDef (Fst Id) (Snd Id)) (99,[10..14]) --- Present 10 (JustDef Just) --- PresentT 10 --- --- >>> pl @(HeadDef (Fst Id) (Snd Id)) (99,[] :: [Int]) --- Present 99 (JustDef Nothing) --- PresentT 99 --- --- >>> pl @(HeadDef 43 (Snd Id)) (99,[] :: [Int]) --- Present 43 (JustDef Nothing) --- PresentT 43 --- -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 fails with the given message --- --- 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" --- --- >>> pl @(HeadFail "zz" (Fst Id) >> Le 6) ([],True) --- Error zz ((>>) lhs failed) --- FailT "zz" --- --- >>> pl @((HeadFail "failed1" (Fst Id) >> Le 6) || 'False) ([],True) --- Error failed1 (||) --- FailT "failed1" --- --- >>> pl @((Fst Id >> HeadFail "failed2" Id >> Le (6 -% 1)) || 'False) ([-9],True) --- True (True || False) --- TrueT --- --- >>> pl @(HeadFail "Asdf" Id) ([] :: [()]) -- breaks otherwise --- Error Asdf (JustFail Nothing) --- FailT "Asdf" --- --- >>> pl @(HeadFail (PrintF "msg=%s def" (Fst Id)) (Snd Id)) ("Abc" :: String,[]::[Int]) --- Error msg=Abc def (JustFail Nothing) --- FailT "msg=Abc def" --- - -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)) - --- | takes the tail of a list-like object or uses the given default value --- --- >>> pl @(TailDef '[9,7] (Fst Id)) ([],True) --- Present [9,7] (JustDef Nothing) --- PresentT [9,7] --- --- >>> pl @(TailDef '[9,7] (Fst Id)) ([1..5],True) --- Present [2,3,4,5] (JustDef Just) --- PresentT [2,3,4,5] --- --- >>> pl @(TailDef '[3] (Fst Id)) ([10..15],True) --- Present [11,12,13,14,15] (JustDef Just) --- PresentT [11,12,13,14,15] --- - -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)) - - --- | takes the tail of a list-like object or fails with the given message --- --- >>> pl @(TailFail (PrintT "a=%d b=%s" (Snd Id)) (Fst Id)) ([]::[()],(4::Int,"someval" :: String)) --- Error a=4 b=someval (JustFail Nothing) --- FailT "a=4 b=someval" --- - -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)) - --- | takes the last value of a list-like object or a default value --- --- >>> pl @(LastDef 9 (Fst Id)) ([],True) --- Present 9 (JustDef Nothing) --- PresentT 9 --- --- >>> pl @(LastDef 9 (Fst Id)) ([1..5],True) --- Present 5 (JustDef Just) --- PresentT 5 --- --- >>> pl @(LastDef 3 (Fst Id)) ([10..15],True) --- Present 15 (JustDef Just) --- PresentT 15 --- --- >>> pl @(LastDef 0 Id) [1..12] --- Present 12 (JustDef Just) --- PresentT 12 --- --- >>> pl @(LastDef 0 Id) [] --- Present 0 (JustDef Nothing) --- PresentT 0 --- - -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)) - --- | takes the init of a list-like object or fails with the given message -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)) - --- | takes the init of a list-like object or uses the given default value --- --- >>> pl @(InitDef '[9,7] (Fst Id)) ([],True) --- Present [9,7] (JustDef Nothing) --- PresentT [9,7] --- --- >>> pl @(InitDef '[9,7] (Fst Id)) ([1..5],True) --- Present [1,2,3,4] (JustDef Just) --- PresentT [1,2,3,4] --- --- >>> pl @(InitDef '[3] (Fst Id)) ([10..15],True) --- Present [10,11,12,13,14] (JustDef Just) --- PresentT [10,11,12,13,14] --- -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)) - --- | takes the init of a list-like object or fails with the given message -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)) - -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) - --- | 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 @(ScanN 4 (PrimeNext Id) Id) 3 --- PresentT [3,5,7,11,13] --- -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] - --- | 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 - --- | 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 --- --- >>> pl @(Coerce2 (SG.Sum Int)) (Just (10 :: Int)) --- Present Just (Sum {getSum = 10}) (Coerce2 Just (Sum {getSum = 10}) | Just 10) --- PresentT (Just (Sum {getSum = 10})) --- -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) [] - -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)) - - - --- 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 - --- | run an expression \'p\' and on failure run \'q\' --- --- >>> pz @(Catch (Succ Id) (Fst Id >> Second (ShowP Id) >> PrintT "%s %s" Id >> 'LT)) GT --- PresentT LT --- --- >>> pz @(Len > 1 && Catch (Id !! 3 == 66) 'False) [1,2] --- FalseT --- --- >>> pl @(Catch (Resplit "\\d+(" Id) (Snd Id >> MEmptyP)) "123" --- Present [] (Catch caught exception[Regex failed to compile]) --- PresentT [] --- --- >>> pl @(Catch (OneP Id) 99) [10,11] --- Present 99 (Catch caught exception[OneP 2 elements]) --- PresentT 99 --- --- >>> pl @(Catch (OneP Id) 99) [10] --- Present 10 (Catch did not fire) --- PresentT 10 --- --- >>> pl @(Catch (OneP Id) 'True) [False] -- cant know that this is FalseT cos is driven by type of the list not the 'True part --- Present False (Catch did not fire) --- PresentT False --- --- >>> pl @(Catch (OneP Id) 'False) [True,True,False] --- False (Catch caught exception[OneP 3 elements]) --- FalseT --- --- >>> pl @(Catch (OneP Id) 'True) [] --- True (Catch caught exception[OneP empty]) --- TrueT --- -data Catch p q - --- | run an expression \'p\' and on failure print a custom error \'s\' using the error string and the input value --- --- >>> 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 --- --- >>> pl @(Catch' (Failt Int "someval") (PrintT "msg=%s caught(%03d)" Id)) (44 :: Int) --- Error msg=someval caught(044) (Catch default condition failed) --- FailT "msg=someval caught(044)" --- --- >>> pl @(Catch' (OneP Id) (Second (ShowP Id) >> PrintT "msg=%s caught(%s)" Id)) [10,12,13] --- Error msg=OneP 3 elements caught([10,12,13]) (Catch default condition failed) --- FailT "msg=OneP 3 elements caught([10,12,13])" --- --- >>> pl @(Catch' (OneP Id) (PrintT "msg=%s caught(%s)" (Second (ShowP Id)))) [10] --- Present 10 (Catch did not fire) --- PresentT 10 --- --- >>> pl @(Catch' (OneP Id) (PrintT "msg=%s err s=%s" (Second (ShowP Id)))) [10,11] --- Error msg=OneP 2 elements err s=[10,11] (Catch default condition failed) --- FailT "msg=OneP 2 elements err s=[10,11]" --- -data Catch' p s -type CatchT' p s = Catch p (FailCatchT s) -- eg set eg s=PrintF "%d" Id or PrintF "%s" (ShowP Id) -type FailCatchT 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] - - - --- | 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 version of '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) - --- | 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 '("abc",((1,(2,9,10)),(3,4)))) --- 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 @(MsgI "K " p)) - --- 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) - - - +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +-- | extra promoted functions +module Predicate.Data.Extra ( + -- ** list functions + HeadDef + , HeadFail + , TailDef + , TailFail + , LastDef + , LastFail + , InitDef + , InitFail + + , HeadMay + , LastMay + , TailMay + , InitMay + + , PartitionsBy + , IMap + , IList + + -- ** primes + , IsPrime + , PrimeNext + , PrimePrev + , PrimeFactors + , Primes + + -- ** luhn check + , IsLuhn + + ) where +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import Predicate.Data.List (Head, Uncons, Unsnoc, SortBy, Zip, GroupBy, SortOn, ZipWith) +import Predicate.Data.Enum (type (...)) +import Predicate.Data.Numeric (type (-)) +import Predicate.Data.Maybe (JustDef, JustFail) +import Predicate.Data.Lifted (FMap) +import Control.Lens +import qualified Safe (headNote, cycleNote) +import Data.Proxy (Proxy(..)) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> import qualified Data.Text as T +-- >>> import qualified Data.Sequence as Seq +-- >>> import Predicate.Prelude +-- >>> import qualified Data.Semigroup as SG +-- >>> import Data.These + +-- | takes the head of a list-like object or uses the given default value +-- +-- see 'ConsT' for other supported types eg 'Data.Sequence.Seq' +-- +-- >>> pz @(HeadDef 444 Id) [] +-- Val 444 +-- +-- >>> pz @(HeadDef 444 Id) [1..5] +-- Val 1 +-- +-- >>> pz @(HeadDef 444 Id) [1..5] +-- Val 1 +-- +-- >>> pz @(HeadDef (C "w") Id) (Seq.fromList "abcdef") +-- Val 'a' +-- +-- >>> pz @(HeadDef (C "w") Id) Seq.empty +-- Val 'w' +-- +-- >>> pz @(HeadDef (MEmptyT _) Id) ([] :: [SG.Sum Int]) +-- Val (Sum {getSum = 0}) +-- +-- >>> pz @(HeadDef (MEmptyT String) '["abc","def","asdfadf"]) () +-- Val "abc" +-- +-- >>> pz @(HeadDef (MEmptyT _) Snd) (123,["abc","def","asdfadf"]) +-- Val "abc" +-- +-- >>> pz @(HeadDef (MEmptyT _) Snd) (123,[]) +-- Val () +-- +-- >>> pl @(HeadDef 9 Fst) ([],True) +-- Present 9 (JustDef Nothing) +-- Val 9 +-- +-- >>> pl @(HeadDef 99 Fst) ([10..15],True) +-- Present 10 (JustDef Just) +-- Val 10 +-- +-- >>> pl @(HeadDef 12 Fst >> Le 6) ([],True) +-- False ((>>) False | {12 <= 6}) +-- Val False +-- +-- >>> pl @(HeadDef 1 Fst >> Le 6) ([],True) +-- True ((>>) True | {1 <= 6}) +-- Val True +-- +-- >>> pl @(HeadDef 10 Fst >> Le 6) ([],True) +-- False ((>>) False | {10 <= 6}) +-- Val False +-- +-- >>> pl @(HeadDef (MEmptyT _) Id) (map (:[]) ([] :: [Int])) +-- Present [] (JustDef Nothing) +-- Val [] +-- +-- >>> pl @(HeadDef (MEmptyT _) Id) (map (:[]) ([10..14] :: [Int])) +-- Present [10] (JustDef Just) +-- Val [10] +-- +-- >>> pl @(HeadDef Fst Snd) (99,[10..14]) +-- Present 10 (JustDef Just) +-- Val 10 +-- +-- >>> pl @(HeadDef Fst Snd) (99,[] :: [Int]) +-- Present 99 (JustDef Nothing) +-- Val 99 +-- +-- >>> pl @(HeadDef 43 Snd) (99,[] :: [Int]) +-- Present 43 (JustDef Nothing) +-- Val 43 +-- +data HeadDef p q deriving Show +type HeadDefT p q = JustDef p (q >> Uncons >> FMap Fst) + +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 fails with the given message +-- +-- see 'ConsT' for other supported types eg 'Data.Sequence.Seq' +-- +-- >>> pz @(HeadFail "oops" Id) ["abc","def","asdfadf"] +-- Val "abc" +-- +-- >>> pz @(HeadFail "empty list" Id) [] +-- Fail "empty list" +-- +-- >>> pl @(HeadFail "zz" Fst >> Le 6) ([],True) +-- Error zz (JustFail Nothing) +-- Fail "zz" +-- +-- >>> pl @((HeadFail "failed1" Fst >> Le 6) || 'False) ([],True) +-- Error failed1 (JustFail Nothing | ||) +-- Fail "failed1" +-- +-- >>> pl @((Fst >> HeadFail "failed2" Id >> Le (6 -% 1)) || 'False) ([-9],True) +-- True (True || False) +-- Val True +-- +-- >>> pl @(HeadFail "Asdf" Id) ([] :: [()]) -- breaks otherwise +-- Error Asdf (JustFail Nothing) +-- Fail "Asdf" +-- +-- >>> pl @(HeadFail (PrintF "msg=%s def" Fst) Snd) ("Abc",[]) +-- Error msg=Abc def (JustFail Nothing) +-- Fail "msg=Abc def" +-- +data HeadFail msg q deriving Show +type HeadFailT msg q = JustFail msg (q >> Uncons >> FMap Fst) + +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)) + +-- | takes the tail of a list-like object or uses the given default value +-- +-- >>> pl @(TailDef '[9,7] Fst) ([],True) +-- Present [9,7] (JustDef Nothing) +-- Val [9,7] +-- +-- >>> pl @(TailDef '[9,7] Fst) ([1..5],True) +-- Present [2,3,4,5] (JustDef Just) +-- Val [2,3,4,5] +-- +-- >>> pl @(TailDef '[3] Fst) ([10..15],True) +-- Present [11,12,13,14,15] (JustDef Just) +-- Val [11,12,13,14,15] +-- +data TailDef p q deriving Show +type TailDefT p q = JustDef p (q >> Uncons >> FMap Snd) + +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)) + + +-- | takes the tail of a list-like object or fails with the given message +-- +-- >>> pl @(TailFail (PrintT "a=%d b=%s" Snd) Fst) ([]::[()],(4,"someval")) +-- Error a=4 b=someval (JustFail Nothing) +-- Fail "a=4 b=someval" +-- +data TailFail msg q deriving Show +type TailFailT msg q = JustFail msg (q >> Uncons >> FMap Snd) + +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)) + +-- | takes the last value of a list-like object or a default value +-- +-- >>> pl @(LastDef 9 Fst) ([],True) +-- Present 9 (JustDef Nothing) +-- Val 9 +-- +-- >>> pl @(LastDef 9 Fst) ([1..5],True) +-- Present 5 (JustDef Just) +-- Val 5 +-- +-- >>> pl @(LastDef 3 Fst) ([10..15],True) +-- Present 15 (JustDef Just) +-- Val 15 +-- +-- >>> pl @(LastDef 0 Id) [1..12] +-- Present 12 (JustDef Just) +-- Val 12 +-- +-- >>> pl @(LastDef 0 Id) [] +-- Present 0 (JustDef Nothing) +-- Val 0 +-- +data LastDef p q deriving Show +type LastDefT p q = JustDef p (q >> Unsnoc >> FMap Snd) + +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)) + +-- | takes the init of a list-like object or fails with the given message +data LastFail msg q deriving Show +type LastFailT msg q = JustFail msg (q >> Unsnoc >> FMap Snd) + +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)) + +-- | takes the init of a list-like object or uses the given default value +-- +-- >>> pl @(InitDef '[9,7] Fst) ([],True) +-- Present [9,7] (JustDef Nothing) +-- Val [9,7] +-- +-- >>> pl @(InitDef '[9,7] Fst) ([1..5],True) +-- Present [1,2,3,4] (JustDef Just) +-- Val [1,2,3,4] +-- +-- >>> pl @(InitDef '[3] Fst) ([10..15],True) +-- Present [10,11,12,13,14] (JustDef Just) +-- Val [10,11,12,13,14] +-- +data InitDef p q deriving Show +type InitDefT p q = JustDef p (q >> Unsnoc >> FMap Fst) + +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)) + +-- | takes the init of a list-like object or fails with the given message +data InitFail msg q deriving Show +type InitFailT msg q = JustFail msg (q >> Unsnoc >> FMap Fst) + +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)) + +-- | similar to 'Safe.headMay' +-- +-- >>> pl @HeadMay [] +-- Present Nothing ((>>) Nothing | {FMap <skipped>}) +-- Val Nothing +-- +-- >>> pl @HeadMay [99,7,3] +-- Present Just 99 ((>>) Just 99 | {FMap Fst 99 | (99,[7,3])}) +-- Val (Just 99) +-- +data HeadMay deriving Show +type HeadMayT = Uncons >> FMap Fst + +instance P HeadMayT x => P HeadMay x where + type PP HeadMay x = PP HeadMayT x + eval _ = eval (Proxy @HeadMayT) + +-- | similar to 'Safe.lastMay' +-- +-- >>> pz @LastMay "hello" +-- Val (Just 'o') +-- +data LastMay deriving Show +type LastMayT = Unsnoc >> FMap Snd + +instance P LastMayT x => P LastMay x where + type PP LastMay x = PP LastMayT x + eval _ = eval (Proxy @LastMayT) + +-- | similar to 'Safe.tailMay' +-- +-- >>> pz @TailMay "hello" +-- Val (Just "ello") +-- +data TailMay deriving Show +type TailMayT = Uncons >> FMap Snd + +instance P TailMayT x => P TailMay x where + type PP TailMay x = PP TailMayT x + eval _ = eval (Proxy @TailMayT) + +-- | similar to 'Safe.initMay' +-- +-- >>> pz @InitMay "hello" +-- Val (Just "hell") +-- +data InitMay deriving Show +type InitMayT = Unsnoc >> FMap Fst + +instance P InitMayT x => P InitMay x where + type PP InitMay x = PP InitMayT x + eval _ = eval (Proxy @InitMayT) + +-- | a predicate on prime numbers +-- +-- >>> pz @IsPrime 2 +-- Val True +-- +-- >>> pz @(Map '(Id,IsPrime)) [0..12] +-- Val [(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 IsPrime deriving Show + +instance ( x ~ a + , Show a + , Integral a + ) => P IsPrime x where + type PP IsPrime x = Bool + eval _ opts x = + let msg0 = "IsPrime" + b = x > 1 && isPrime (fromIntegral x) + in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " x) [] + +-- | get the next prime number +-- +-- >>> pz @PrimeNext 6 +-- Val 7 +-- +-- >>> pz @(ScanN 4 PrimeNext Id) 3 +-- Val [3,5,7,11,13] +-- +data PrimeNext deriving Show + +instance ( Show x + , Integral x + ) => P PrimeNext x where + type PP PrimeNext x = Integer + eval _ opts x = + let msg0 = "PrimeNext" + ret = Safe.headNote msg0 $ dropWhile (<= fromIntegral x) primeStream + in pure $ mkNode opts (Val ret) (msg0 <> showVerbose opts " | " x) [] + +-- | get the next prime number +-- +-- >>> pz @PrimePrev 6 +-- Val 5 +-- +-- >>> pz @PrimePrev 5 +-- Val 3 +-- +-- >>> pz @PrimePrev (-206) +-- Val 2 +-- +-- >>> pz @(ScanN 6 PrimePrev Id) 11 +-- Val [11,7,5,3,2,2,2] +-- +data PrimePrev deriving Show + +instance ( Show x + , Integral x + ) => P PrimePrev x where + type PP PrimePrev x = Integer + eval _ opts x = + let msg0 = "PrimePrev" + ret = case unsnoc $ takeWhile (< fromIntegral x) primeStream of + Just (_,p) -> p + Nothing -> 2 + in pure $ mkNode opts (Val ret) (msg0 <> showVerbose opts " | " x) [] + +-- | get list of @n@ primes +-- +-- >>> pz @(Primes Id) 5 +-- Val [2,3,5,7,11] +-- +data Primes n deriving Show + +instance ( Integral (PP n x) + , P n x + ) => P (Primes n) x where + type PP (Primes n) x = [Integer] + eval _ opts x = do + let msg0 = "Primes" + nn <- eval (Proxy @n) opts x + pure $ case getValueLR NoInline opts msg0 nn [] of + Left e -> e + Right (fromIntegral -> n) -> + let ret = take n primeStream + in mkNode opts (Val ret) (msg0 <> showVerbose opts " | " n) [hh nn] + +-- | prime factorisation of positive numbers +-- +-- >>> pz @(PrimeFactors Id) 17 +-- Val [17] +-- +-- >>> pz @(PrimeFactors Id) 1 +-- Val [1] +-- +-- >>> pz @(PrimeFactors Id) 30 +-- Val [2,3,5] +-- +-- >>> pz @(PrimeFactors Id) 64 +-- Val [2,2,2,2,2,2] +-- +-- >>> pz @(PrimeFactors Id) (-30) +-- Fail "PrimeFactors number<=0" +-- +data PrimeFactors n deriving Show + +instance ( Integral (PP n x) + , P n x + ) => P (PrimeFactors n) x where + type PP (PrimeFactors n) x = [Integer] + eval _ opts x = do + let msg0 = "PrimeFactors" + nn <- eval (Proxy @n) opts x + pure $ case getValueLR NoInline opts msg0 nn [] of + Left e -> e + Right (fromIntegral -> n :: Integer) + | n <= 0 -> mkNode opts (Fail (msg0 <> " number<=0")) "" [hh nn] + | otherwise -> + let ret = primeFactors n + in mkNode opts (Val ret) (msg0 <> showVerbose opts " | " n) [hh nn] + +-- | IsLuhn predicate check on last digit +-- +-- >>> pz @IsLuhn [1,2,3,0] +-- Val True +-- +-- >>> pz @IsLuhn [1,2,3,4] +-- Val False +-- +-- >>> pz @(GuardSimple IsLuhn) [15,4,3,1,99] +-- Fail "(IsLuhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99])" +-- +-- >>> pl @IsLuhn [15,4,3,1,99] +-- False (IsLuhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99]) +-- Val False +-- +data IsLuhn deriving Show + +instance x ~ [Int] + => P IsLuhn x where + type PP IsLuhn x = Bool + eval _ opts x = + let msg0 = "IsLuhn" + in pure $ case chkSize opts msg0 x [] of + Left e -> e + Right _ -> + let xs = zipWith (*) (reverse x) (Safe.cycleNote msg0 [1,2]) + ys = map (\w -> if w>=10 then w-9 else w) xs + z = sum ys + ret = z `mod` 10 + in if ret == 0 then mkNodeB opts True (msg0 <> " | " <> showL opts x) [] + else mkNodeB opts False (msg0 <> " map=" <> showL opts ys <> " sum=" <> showL opts z <> " ret=" <> showL opts ret <> showVerbose opts " | " x) [] + +-- | experimental: sorts then partitions and then sorts each partitions based on the leftmost occurring value in the original list +-- if the existing order of data is fine then use 'Predicate.Data.List.GroupBy' as you do not need this +-- +-- >>> pz @(PartitionsBy (Fst ==! Snd) (L11 == L21) Id) [10,9,9,1,9] +-- Val [[10],[9,9,9],[1]] +-- +-- >>> pz @(PartitionsBy OrdA (L11 < L21) Id) "efaffabec" +-- Val ["a","f","f","abce","ef"] +-- +-- >>> pz @(PartitionsBy 'GT 'True Id) "efaffabec" +-- Val ["cebaffafe"] +-- +-- >>> pz @(PartitionsBy 'GT 'False Id) "efaffabec" +-- Val ["e","f","a","f","f","a","b","e","c"] +-- +-- >>> pz @(PartitionsBy (Fst ==! Snd) (L12 > L22) Id) [10,9,9,1,9,4] +-- Val [[9],[1],[9,10],[4,9]] +-- +-- >>> pz @(PartitionsBy (L11 ==! L21) (L12 > L22) Id) "eddadc" +-- Val ["d","a","de","cd"] +-- +-- >>> pz @(PartitionsBy (L11 ==! L21) (L11 < L21) Id) [10,9,9,1,9,4] +-- Val [[9],[1,4,9],[9,10]] +-- +data PartitionsBy p q r deriving Show +type PartitionsByT p q r = SortBy p (Zip r (0 ... (Length r - 1))) >> GroupBy q Id >> SortOn (Head >> Snd) Id >> Map (Map Fst) + +instance P (PartitionsByT p q r) x => P (PartitionsBy p q r) x where + type PP (PartitionsBy p q r) x = PP (PartitionsByT p q r) x + eval _ = eval (Proxy @(PartitionsByT p q r)) + +-- | add an index to map +-- +-- >>> pz @(Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" >> Map (Snd >> IMap (GuardBool (PrintT "bad value=%d %s" Id) (Snd >> ReadP Int Id < 255)) Id)) "123.222.999.3" +-- Fail "bad value=2 999" +-- +-- >>> pz @(Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" >> Map (Snd >> IMap (GuardBool (PrintT "bad value=%d %s" Id) (Snd >> ReadP Int Id < 255)) Id)) "123.222.99.3" +-- Val [[True,True,True,True]] +-- +data IMap p q deriving Show +type IMapT p q = ZipWith p (0 ... (Length q - 1)) q + +instance P (IMapT p q) x => P (IMap p q) x where + type PP (IMap p q) x = PP (IMapT p q) x + eval _ = eval (Proxy @(IMapT p q)) + +-- | add an index to list +-- +-- >>> pz @IList "abcdef" +-- Val [(0,'a'),(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')] +-- +data IList deriving Show +type IListT = Zip (0 ... (Len - 1)) Id + +instance P IListT x => P IList x where + type PP IList x = PP IListT x + eval _ = eval (Proxy @IListT)
src/Predicate/Data/Foldable.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,12 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE ViewPatterns #-} -{- | - promoted foldable functions --} +-- | promoted foldable functions module Predicate.Data.Foldable ( Concat , ConcatMap @@ -35,7 +27,6 @@ , FromListExt , ToList - , ToList' , IToList , IToList' @@ -46,19 +37,23 @@ , Null' , IsEmpty + , Ands + , Ors + ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.Monoid (MConcat) -import Control.Lens hiding (iall) -import Data.Proxy -import Data.Typeable +import Control.Lens +import Data.Typeable (Typeable, Proxy(Proxy)) import Data.Kind (Type) -import Data.Foldable +import Data.Foldable (Foldable(toList)) import qualified Data.List.NonEmpty as N import Data.List.NonEmpty (NonEmpty(..)) import qualified GHC.Exts as GE - +import Data.List (findIndex) +import qualified Safe (cycleNote) -- $setup -- >>> import Predicate.Prelude -- >>> :set -XDataKinds @@ -78,21 +73,21 @@ -- | create a 'NonEmpty' list from a 'Foldable' -- -- >>> pz @ToNEList [] --- FailT "empty list" +-- Fail "empty list" -- -- >>> pz @ToNEList [1,2,3,4,5] --- PresentT (1 :| [2,3,4,5]) +-- Val (1 :| [2,3,4,5]) -- -data ToNEList -instance (Show (t a) - , Foldable t - ) => P ToNEList (t a) where +data ToNEList deriving Show +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) [] + [] -> mkNode opts (Fail "empty list") msg0 [] + x:xs -> mkNode opts (Val (x N.:| xs)) (msg0 <> showVerbose opts " " as) [] -- cant directly create a singleton type using '[] since the type of '[] is unknown. instead use 'Singleton' or 'EmptyT' @@ -100,26 +95,26 @@ -- | similar to 'null' using 'AsEmpty' -- -- >>> pz @IsEmpty [1,2,3,4] --- FalseT +-- Val False -- -- >>> pz @IsEmpty [] --- TrueT +-- Val True -- -- >>> pz @IsEmpty LT --- FalseT +-- Val False -- -- >>> pz @IsEmpty EQ --- TrueT +-- Val True -- -- >>> pl @IsEmpty ("failed11" :: T.Text) -- False (IsEmpty | "failed11") --- FalseT +-- Val False -- -- >>> pl @IsEmpty ("" :: T.Text) -- True (IsEmpty | "") --- TrueT +-- Val True -- -data IsEmpty +data IsEmpty deriving Show instance ( Show as , AsEmpty as @@ -129,120 +124,117 @@ let b = has _Empty as in pure $ mkNodeB opts b ("IsEmpty" <> showVerbose opts " | " as) [] +data IToList' t deriving Show +instance ( Show (f a) + , Typeable (PP t x) + , Show (PP t x) + , FoldableWithIndex (PP t x) f + , x ~ f a + , Show a + ) => P (IToList' t) x where + type PP (IToList' t) x = [(PP t x, ExtractAFromTA x)] + eval _ opts x = + let msg0 = "IToList" + b = itoList x + t = showT @(PP t x) + in pure $ mkNode opts (Val b) (msg0 <> "(" <> t <> ") " <> showL opts b <> showVerbose opts " | " x) [] + -- | similar to 'Control.Lens.itoList' -- --- >>> pz @(IToList _ Id) ("aBc" :: String) --- PresentT [(0,'a'),(1,'B'),(2,'c')] +-- >>> pz @(IToList _) ("aBc" :: String) +-- Val [(0,'a'),(1,'B'),(2,'c')] -- --- >>> pl @(IToList _ Id) ("abcd" :: String) +-- >>> pl @(IToList _) ("abcd" :: String) -- Present [(0,'a'),(1,'b'),(2,'c'),(3,'d')] (IToList(Int) [(0,'a'),(1,'b'),(2,'c'),(3,'d')] | "abcd") --- PresentT [(0,'a'),(1,'b'),(2,'c'),(3,'d')] +-- Val [(0,'a'),(1,'b'),(2,'c'),(3,'d')] -- --- >>> pl @(IToList _ Id) (M.fromList $ itoList ("abcd" :: String)) +-- >>> pl @(IToList _) (M.fromList $ itoList ("abcd" :: String)) -- Present [(0,'a'),(1,'b'),(2,'c'),(3,'d')] (IToList(Int) [(0,'a'),(1,'b'),(2,'c'),(3,'d')] | fromList [(0,'a'),(1,'b'),(2,'c'),(3,'d')]) --- PresentT [(0,'a'),(1,'b'),(2,'c'),(3,'d')] +-- Val [(0,'a'),(1,'b'),(2,'c'),(3,'d')] -- --- >>> pl @(IToList _ Id) [9,2,7,4] +-- >>> pl @(IToList _) [9,2,7,4] -- Present [(0,9),(1,2),(2,7),(3,4)] (IToList(Int) [(0,9),(1,2),(2,7),(3,4)] | [9,2,7,4]) --- PresentT [(0,9),(1,2),(2,7),(3,4)] +-- Val [(0,9),(1,2),(2,7),(3,4)] -- --- >>> pl @(IToList _ Id) (M.fromList (zip ['a'..] [9,2,7,4])) +-- >>> pl @(IToList _) (M.fromList (zip ['a'..] [9,2,7,4])) -- Present [('a',9),('b',2),('c',7),('d',4)] (IToList(Char) [('a',9),('b',2),('c',7),('d',4)] | fromList [('a',9),('b',2),('c',7),('d',4)]) --- PresentT [('a',9),('b',2),('c',7),('d',4)] +-- Val [('a',9),('b',2),('c',7),('d',4)] -- --- >>> pl @(IToList _ Id) (Just 234) +-- >>> pl @(IToList _) (Just 234) -- Present [((),234)] (IToList(()) [((),234)] | Just 234) --- PresentT [((),234)] +-- Val [((),234)] -- --- >>> pl @(IToList _ Id) (Nothing @Double) +-- >>> pl @(IToList _) (Nothing @Double) -- Present [] (IToList(()) [] | Nothing) --- PresentT [] +-- Val [] -- --- >>> pl @(IToList _ Id) [1..5] +-- >>> pl @(IToList _) [1..5] -- Present [(0,1),(1,2),(2,3),(3,4),(4,5)] (IToList(Int) [(0,1),(1,2),(2,3),(3,4),(4,5)] | [1,2,3,4,5]) --- PresentT [(0,1),(1,2),(2,3),(3,4),(4,5)] +-- Val [(0,1),(1,2),(2,3),(3,4),(4,5)] -- --- >>> pl @(IToList _ Id) ['a','b','c'] +-- >>> pl @(IToList _) ['a','b','c'] -- Present [(0,'a'),(1,'b'),(2,'c')] (IToList(Int) [(0,'a'),(1,'b'),(2,'c')] | "abc") --- PresentT [(0,'a'),(1,'b'),(2,'c')] +-- Val [(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 +data IToList (t :: Type) deriving Show +type IToListT (t :: Type) = IToList' (Hole t) -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)) +instance P (IToListT t) x => P (IToList t) x where + type PP (IToList t) x = PP (IToListT t) x + eval _ = eval (Proxy @(IToListT t)) -- | invokes 'GE.toList' -- -- >>> pz @ToListExt (M.fromList [(1,'x'),(4,'y')]) --- PresentT [(1,'x'),(4,'y')] +-- Val [(1,'x'),(4,'y')] -- -- >>> pz @ToListExt (T.pack "abc") --- PresentT "abc" +-- Val "abc" -- -data ToListExt +data ToListExt deriving Show -instance (Show l - , GE.IsList l - , Show (GE.Item l) - ) => P ToListExt l where +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) [] + in pure $ mkNode opts (Val z) (show3 opts msg0 z as) [] -- | invokes 'GE.fromList' -- -- >>> 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]) +-- Val (fromList [1,2,5]) -- --- >>> pl @(FromList (M.Map _ _) >> I !! Char1 "y") [('x',True),('y',False)] +-- >>> pl @(FromList (M.Map _ _) >> Id !! C "y") [('x',True),('y',False)] -- Present False ((>>) False | {IxL('y') False | p=fromList [('x',True),('y',False)] | q='y'}) --- PresentT False +-- Val False -- --- >>> pl @(FromList (M.Map _ _) >> Id !! Char1 "z") [('x',True),('y',False)] --- Error (!!) index not found (fromList [('x',True),('y',False)] (>>) rhs failed) --- FailT "(!!) index not found" +-- >>> pl @(FromList (M.Map _ _) >> Id !! C "z") [('x',True),('y',False)] +-- Error (!!) index not found (IxL('z') | fromList [('x',True),('y',False)]) +-- Fail "(!!) index not found" -- - -data FromList (t :: Type) -- doesnt work with OverloadedLists unless you cast to [a] explicitly +-- >>> pl @(FromList (M.Map _ _)) [(4,"x"),(5,"dd")] +-- Present fromList [(4,"x"),(5,"dd")] (FromList fromList [(4,"x"),(5,"dd")]) +-- Val (fromList [(4,"x"),(5,"dd")]) +-- +data FromList (t :: Type) deriving Show +-- 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 +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) [] + in pure $ mkNode opts (Val z) (msg0 <> " " <> showL opts z) [] -- | invokes 'GE.fromList' -- @@ -250,174 +242,132 @@ -- -- >>> :set -XOverloadedLists -- >>> pz @(FromListExt (M.Map _ _)) [(4,"x"),(5,"dd")] --- PresentT (fromList [(4,"x"),(5,"dd")]) +-- Val (fromList [(4,"x"),(5,"dd")]) -- -data FromListExt (t :: Type) +data FromListExt (t :: Type) deriving Show -- l ~ l' is key -instance (Show l - , GE.IsList l - , l ~ l' - ) => P (FromListExt l') l where +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) [] + in pure $ mkNode opts (Val z) (msg0 <> " " <> showL opts z) [] -- | similar to 'concat' -- --- >>> pz @(Concat Id) ["abc","D","eF","","G"] --- PresentT "abcDeFG" +-- >>> pz @Concat ["abc","D","eF","","G"] +-- Val "abcDeFG" -- --- >>> pz @(Concat (Snd Id)) ('x',["abc","D","eF","","G"]) --- PresentT "abcDeFG" +-- >>> pz @(Lift Concat Snd) ('x',["abc","D","eF","","G"]) +-- Val "abcDeFG" -- -data Concat p +data Concat deriving Show -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 +instance ( Show a + , Show x + , x ~ t [a] + , Foldable t + ) => P Concat x where + type PP Concat x = ExtractAFromTA x + eval _ opts x = 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] + b = concat x + in pure $ mkNode opts (Val b) (show3 opts msg0 b x) [] -- | similar to 'concatMap' -data ConcatMap p q -type ConcatMapT p q = Concat (Map p q) +data ConcatMap p q deriving Show +type ConcatMapT p q = Map' p q >> Concat 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)) --- | similar to 'cycle' but for a fixed number \'n\' +-- | similar to 'cycle' but for a fixed number @n@ -- -- >>> pz @(Cycle 5 Id) [1,2] --- PresentT [1,2,1,2,1] +-- Val [1,2,1,2,1] -- -data Cycle n p +data Cycle n p deriving Show -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 +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 [] + lr <- runPQ NoInline 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 () -> + Right _ -> let msg1 = msg0 <> "(" <> show n <> ")" - d = take n (cycle (toList p)) - in mkNode opts (PresentT d) (show01 opts msg1 d p) hhs + d = take n (Safe.cycleNote msg0 (toList p)) + in mkNode opts (Val d) (show3 opts msg1 d p) hhs -- | similar to 'toList' -- -- >>> pz @ToList "aBc" --- PresentT "aBc" +-- Val "aBc" -- -- >>> pz @ToList (Just 14) --- PresentT [14] +-- Val [14] -- -- >>> pz @ToList Nothing --- PresentT [] +-- Val [] -- -- >>> pz @ToList (Left "xx") --- PresentT [] +-- Val [] -- -- >>> pz @ToList (These 12 "xx") --- PresentT ["xx"] +-- Val ["xx"] -- -- >>> pl @ToList (M.fromList $ zip [0..] "abcd") -- Present "abcd" (ToList fromList [(0,'a'),(1,'b'),(2,'c'),(3,'d')]) --- PresentT "abcd" +-- Val "abcd" -- -- >>> pl @ToList (Just 123) -- Present [123] (ToList Just 123) --- PresentT [123] +-- Val [123] -- -- >>> pl @ToList (M.fromList (zip ['a'..] [9,2,7,4])) -- Present [9,2,7,4] (ToList fromList [('a',9),('b',2),('c',7),('d',4)]) --- PresentT [9,2,7,4] +-- Val [9,2,7,4] -- - -data ToList -instance (Show (t a) - , Foldable t - ) => P ToList (t a) where +data ToList deriving Show +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" :: String)) --- PresentT [] --- --- >>> pz @(ToList' Id) (These 12 ("xx" :: String)) --- 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 + in pure $ mkNode opts (Val z) (msg0 <> showVerbose opts " " as) [] -data Null' p +data Null' p deriving Show -instance (Show (t a) - , Foldable t - , t a ~ PP p x - , P p x - ) => P (Null' p) x where +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 + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e Right p -> let b = null p @@ -426,106 +376,162 @@ -- | similar to 'null' using 'Foldable' -- -- >>> pz @Null [1,2,3,4] --- FalseT +-- Val False -- -- >>> pz @Null [] --- TrueT +-- Val True -- -- >>> pz @Null Nothing --- TrueT +-- Val True -- -data Null +data Null deriving Show type NullT = Null' Id instance P NullT a => P Null a where type PP Null a = Bool eval _ = evalBool (Proxy @NullT) --- | similar to a limited form of 'foldMap' +-- | wraps each item in the foldable container and then unwraps the mconcatenated result: uses 'Control.Lens.Wrapped.Wrapped' -- -- >>> pz @(FoldMap (SG.Sum _) Id) [44, 12, 3] --- PresentT 59 +-- Val 59 -- -- >>> pz @(FoldMap (SG.Product _) Id) [44, 12, 3] --- PresentT 1584 +-- Val 1584 -- -- >>> type Ands' p = FoldMap SG.All p -- >>> pz @(Ands' Id) [True,False,True,True] --- PresentT False +-- Val False -- -- >>> pz @(Ands' Id) [True,True,True] --- PresentT True +-- Val True -- -- >>> pz @(Ands' Id) [] --- PresentT True +-- Val True -- -- >>> type Ors' p = FoldMap SG.Any p -- >>> pz @(Ors' Id) [False,False,False] --- PresentT False +-- Val False -- -- >>> pz @(Ors' Id) [] --- PresentT False +-- Val False -- -- >>> pz @(Ors' Id) [False,False,False,True] --- PresentT True +-- Val True -- --- >>> type AllPositive' = FoldMap SG.All (Map Positive Id) +-- >>> type AllPositive' = FoldMap SG.All (Map Positive) -- >>> pz @AllPositive' [3,1,-5,10,2,3] --- PresentT False +-- Val False -- --- >>> type AllNegative' = FoldMap SG.All (Map Negative Id) +-- >>> type AllNegative' = FoldMap SG.All (Map Negative) -- >>> pz @AllNegative' [-1,-5,-10,-2,-3] --- PresentT True +-- Val 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 +-- Val 12 -- -- >>> pl @(FoldMap (SG.Sum _) Id) [14,8,17,13] -- Present 52 ((>>) 52 | {getSum = 52}) --- PresentT 52 +-- Val 52 -- -- >>> pl @(FoldMap (SG.Max _) Id) [14 :: Int,8,17,13] -- cos Bounded! -- Present 17 ((>>) 17 | {getMax = 17}) --- PresentT 17 +-- Val 17 -- -- >>> pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [1..20] -- True (False || True) --- TrueT +-- Val True -- -- >>> pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [1..19] -- False (False || False | ((>>) False | {1 == 0})}) || ((>>) False | {190 > 200})) --- FalseT +-- Val False -- -- >>> pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [] -- True (True || False) --- TrueT +-- Val True -- -- >>> pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) &&& FoldMap (SG.Sum _) Id) [1..20] --- Present (False,210) (W '(False,210)) --- PresentT (False,210) +-- Present (False,210) ('(False,210)) +-- Val (False,210) -- -- >>> pl @(FoldMap SG.Any Id) [False,False,True,False] -- Present True ((>>) True | {getAny = True}) --- PresentT True +-- Val True -- -- >>> pl @(FoldMap SG.All Id) [False,False,True,False] -- Present False ((>>) False | {getAll = False}) --- PresentT False +-- Val False -- -- >>> pl @(FoldMap (SG.Sum _) Id) (Just 13) -- Present 13 ((>>) 13 | {getSum = 13}) --- PresentT 13 +-- Val 13 -- -- >>> pl @(FoldMap (SG.Sum _) Id) [1..10] -- Present 55 ((>>) 55 | {getSum = 55}) --- PresentT 55 +-- Val 55 -- - -data FoldMap (t :: Type) p -type FoldMapT (t :: Type) p = Map (Wrap t Id) p >> Unwrap (MConcat Id) +data FoldMap (t :: Type) p deriving Show +type FoldMapT (t :: Type) p = Map' (Wrap t Id) p >> MConcat Id >> Unwrap 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 'Data.Foldable.and' +-- +-- >>> pz @Ands [True,True,True] +-- Val True +-- +-- >>> pl @Ands [True,True,True,False] +-- False (Ands(4) i=3 | [True,True,True,False]) +-- Val False +-- +-- >>> pz @Ands [] +-- Val True +-- +data Ands deriving Show + +instance ( x ~ t a + , Show (t a) + , Foldable t + , a ~ Bool + ) => P Ands x where + type PP Ands x = Bool + eval _ opts x = + let msg0 = "Ands" + msg1 = msg0 ++ "(" ++ show (length x) ++ ")" + w = case findIndex not (toList x) of + Nothing -> "" + Just i -> " i="++show i + in pure $ mkNodeB opts (and x) (msg1 <> w <> showVerbose opts " | " x) [] + +-- | similar to 'Data.Foldable.or' +-- +-- >>> pz @Ors [False,False,False] +-- Val False +-- +-- >>> pl @Ors [True,True,True,False] +-- True (Ors(4) i=0 | [True,True,True,False]) +-- Val True +-- +-- >>> pl @Ors [] +-- False (Ors(0) | []) +-- Val False +-- +data Ors deriving Show + +instance ( x ~ t a + , Show x + , Foldable t + , a ~ Bool + ) => P Ors x where + type PP Ors x = Bool + eval _ opts x = + let msg0 = "Ors" + msg1 = msg0 ++ "(" ++ show (length x) ++ ")" + w = case findIndex id (toList x) of + Nothing -> "" + Just i -> " i=" ++ show i + in pure $ mkNodeB opts (or x) (msg1 <> w <> showVerbose opts " | " x) []
src/Predicate/Data/IO.hs view
@@ -1,8 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -18,76 +13,85 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted io functions --} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +-- | promoted io functions module Predicate.Data.IO ( - + -- ** file handling ReadFile + , ReadFileBinary , FileExists , ReadDir , DirExists - , ReadEnv - , ReadEnvAll - , TimeUtc - , TimeZt , AppendFile , WriteFile , WriteFile' + + -- ** screen , Stdout , Stderr , Stdin , ReadIO , ReadIO' + -- ** environment + , ReadEnv + , ReadEnvAll + + -- ** date time + , TimeUtc + , TimeZt + + -- ** random + , GenIO + , GenPure + , GenNext + , GenSplit + , GenRange + , RandomNext + , RandomList + , RandomRNext + , RandomRList + ) where import Predicate.Core +import Predicate.Misc import Predicate.Util +import Predicate.Data.Enum (type (...)) import Predicate.Data.Maybe (IsJust) -import Predicate.Data.Monoid (type (<>)) +import Predicate.Data.Iterator (Foldl) +import Predicate.Data.List (type (:+)) +import Predicate.Data.Monoid (type (<>), MEmptyT) import Predicate.Data.ReadShow (ReadP) +import Predicate.Data.Tuple (Second) import GHC.TypeLits (Symbol,KnownSymbol) -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import qualified Control.Exception as E import Data.Kind (Type) -import Control.Arrow -import Data.Time -import System.Directory -import System.IO -import System.Environment - +import Control.Arrow (ArrowChoice(left)) +import Data.Time (UTCTime, ZonedTime, getCurrentTime, getZonedTime) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.IO (hPutStr, withFile, IOMode(WriteMode, AppendMode)) +import System.Environment (getEnvironment, lookupEnv) +import qualified Data.ByteString.Char8 as BS8 +import System.Random -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import Predicate.Prelude --- | similar to 'readFile' +-- | similar to 'System.IO.readFile' -- -- >>> pz @(ReadFile "LICENSE" >> 'Just Id >> Len > 0) () --- TrueT +-- Val True -- -- >>> pz @(FileExists "xyzzy") () --- FalseT --- --- >>> pl @(FileExists "xxy") () --- False (IsJust) --- FalseT +-- Val False -- -data ReadFile p - - --- | similar to 'doesFileExist' -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)) +data ReadFile p deriving Show instance ( PP p x ~ String , P p x @@ -96,7 +100,7 @@ eval _ opts x = do let msg0 = "ReadFile" pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of + case getValueLR NoInline opts msg0 pp [] of Left e -> pure e Right p -> do let msg1 = msg0 <> "[" <> p <> "]" @@ -105,32 +109,58 @@ 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] + Nothing -> mkNode opts (Fail msg1) "" [hh pp] + Just Nothing -> mkNode opts (Val Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just b) -> mkNode opts (Val (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> litL opts b) [hh pp] --- | similar to 'doesDirectoryExist' +-- | similar to 'Data.ByteString.readFile' +data ReadFileBinary p deriving Show + +instance ( PP p x ~ String + , P p x + ) => P (ReadFileBinary p) x where + type PP (ReadFileBinary p) x = Maybe BS8.ByteString + eval _ opts x = do + let msg0 = "ReadFileBinary" + pp <- eval (Proxy @p) opts x + case getValueLR NoInline 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 <$> BS8.readFile p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (Fail msg1) "" [hh pp] + Just Nothing -> mkNode opts (Val Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just b) -> mkNode opts (Val (Just b)) (msg1 <> " len=" <> show (BS8.length b) <> " Just " <> litBS opts b) [hh pp] + +-- | similar to 'System.Directory.doesFileExist' +data FileExists p deriving Show +type FileExistsT p = ReadFile p >> IsJust + +instance P (FileExistsT p) x => P (FileExists p) x where + type PP (FileExists p) x = PP (FileExistsT p) x + eval _ = evalBool (Proxy @(FileExistsT p)) + +-- | similar to 'System.Directory.doesDirectoryExist' -- -- >>> pz @(DirExists ".") () --- TrueT --- --- >>> pl @(DirExists ".") () --- True (IsJust) --- TrueT +-- Val True -- --- >>> pl @(DirExists "xxy") () --- False (IsJust) --- FalseT +-- >>> pz @(DirExists "xxy") () +-- Val False -- -data DirExists p -type DirExistsT p = IsJust (ReadDir p) +data DirExists p deriving Show +type DirExistsT p = ReadDir p >> IsJust instance P (DirExistsT p) x => P (DirExists p) x where type PP (DirExists p) x = PP (DirExistsT p) x eval _ = evalBool (Proxy @(DirExistsT p)) --- | similar to 'listDirectory' -data ReadDir p +-- | similar to 'System.Directory.listDirectory' +data ReadDir p deriving Show instance ( PP p x ~ String , P p x ) => P (ReadDir p) x where @@ -138,7 +168,7 @@ eval _ opts x = do let msg0 = "ReadDir" pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of + case getValueLR NoInline opts msg0 pp [] of Left e -> pure e Right p -> do let msg1 = msg0 <> "[" <> p <> "]" @@ -147,16 +177,16 @@ 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] + Nothing -> mkNode opts (Fail msg1) "" [hh pp] + Just Nothing -> mkNode opts (Val Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just b) -> mkNode opts (Val (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> showL opts b) [hh pp] --- | read an environment variable: similar to 'getEnv' +-- | read an environment variable: similar to 'System.Environment.getEnv' -- -- >>> pz @(ReadEnv "PATH" >> 'Just Id >> 'True) () --- TrueT +-- Val True -- -data ReadEnv p +data ReadEnv p deriving Show instance ( PP p x ~ String , P p x @@ -165,18 +195,18 @@ eval _ opts x = do let msg0 = "ReadEnv" pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of + case getValueLR NoInline 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] + Nothing -> mkNode opts (Fail msg1) "" [hh pp] + Just Nothing -> mkNode opts (Val Nothing) (msg1 <> " does not exist") [hh pp] + Just (Just v) -> mkNode opts (Val (Just v)) (msg1 <> " " <> litL opts v) [hh pp] --- | read all the environment variables as key value pairs: similar to 'getEnvironment' -data ReadEnvAll +-- | read all the environment variables as key value pairs: similar to 'System.Environment.getEnvironment' +data ReadEnvAll deriving Show instance P ReadEnvAll a where type PP ReadEnvAll a = [(String,String)] @@ -184,51 +214,55 @@ 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)) [] + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (Val v) (msg0 <> " count=" <> show (length v)) [] -- | get the current time using 'UTCTime' -data TimeUtc +data TimeUtc deriving Show instance P TimeUtc a where type PP TimeUtc a = UTCTime - eval _ opts _a = do + eval _ opts _ = 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) [] + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (Val v) (msg0 <> " " <> showL opts v) [] -- | get the current time using 'ZonedTime' -data TimeZt +data TimeZt deriving Show instance P TimeZt a where type PP TimeZt a = ZonedTime - eval _ opts _a = do + eval _ opts _ = 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) [] + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [] + Just v -> mkNode opts (Val v) (msg0 <> " " <> showL opts v) [] -data FHandle s = FStdout | FStderr | FOther !s !WFMode deriving Show +data FHandle s = FStdout | FStderr | FOther !s !WFMode + deriving stock (Read, Show, Eq) 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) +instance ( GetMode w + , KnownSymbol s + ) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w) -data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq) +data WFMode = WFAppend | WFWrite | WFWriteForce + deriving stock (Read, 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 +data WriteFileImpl (hh :: FHandle Symbol) p deriving Show -- | append to a file -data AppendFile (s :: Symbol) p +data AppendFile (s :: Symbol) p deriving Show type AppendFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFAppend) p instance P (AppendFileT s p) x => P (AppendFile s p) x where @@ -237,7 +271,7 @@ -- | write to file, overwriting if needed -data WriteFile' (s :: Symbol) p +data WriteFile' (s :: Symbol) p deriving Show type WriteFileT' (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWriteForce) p instance P (WriteFileT' s p) x => P (WriteFile' s p) x where @@ -245,7 +279,7 @@ eval _ = eval (Proxy @(WriteFileT' s p)) -- | write to file, without overwriting -data WriteFile (s :: Symbol) p +data WriteFile (s :: Symbol) p deriving Show type WriteFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWrite) p instance P (WriteFileT s p) x => P (WriteFile s p) x where @@ -253,7 +287,7 @@ eval _ = eval (Proxy @(WriteFileT s p)) -- | write a string value to stdout -data Stdout p +data Stdout p deriving Show type StdoutT p = WriteFileImpl 'FStdout p instance P (StdoutT p) x => P (Stdout p) x where @@ -261,17 +295,17 @@ eval _ = eval (Proxy @(StdoutT p)) -- | write a string value to stderr -data Stderr p +data Stderr p deriving Show 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 +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 @@ -283,7 +317,7 @@ WFWrite -> "WriteFile" WFWriteForce -> "WriteFile'" pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of + case getValueLR NoInline opts msg0 pp [] of Left e -> pure e Right ss -> do mb <- runIO $ case fh of @@ -294,13 +328,14 @@ if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists" else do let md = case w of - WFAppend -> AppendMode - _ -> WriteMode + WFAppend -> AppendMode + WFWrite -> WriteMode + WFWriteForce -> 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] + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [hh pp] + Just (Left e) -> mkNode opts (Fail $ msg0 <> ":" <> e) "" [hh pp] + Just (Right ()) -> mkNode opts (Val ()) 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" @@ -308,11 +343,11 @@ -- eg pa @(ReadIO Int + ReadIO Int) () -- | read a value from stdin -data Stdin +data Stdin deriving Show instance P Stdin x where type PP Stdin x = String - eval _ opts _x = do + eval _ opts _ = do let msg0 = "Stdin" mb <- runIO $ do lr <- E.try getLine @@ -320,7 +355,163 @@ 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 <> "]") [] + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [] + Just (Left e) -> mkNode opts (Fail $ msg0 <> ":" <> e) "" [] + Just (Right ss) -> mkNode opts (Val ss) (msg0 <> "[" <> litVerbose opts "" ss <> "]") [] + +-- | generate a random number: see 'System.Random.newStdGen' +data GenIO deriving Show + +instance P GenIO x where + type PP GenIO x = StdGen + eval _ opts _ = do + let msg0 = "GenIO" + mg <- runIO newStdGen + pure $ case mg of + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" [] + Just g -> mkNode opts (Val g) (msg0 <> "[" <> showVerbose opts "" g <> "]") [] + +-- | similar to 'System.Random.mkStdGen' +-- +-- >>> pz @(GenPure Id) 1234 +-- Val 1235 1 +-- +data GenPure p deriving Show + +instance (PP p x ~ Int, P p x) => P (GenPure p) x where + type PP (GenPure p) x = StdGen + eval _ opts x = do + let msg0 = "GenPure" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let g = mkStdGen p + in mkNode opts (Val g) msg0 [hh pp] + +-- | get the next random number of type @t@ using generator @r@ : similar to 'System.Random.random' +-- +-- >>> pz @(UnfoldN 5 (RandomNext Bool Id) Id) (mkStdGen 3) +-- Val [True,True,False,True,True] +-- +data RandomNext (t :: Type) p deriving Show + +instance ( Random t + , P p x + , Show (PP p x) + , RandomGen (PP p x) + ) => P (RandomNext t p) x where + type PP (RandomNext t p) x = (t, PP p x) + eval _ opts x = do + let msg0 = "RandomNext" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let (a,g) = random p + in mkNode opts (Val (a,g)) (msg0 <> "[" <> showVerbose opts "" g <> "]") [hh pp] + +-- | get a list of @n@ random numbers of type @t@ using generator @p@: similar to 'System.Random.randoms' +-- +-- >>> pz @(RandomList 10 Bool Id) (mkStdGen 4) +-- Val ([True,True,False,True,True,True,True,False,False,True],2036574526 1336516156) +-- +data RandomList n (t :: Type) p deriving Show +type RandomListT n t p = Foldl (Fst >> Second (RandomNext t Id) >> '(L21 :+ Fst, L22)) '(MEmptyT [t],p) (1...n) + +instance P (RandomListT n t p) x => P (RandomList n t p) x where + type PP (RandomList n t p) x = PP (RandomListT n t p) x + eval _ = eval (Proxy @(RandomListT n t p)) + + +-- | get the next random number of type @t@ in range between @p@ and @q@ using generator @r@ : similar to 'System.Random.randomR' +-- +-- >>> pz @(Foldl (Fst >> Second (RandomRNext Int 1 100 Id) >> '(L21 :+ Fst, L22)) '( MEmptyT [Int] ,Id) (1...5)) (mkStdGen 3) +-- Val ([12,26,33,94,64],781515869 652912057) +-- +-- >>> pz @(UnfoldN 10 (RandomRNext _ (C "A") (C "H") Id) Id) (mkStdGen 3) +-- Val "DBABDDEEEA" +-- +data RandomRNext (t :: Type) p q r deriving Show + +instance ( Random t + , P r x + , RandomGen (PP r x) + , Show (PP r x) + , PP p x ~ t + , PP q x ~ t + , P p x + , P q x + ) => P (RandomRNext t p q r) x where + type PP (RandomRNext t p q r) x = (t, PP r x) + eval _ opts x = do + let msg0 = "RandomRNext" + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + rr <- eval (Proxy @r) opts x + pure $ case getValueLR NoInline opts msg0 rr [hh pp,hh qq] of + Left e -> e + Right r -> + let (a,g) = randomR (p,q) r + in mkNode opts (Val (a,g)) (msg0 <> "[" <> showVerbose opts "" g <> "]") [hh pp, hh qq, hh rr] + +-- | list @n@ random numbers of type @t@ in range between @p@ and @q@ using generator @r@ : similar to 'System.Random.randomRs' +-- +-- >>> pz @(RandomRList 10 Int 0 6 Id) (mkStdGen 1) +-- Val ([6,6,5,1,3,0,3,6,5,2],1244126523 1336516156) +-- +-- >>> pz @(RandomRList 10 _ (C "A") (C "F") Id) (mkStdGen 1) +-- Val ("EEBCBEFBEF",1244126523 1336516156) +-- +data RandomRList n (t :: Type) p q r deriving Show +type RandomRListT n t p q r = Foldl (Fst >> Second (RandomRNext t p q Id) >> '(L21 :+ Fst, L22)) '(MEmptyT [t],r) (1...n) + +instance P (RandomRListT n t p q r) x => P (RandomRList n t p q r) x where + type PP (RandomRList n t p q r) x = PP (RandomRListT n t p q r) x + eval _ = eval (Proxy @(RandomRListT n t p q r)) + +-- | similar to 'System.Random.split' +data GenSplit p deriving Show + +instance (RandomGen (PP p x), P p x) => P (GenSplit p) x where + type PP (GenSplit p) x = (PP p x, PP p x) + eval _ opts x = do + let msg0 = "GenSplit" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let g = split p + in mkNode opts (Val g) msg0 [hh pp] + + +-- | similar to 'System.Random.next' +data GenNext p deriving Show + +instance (RandomGen (PP p x), P p x) => P (GenNext p) x where + type PP (GenNext p) x = (Int, PP p x) + eval _ opts x = do + let msg0 = "GenNext" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let g = next p + in mkNode opts (Val g) msg0 [hh pp] + +-- | similar to 'System.Random.genRange' +data GenRange p deriving Show + +instance (RandomGen (PP p x), P p x) => P (GenRange p) x where + type PP (GenRange p) x = (Int, Int) + eval _ opts x = do + let msg0 = "GenRange" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let g = genRange p + in mkNode opts (Val g) msg0 [hh pp]
src/Predicate/Data/Index.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,13 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted indexing functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted indexing functions module Predicate.Data.Index ( - -- ** indexing expressions Ix , Ix' , IxL @@ -35,28 +26,20 @@ , LookupDef' , LookupFail , LookupFail' - - -- ** list to tuples - , Tuple2 - , Tuple3 - , Tuple4 - , Tuple5 - , Tuple6 - ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.Maybe (JustDef, JustFail) -import Control.Lens hiding (iall) +import Control.Lens import GHC.TypeLits (Nat, KnownNat) -import Data.Proxy +import Data.Proxy (Proxy(..)) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Map.Strict as M -- >>> import qualified Data.Set as Set -- >>> import qualified Data.Text as T @@ -65,31 +48,31 @@ -- | index a value in an 'Ixed' container and if not found return the given default value -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) (['a'..'e'],2) +-- >>> pl @(LookupDef' Snd Fst (C "xx") Id) (['a'..'e'],2) -- Present 'c' (JustDef Just) --- PresentT 'c' +-- Val 'c' -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) (['a'..'e'],999) +-- >>> pl @(LookupDef' Snd Fst (C "xx") Id) (['a'..'e'],999) -- Present 'x' (JustDef Nothing) --- PresentT 'x' +-- Val 'x' -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) ([],2) +-- >>> pl @(LookupDef' Snd Fst (C "xx") Id) ([],2) -- Present 'x' (JustDef Nothing) --- PresentT 'x' +-- Val 'x' -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") (Snd Id)) ('w',([],2)) +-- >>> pl @(LookupDef' Snd Fst (C "xx") Snd) ('w',([],2)) -- Present 'x' (JustDef Nothing) --- PresentT 'x' +-- Val 'x' -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (Fst Id) (Snd Id)) ('x',(['a'..'e'],2)) +-- >>> pl @(LookupDef' Snd Fst Fst Snd) ('x',(['a'..'e'],2)) -- Present 'c' (JustDef Just) --- PresentT 'c' +-- Val 'c' -- --- >>> pl @(LookupDef' (Fst Id) (Snd Id) (MEmptyT _) (Snd Id)) ('x',(map SG.Min [10..15::Int], 3)) +-- >>> pl @(LookupDef' Snd Fst (MEmptyT _) Snd) ('x',(map SG.Min [10..15::Int], 3)) -- Present Min {getMin = 13} (JustDef Just) --- PresentT (Min {getMin = 13}) +-- Val (Min {getMin = 13}) -- -data LookupDef' v w p q +data LookupDef' v w p q deriving Show 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 @@ -98,47 +81,35 @@ -- | index a value in an 'Ixed' container and if not found return the given default value -- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 4 Id) 23 +-- >>> pl @(LookupDef 4 '[1,2,3,4,5,6] Id) 23 -- Present 5 (JustDef Just) --- PresentT 5 +-- Val 5 -- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 4 (Fst Id)) (23,'x') +-- >>> pl @(LookupDef 4 '[1,2,3,4,5,6] Fst) (23,'x') -- Present 5 (JustDef Just) --- PresentT 5 --- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 99 Id) 23 --- Present 23 (JustDef Nothing) --- PresentT 23 +-- Val 5 -- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 99 (Fst Id)) (23,'x') +-- >>> pl @(LookupDef 99 '[1,2,3,4,5,6] Id) 23 -- Present 23 (JustDef Nothing) --- PresentT 23 --- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 4 999) (23,'x') --- Present 5 (JustDef Just) --- PresentT 5 --- --- >>> pl @(LookupDef '[1,2,3,4,5,6] 40 999) (23,'x') --- Present 999 (JustDef Nothing) --- PresentT 999 +-- Val 23 -- --- >>> pl @(LookupDef (Fst Id) 4 (MEmptyT _)) (map SG.Min [1::Int .. 10],'x') +-- >>> pl @(LookupDef 4 Fst (MEmptyT _)) (map SG.Min [1::Int .. 10],'x') -- Present Min {getMin = 5} (JustDef Just) --- PresentT (Min {getMin = 5}) +-- Val (Min {getMin = 5}) -- --- >>> pl @(LookupDef (Fst Id) 999 (MEmptyT _)) (map SG.Min [1::Int .. 10],'x') +-- >>> pl @(LookupDef 999 Fst (MEmptyT _)) (map SG.Min [1::Int .. 10],'x') -- Present Min {getMin = 9223372036854775807} (JustDef Nothing) --- PresentT (Min {getMin = 9223372036854775807}) +-- Val (Min {getMin = 9223372036854775807}) -- -data LookupDef v w p -type LookupDefT v w p = LookupDef' v w p I +data LookupDef v w p deriving Show +type LookupDefT v w p = LookupDef' v w p Id 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)) -- | index a value in an 'Ixed' container and if not found fail with the given message -data LookupFail' msg v w q +data LookupFail' msg v w q deriving Show 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 @@ -147,16 +118,16 @@ -- | index a value in an 'Ixed' container and if not found fail with the given message -- --- >>> pl @(LookupFail "someval" (Fst Id) 999) (map SG.Min [1::Int .. 10],'x') +-- >>> pl @(LookupFail "someval" 999 Fst) (map SG.Min [1::Int .. 10],'x') -- Error someval (JustFail Nothing) --- FailT "someval" +-- Fail "someval" -- --- >>> pl @(LookupFail (PrintF "char=%c" (Snd Id)) (Fst Id) 49) (map SG.Min [1::Int ..10],'x') +-- >>> pl @(LookupFail (PrintF "char=%c" Snd) 49 Fst) (map SG.Min [1::Int ..10],'x') -- Error char=x (JustFail Nothing) --- FailT "char=x" +-- Fail "char=x" -- -data LookupFail msg v w -type LookupFailT msg v w = LookupFail' msg v w I +data LookupFail msg v w deriving Show +type LookupFailT msg v w = LookupFail' msg v w Id 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 @@ -165,83 +136,84 @@ -- | similar to 'Data.List.!!' using an 'Ixed' container -- -- >>> pz @(Ix 4 "not found") ["abc","D","eF","","G"] --- PresentT "G" +-- Val "G" -- -- >>> pz @(Ix 40 "not found") ["abc","D","eF","","G"] --- PresentT "not found" +-- Val "not found" -- --- >>> pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Id) ([10,12,3,5],"ss") +-- >>> pl @(Fst >> Dup >> (Ix 1 (FailP "failed5") *** Ix 3 (FailP "failed5")) >> Id) ([10,12,3,5],"ss") -- Present (12,5) ((>>) (12,5) | {Id (12,5)}) --- PresentT (12,5) +-- Val (12,5) -- --- >>> pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Fst Id < Snd Id) ([10,12,3,5],"ss") +-- >>> pl @(Fst >> Dup >> (Ix 1 (FailP "failed5") *** Ix 3 (FailP "failed5")) >> Fst < Snd) ([10,12,3,5],"ss") -- False ((>>) False | {12 < 5}) --- FalseT +-- Val False -- --- >>> pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Fst Id > Snd Id) ([10,12,3,5],"ss") +-- >>> pl @(Fst >> Dup >> (Ix 1 (FailP "failed5") *** Ix 3 (FailP "failed5")) >> Fst > Snd) ([10,12,3,5],"ss") -- True ((>>) True | {12 > 5}) --- TrueT +-- Val True -- --- >>> pl @(Snd Id >> Len &&& Ix 3 (Failp "someval1") >> Fst Id == Snd Id) ('x',[1..5]) +-- >>> pl @(Snd >> Len &&& Ix 3 (FailP "someval1") >> Fst == Snd) ('x',[1..5]) -- False ((>>) False | {5 == 4}) --- FalseT +-- Val False -- --- >>> pl @(Snd Id >> Len &&& Ix 3 (Failp "someval2") >> Fst Id < Snd Id) ('x',[1..5]) +-- >>> pl @(Snd >> Len &&& Ix 3 (FailP "someval2") >> Fst < Snd) ('x',[1..5]) -- False ((>>) False | {5 < 4}) --- FalseT +-- Val False -- --- >>> pl @(Snd Id >> Len &&& Ix 3 (Failp "someval3") >> Fst Id > Snd Id) ('x',[1..5]) +-- >>> pl @(Snd >> Len &&& Ix 3 (FailP "someval3") >> Fst > Snd) ('x',[1..5]) -- True ((>>) True | {5 > 4}) --- TrueT +-- Val True -- --- >>> pl @(Map Len Id >> Ix 3 (Failp "lhs") &&& Ix 0 5 >> Fst Id == Snd Id) [[1..4],[4..5]] --- Error lhs ([4,2] (>>) rhs failed) --- FailT "lhs" +-- >>> pl @(Map Len >> Ix 3 (FailP "lhs") &&& Ix 0 5 >> Fst == Snd) [[1..4],[4..5]] +-- Error lhs (Ix(3) not found | '(,)) +-- Fail "lhs" -- --- >>> pl @(Map Len Id >> Ix 0 (Failp "lhs") &&& Ix 1 5 >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 0 (FailP "lhs") &&& Ix 1 5 >> Fst == Snd) [[1..4],[4..5]] -- False ((>>) False | {4 == 2}) --- FalseT +-- Val False -- --- >>> pl @(Map Len Id >> Ix 1 (Failp "lhs") &&& Ix 3 (Failp "rhs") >> Fst Id == Snd Id) [[1..4],[4..5]] --- Error rhs ([4,2] (>>) rhs failed) --- FailT "rhs" +-- >>> pl @(Map Len >> Ix 1 (FailP "lhs") &&& Ix 3 (FailP "rhs") >> Fst == Snd) [[1..4],[4..5]] +-- Error rhs (Ix(3) not found | '(,)) +-- Fail "rhs" -- --- >>> pl @(Map Len Id >> Ix 10 (Failp "lhs") &&& Ix 1 (Failp "rhs") >> Fst Id == Snd Id) [[1..4],[4..5]] --- Error lhs ([4,2] (>>) rhs failed) --- FailT "lhs" +-- >>> pl @(Map Len >> Ix 10 (FailP "lhs") &&& Ix 1 (FailP "rhs") >> Fst == Snd) [[1..4],[4..5]] +-- Error lhs (Ix(10) not found | '(,)) +-- Fail "lhs" -- --- >>> pl @(Map Len Id >> Ix 0 (Failp "lhs") &&& Ix 10 (Failp "rhs") >> Fst Id == Snd Id) [[1..4],[4..5]] --- Error rhs ([4,2] (>>) rhs failed) --- FailT "rhs" +-- >>> pl @(Map Len >> Ix 0 (FailP "lhs") &&& Ix 10 (FailP "rhs") >> Fst == Snd) [[1..4],[4..5]] +-- Error rhs (Ix(10) not found | '(,)) +-- Fail "rhs" -- --- >>> pl @(Map Len Id >> Ix 10 3 &&& Ix 1 (Failp "rhs") >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 10 3 &&& Ix 1 (FailP "rhs") >> Fst == Snd) [[1..4],[4..5]] -- False ((>>) False | {3 == 2}) --- FalseT +-- Val False -- --- >>> pl @(Map Len Id >> Ix 3 3 &&& Ix 1 4 >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 3 3 &&& Ix 1 4 >> Fst == Snd) [[1..4],[4..5]] -- False ((>>) False | {3 == 2}) --- FalseT +-- Val False -- --- >>> pl @(Map Len Id >> Ix 10 3 &&& Ix 1 4 >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 10 3 &&& Ix 1 4 >> Fst == Snd) [[1..4],[4..5]] -- False ((>>) False | {3 == 2}) --- FalseT +-- Val False -- --- >>> pl @(Map Len Id >> Ix 10 5 &&& Ix 1 4 >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 10 5 &&& Ix 1 4 >> Fst == Snd) [[1..4],[4..5]] -- False ((>>) False | {5 == 2}) --- FalseT +-- Val False -- --- >>> pl @(Map Len Id >> Ix 10 2 &&& Ix 1 4 >> Fst Id == Snd Id) [[1..4],[4..5]] +-- >>> pl @(Map Len >> Ix 10 2 &&& Ix 1 4 >> Fst == Snd) [[1..4],[4..5]] -- True ((>>) True | {2 == 2}) --- TrueT +-- Val True -- -data Ix (n :: Nat) def +data Ix (n :: Nat) def deriving Show -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 +instance ( P def (Proxy a) + , PP def (Proxy a) ~ a + , KnownNat n + , Show a + , [a] ~ x + ) => P (Ix n def) x where + type PP (Ix n def) x = ExtractAFromTA x eval _ opts as = do let n = nat @n msg0 = "Ix(" <> show n <> ")" @@ -249,13 +221,13 @@ Nothing -> do let msg1 = msg0 <> " not found" pp <- eval (Proxy @def) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [] of + pure $ case getValueLR Inline 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) [] + Right _ -> mkNodeCopy opts pp msg1 [hh pp] + Just a -> pure $ mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -data Ix' (n :: Nat) -type IxT' (n :: Nat) = Ix n (Failp "Ix index not found") +data Ix' (n :: Nat) deriving Show +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 @@ -264,271 +236,251 @@ -- | similar to 'Data.List.!!' leveraging 'Ixed' -- -- >>> pz @(IxL Id 2 "notfound") ["abc","D","eF","","G"] --- PresentT "eF" +-- Val "eF" -- -- >>> pz @(IxL Id 20 "notfound") ["abc","D","eF","","G"] --- PresentT "notfound" +-- Val "notfound" -- --- >>> pl @(IxL Id 1 (Char1 "x")) ("123" :: T.Text) +-- >>> pl @(IxL Id 1 (C "x")) ("123" :: T.Text) -- Present '2' (IxL(1) '2' | p="123" | q=1) --- PresentT '2' +-- Val '2' -- --- >>> pl @(IxL Id 15 (Char1 "x")) ("123" :: T.Text) +-- >>> pl @(IxL Id 15 (C "x")) ("123" :: T.Text) -- Present 'x' (IxL(15) index not found) --- PresentT 'x' +-- Val 'x' -- - -data IxL p q def -- p is the big value and q is the index and def is the default +data IxL p q def deriving Show +-- 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) - ) +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 [] + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts a [] case lr of Left e -> pure e Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" + let msg1 = msg0 <> "(" <> showL opts 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 + pure $ case getValueLR Inline 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] + Right _ -> mkNodeCopy opts rr (msg1 <> " index not found") [hh pp, hh qq] + Just ret -> pure $ mkNode opts (Val ret) (show3' 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" +-- Val "eF" -- -- >>> pz @(Id !! 20) ["abc","D","eF","","G"] --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- -- >>> pz @(Id !! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) --- PresentT 2 +-- Val 2 -- -- >>> pl @(Id !! 3) ("asfd" :: T.Text) -- Present 'd' (IxL(3) 'd' | p="asfd" | q=3) --- PresentT 'd' +-- Val 'd' -- -- >>> pl @(Id !! 4) ("asfd" :: T.Text) -- Error (!!) index not found (IxL(4)) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- -- >>> pl @(Id !! MEmptyT _) (Just "a") -- Present "a" (IxL(()) "a" | p=Just "a" | q=()) --- PresentT "a" +-- Val "a" -- -- >>> pl @(Id !! MEmptyT _) (Nothing @()) -- had to add @() to keep this happy: ghci is fine -- Error (!!) index not found (IxL(())) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- -- >>> pl @(Id !! 0) ('a','b','c') -- Present 'a' (IxL(0) 'a' | p=('a','b','c') | q=0) --- PresentT 'a' +-- Val 'a' -- --- >>> pl @(Id !! Failt _ "err") ('a','b','c') +-- >>> pl @(Id !! FailT _ "err") ('a','b','c') -- Error err (IxL) --- FailT "err" +-- Fail "err" -- -- >>> pl @(Id !! "d") (M.fromList $ zip (map (:[]) "abcd") [0 ..]) -- Present 3 (IxL("d") 3 | p=fromList [("a",0),("b",1),("c",2),("d",3)] | q="d") --- PresentT 3 +-- Val 3 -- --- >>> pl @(Id !! Head "d") (M.fromList $ zip "abcd" [0 ..]) -- had to String (instead of _) to keep this happy: ghci is fine +-- >>> pl @(Id !! C "d") (M.fromList $ zip "abcd" [0 ..]) -- Present 3 (IxL('d') 3 | p=fromList [('a',0),('b',1),('c',2),('d',3)] | q='d') --- PresentT 3 +-- Val 3 -- --- >>> pl @(Id !! Head "d") (Set.fromList "abcd") -- had to String (instead of _) to keep this happy: ghci is fine +-- >>> pl @(Id !! C "d") (Set.fromList "abcd") -- Present () (IxL('d') () | p=fromList "abcd" | q='d') --- PresentT () +-- Val () -- --- >>> pl @(Id !! HeadFail "failedn" "e") (Set.fromList "abcd") -- had to String (instead of _) to keep this happy: ghci is fine +-- >>> pl @(Id !! HeadFail "failedn" "e") (Set.fromList "abcd") -- Error (!!) index not found (IxL('e')) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- --- >>> pl @(Id !! Head "d") (M.fromList $ zip "abcd" [0 ..]) -- use Char1 "d" instead of "d" >> Head +-- >>> pl @(Id !! C "d") (M.fromList $ zip "abcd" [0 ..]) -- Present 3 (IxL('d') 3 | p=fromList [('a',0),('b',1),('c',2),('d',3)] | q='d') --- PresentT 3 +-- Val 3 -- -- >>> pl @(Id !! MEmptyT _) (Just 10) -- Present 10 (IxL(()) 10 | p=Just 10 | q=()) --- PresentT 10 +-- Val 10 -- -- >>> pl @(Id !! MEmptyT _) (Nothing @()) -- Error (!!) index not found (IxL(())) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- -- >>> pl @(Id !! 6) ['a'..'z'] -- Present 'g' (IxL(6) 'g' | p="abcdefghijklmnopqrstuvwxyz" | q=6) --- PresentT 'g' +-- Val 'g' -- --- >>> pl @(Snd Id !! Fst Id) (3,"abcde" :: String) +-- >>> pl @(Snd !! Fst) (3,"abcde") -- Present 'd' (IxL(3) 'd' | p="abcde" | q=3) --- PresentT 'd' +-- Val 'd' -- --- >>> pl @(Snd Id !! Fst Id) (4,[9,8]) +-- >>> pl @(Snd !! Fst) (4,[9,8]) -- Error (!!) index not found (IxL(4)) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- --- >>> pl @(2 &&& Id >> Snd Id !! Fst Id) ("abcdef" :: String) +-- >>> pl @(2 &&& Id >> Snd !! Fst) "abcdef" -- Present 'c' ((>>) 'c' | {IxL(2) 'c' | p="abcdef" | q=2}) --- PresentT 'c' +-- Val 'c' -- --- >>> pl @((Len >> Pred Id) &&& Id >> Snd Id !! Fst Id) "abcdef" +-- >>> pl @((Len >> Pred) &&& Id >> Snd !! Fst) "abcdef" -- Present 'f' ((>>) 'f' | {IxL(5) 'f' | p="abcdef" | q=5}) --- PresentT 'f' +-- Val 'f' -- -- >>> pl @(Id !! 3) ('a','b','c','d','e') -- Present 'd' (IxL(3) 'd' | p=('a','b','c','d','e') | q=3) --- PresentT 'd' +-- Val 'd' -- -- >>> pl @(Id !! "s") $ M.fromList [("t",1), ("s", 20), ("s", 99)] -- Present 99 (IxL("s") 99 | p=fromList [("s",99),("t",1)] | q="s") --- PresentT 99 +-- Val 99 -- --- >>> pl @(Id !! Char1 "d") (M.fromList $ zip "abcd" [0 ..]) +-- >>> pl @(Id !! C "d") (M.fromList $ zip "abcd" [0 ..]) -- Present 3 (IxL('d') 3 | p=fromList [('a',0),('b',1),('c',2),('d',3)] | q='d') --- PresentT 3 +-- Val 3 -- --- >>> pl @(Id !! FromString _ "d" &&& (Map (Snd Id >> Gt 3 >> Coerce SG.Any) (IToList _ Id) >> MConcat Id)) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) --- Present (3,Any {getAny = True}) (W '(3,Any {getAny = True})) --- PresentT (3,Any {getAny = True}) +-- >>> pl @(Id !! FromString _ "d" &&& (Map' (Snd >> Gt 3 >> Coerce SG.Any) (IToList _) >> MConcat Id)) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) +-- Present (3,Any {getAny = True}) ('(3,Any {getAny = True})) +-- Val (3,Any {getAny = 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 ..]) --- Present (3,True) (W '(3,True)) --- PresentT (3,True) +-- >>> pl @(Id !! FromString _ "d" &&& (Map' (Snd >> Gt 3 >> Wrap SG.Any Id) (IToList _) >> MConcat Id >> Unwrap)) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) +-- Present (3,True) ('(3,True)) +-- Val (3,True) -- -- >>> pl @(Id !! FromString _ "d") (M.fromList $ zip (map T.singleton "abcd") [0 ..]) -- Present 3 (IxL("d") 3 | p=fromList [("a",0),("b",1),("c",2),("d",3)] | q="d") --- PresentT 3 +-- Val 3 -- -- >>> pl @(Id !! FromString _ "d") (M.fromList $ zip (map T.singleton "abcd") [0 ..]) -- Present 3 (IxL("d") 3 | p=fromList [("a",0),("b",1),("c",2),("d",3)] | q="d") --- PresentT 3 +-- Val 3 -- -- >>> pl @(Id !! 2 !! 0) [[1..5],[10..14],[100..110]] -- Present 100 (IxL(0) 100 | p=[100,101,102,103,104,105,106,107,108,109,110] | q=0) --- PresentT 100 +-- Val 100 -- -- >>> pl @(Id !! 1 !! 7) [[1..5],[10..14],[100..110]] -- Error (!!) index not found (IxL(7)) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- -- >>> pl @(Id !! 1) [('x',14),('y',3),('z',5)] -- Present ('y',3) (IxL(1) ('y',3) | p=[('x',14),('y',3),('z',5)] | q=1) --- PresentT ('y',3) +-- Val ('y',3) -- -- >>> pl @(Id !! 14) [('x',14),('y',3),('z',5)] -- Error (!!) index not found (IxL(14)) --- FailT "(!!) index not found" +-- Fail "(!!) index not found" -- - -data p !! q -type BangBangT p q = IxL p q (Failp "(!!) index not found") +data p !! q deriving Show +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' +-- | 'lookup' leveraging 'Ixed': see '!!?' -- --- >>> pz @(Lookup Id 2) ["abc","D","eF","","G"] --- PresentT (Just "eF") +-- >>> pz @(Lookup 2 Id) ["abc","D","eF","","G"] +-- Val (Just "eF") -- --- >>> pz @(Lookup Id 20) ["abc","D","eF","","G"] --- PresentT Nothing +-- >>> pz @(Lookup 20 Id) ["abc","D","eF","","G"] +-- Val Nothing -- --- >>> pl @(FromList (M.Map _ _) >> Lookup Id (Char1 "y")) [('x',True),('y',False)] --- Present Just False ((>>) Just False | {Lookup('y') False | p=fromList [('x',True),('y',False)] | q='y'}) --- PresentT (Just False) +-- >>> pl @(FromList (M.Map _ _) >> Lookup (C "y") Id) [('x',True),('y',False)] +-- Present Just False ((>>) Just False | {Lookup('y') False | q=fromList [('x',True),('y',False)] | p='y'}) +-- Val (Just False) -- --- >>> pl @(FromList (M.Map _ _) >> Lookup Id (Char1 "z")) [('x',True),('y',False)] +-- >>> pl @(FromList (M.Map _ _) >> Lookup (C "z") Id) [('x',True),('y',False)] -- Present Nothing ((>>) Nothing | {Lookup('z') not found}) --- PresentT Nothing --- --- >>> pl @(FromList (M.Map _ _) >> Lookup Id %% Char1 "y") [('x',True),('y',False)] --- Present Just False ((>>) Just False | {Lookup('y') False | p=fromList [('x',True),('y',False)] | q='y'}) --- PresentT (Just False) +-- Val Nothing -- --- >>> pl @(Lookup Id 1) [('x',14),('y',3),('z',5)] --- Present Just ('y',3) (Lookup(1) ('y',3) | p=[('x',14),('y',3),('z',5)] | q=1) --- PresentT (Just ('y',3)) +-- >>> pl @(Lookup 1 Id) [('x',14),('y',3),('z',5)] +-- Present Just ('y',3) (Lookup(1) ('y',3) | q=[('x',14),('y',3),('z',5)] | p=1) +-- Val (Just ('y',3)) -- --- >>> pl @(Lookup Id 14) [('x',14),('y',3),('z',5)] +-- >>> pl @(Lookup 14 Id) [('x',14),('y',3),('z',5)] -- Present Nothing (Lookup(14) not found) --- PresentT Nothing --- --- >>> pl @(Lookup "abcdef" 3) () --- Present Just 'd' (Lookup(3) 'd' | p="abcdef" | q=3) --- PresentT (Just 'd') +-- Val Nothing -- --- >>> pl @(Lookup '[1,2,3,4,5,6] 4) () --- Present Just 5 (Lookup(4) 5 | p=[1,2,3,4,5,6] | q=4) --- PresentT (Just 5) +-- >>> pl @(Lookup 3 "abcdef") () +-- Present Just 'd' (Lookup(3) 'd' | q="abcdef" | p=3) +-- Val (Just 'd') -- --- >>> pl @(FromList (M.Map _ _)) [(4,"x"),(5,"dd")] --- Present fromList [(4,"x"),(5,"dd")] (FromList fromList [(4,"x"),(5,"dd")]) --- PresentT (fromList [(4,"x"),(5,"dd")]) +-- >>> pl @(Lookup 4 '[1,2,3,4,5,6]) () +-- Present Just 5 (Lookup(4) 5 | q=[1,2,3,4,5,6] | p=4) +-- Val (Just 5) -- -data Lookup p q +data Lookup p q deriving Show -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)) - ) +instance ( P p a + , P q a + , Show (PP q a) + , Ixed (PP q a) + , PP p a ~ Index (PP q a) + , Show (Index (PP q a)) + , Show (IxValue (PP q a)) + ) => P (Lookup p q) a where - type PP (Lookup p q) a = Maybe (IxValue (PP p a)) + type PP (Lookup p q) a = Maybe (IxValue (PP q a)) eval _ opts a = do let msg0 = "Lookup" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a [] + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts a [] pure $ case lr of Left e -> e Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" + let msg1 = msg0 <> "(" <> showL opts p <> ")" 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 + in case q ^? ix p of + Nothing -> mkNode opts (Val Nothing) (msg1 <> " not found") hhs + Just ret -> mkNode opts (Val (Just ret)) (show3' opts msg1 ret "q=" q <> showVerbose opts " | p=" p) hhs -- | type operator version of 'Lookup' -- --- >>> pl @((Id !!? Char1 "d") > MkJust 99 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) +-- >>> pl @((Id !!? C "d") > MkJust 99 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) -- False (False || False | (Just 4 > Just 99) || (4 <= 3)) --- FalseT +-- Val False -- --- >>> pz @((Id !!? Char1 "d") > MkJust 2 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) --- TrueT +-- >>> pz @((Id !!? C "d") > MkJust 2 || Length Id <= 3) (M.fromList $ zip "abcd" [1..]) +-- Val True -- -data p !!? q -type BangBangQT p q = Lookup p q +data p !!? q deriving Show +type BangBangQT p q = Lookup q p 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)) - --- | convert a list to a 2-tuple -type Tuple2 p = '(p !! 0, p !! 1) --- | convert a list to a 3-tuple -type Tuple3 p = '(p !! 0, p !! 1, p !! 2) --- | convert a list to a 4-tuple -type Tuple4 p = '(p !! 0, p !! 1, p !! 2, p !! 3) --- | convert a list to a 5-tuple -type Tuple5 p = '(p !! 0, p !! 1, p !! 2, p !! 3, p !! 4) --- | convert a list to a 6-tuple -type Tuple6 p = '(p !! 0, p !! 1, p !! 2, p !! 3, p !! 4, p !! 5)
src/Predicate/Data/Iterator.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,11 +12,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted iterator functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted iterator functions module Predicate.Data.Iterator ( Scanl , ScanN @@ -34,6 +26,7 @@ , IterateWhile , IterateNWhile , IterateNUntil + , UnfoldN , Para , ParaN @@ -43,6 +36,7 @@ ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.Tuple (type (***)) import Predicate.Data.Ordering (type (>)) @@ -51,11 +45,11 @@ import Predicate.Data.Maybe (MaybeBool) import GHC.TypeLits (Nat, KnownNat) import qualified GHC.TypeLits as GL -import Control.Lens hiding (iall) -import Data.Proxy -import Data.Maybe -import Control.Arrow -import Data.Void +import Control.Lens +import Data.Proxy (Proxy(Proxy)) +import Data.Maybe (catMaybes) +import Control.Arrow (Arrow((&&&))) +import Data.Void (Void) -- $setup -- >>> import Predicate.Prelude @@ -64,7 +58,6 @@ -- >>> :set -XTypeOperators -- >>> :set -XAllowAmbiguousTypes -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> :set -XFlexibleContexts -- >>> import Data.Time @@ -72,90 +65,89 @@ -- | 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 @(Scanl (Snd :+ Fst) Fst Snd) ([99],[1..5]) +-- Val [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] -- --- >>> pl @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[]) +-- >>> pl @(Scanl (Snd :+ Fst) Fst Snd) ([99],[]) -- Present [[99]] (Scanl [[99]] | b=[99] | as=[]) --- PresentT [[99]] +-- Val [[99]] -- - -data Scanl p q r +data Scanl p q r deriving Show -- 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 - ) +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 [] + lr <- runPQ NoInline 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 + 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 = + | i >= oRecursion opts = pure (rs, Left $ mkNode opts (Fail (msg0 <> ":recursion limit i=" <> show i)) ("(b,as')=" <> showL opts (b,as')) []) + | otherwise = case as' of - [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (PresentT q) (msg0 <> "(done)") [])], Right ()) + [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (Val q) (msg0 <> "(done)") [])], Right ()) a:as -> do pp :: TT b <- evalHide @p opts (b,a) - case getValueLR opts (msg0 <> " i=" <> showIndex i <> " a=" <> show a) pp [] of + case getValueLR NoInline opts (msg0 <> " i=" <> show i <> " a=" <> showL opts 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) + pure $ case splitAndAlign opts msg0 (((0,q), mkNode opts (Val q) (msg0 <> "(initial)") []) : ts) of + Left e -> errorInProgram $ "Scanl e=" ++ show (hh 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) + Left e -> mkNodeCopy opts e msg0 (hh qq : hh rr : map (hh . prefixNumberToTT) itts ++ [hh e]) + Right () -> mkNode opts (Val vals) (show3' opts msg0 vals "b=" q <> showVerbose opts " | as=" r) (hh qq : hh rr : map (hh . prefixNumberToTT) itts) -- | iterates n times keeping all the results -- --- >>> pz @(ScanN 4 (Succ Id) Id) 'c' --- PresentT "cdefg" +-- >>> pz @(ScanN 4 Succ Id) 'c' +-- Val "cdefg" -- --- >>> pz @(Dup >> ScanN 4 (Pred Id *** Succ Id) Id) 'g' --- PresentT [('g','g'),('f','h'),('e','i'),('d','j'),('c','k')] +-- >>> pz @(Dup >> ScanN 4 (Pred *** Succ) Id) 'g' +-- Val [('g','g'),('f','h'),('e','i'),('d','j'),('c','k')] -- --- >>> pz @(ScanN 4 (Succ Id) Id) 4 --- PresentT [4,5,6,7,8] +-- >>> pz @(ScanN 4 Succ Id) 4 +-- Val [4,5,6,7,8] -- --- >>> pz @('(0,1) >> ScanN 20 '(Snd Id, Fst Id + Snd Id) 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,6765] +-- >>> pz @('(0,1) >> ScanN 20 '(Snd, Fst + Snd) Id >> Map Fst) "sdf" +-- Val [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765] -- --- >>> pl @(ScanN 2 (Succ Id) Id) 4 +-- >>> pl @(ScanN 2 Succ Id) 4 -- Present [4,5,6] (Scanl [4,5,6] | b=4 | as=[1,2]) --- PresentT [4,5,6] +-- Val [4,5,6] -- -- >>> pl @(ScanN 5 Id Id) 4 -- Present [4,4,4,4,4,4] (Scanl [4,4,4,4,4,4] | b=4 | as=[1,2,3,4,5]) --- PresentT [4,4,4,4,4,4] +-- Val [4,4,4,4,4,4] -- --- >>> pl @(ScanN 2 (Succ Id) Id >> PadR 10 (MEmptyT Ordering) Id) LT +-- >>> pl @(ScanN 2 Succ Id >> PadR 10 (MEmptyT Ordering) Id) LT -- Present [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ] ((>>) [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ] | {PadR 10 pad=EQ [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ] | [LT,EQ,GT]}) --- PresentT [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ] +-- Val [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ] -- --- >>> pl @(ScanN 4 (Pred Id) Id) 99 +-- >>> pl @(ScanN 4 Pred Id) 99 -- Present [99,98,97,96,95] (Scanl [99,98,97,96,95] | b=99 | as=[1,2,3,4]) --- PresentT [99,98,97,96,95] +-- Val [99,98,97,96,95] -- -data ScanN n p q -type ScanNT n p q = Scanl (Fst Id >> p) q (1...n) -- n times using q then run p +data ScanN n p q deriving Show +type ScanNT n p q = Scanl (Fst >> p) q (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 @@ -163,20 +155,20 @@ -- | tuple version of 'ScanN' -- --- >>> pl @(ScanNA (Succ Id)) (4,'a') +-- >>> pl @(ScanNA Succ) (4,'a') -- Present "abcde" (Scanl "abcde" | b='a' | as=[1,2,3,4]) --- PresentT "abcde" +-- Val "abcde" -- --- >>> pl @(ScanNA (Tail Id)) (4,"abcd" :: String) +-- >>> pl @(ScanNA Tail) (4,"abcd") -- Present ["abcd","bcd","cd","d",""] (Scanl ["abcd","bcd","cd","d",""] | b="abcd" | as=[1,2,3,4]) --- PresentT ["abcd","bcd","cd","d",""] +-- Val ["abcd","bcd","cd","d",""] -- --- >>> pl @(Len &&& Id >> ScanNA (Tail Id)) "abcd" +-- >>> pl @(Len &&& Id >> ScanNA Tail) "abcd" -- Present ["abcd","bcd","cd","d",""] ((>>) ["abcd","bcd","cd","d",""] | {Scanl ["abcd","bcd","cd","d",""] | b="abcd" | as=[1,2,3,4]}) --- PresentT ["abcd","bcd","cd","d",""] +-- Val ["abcd","bcd","cd","d",""] -- -data ScanNA q -type ScanNAT q = ScanN (Fst Id) q (Snd Id) +data ScanNA q deriving Show +type ScanNAT q = ScanN Fst q Snd instance P (ScanNAT q) x => P (ScanNA q) x where type PP (ScanNA q) x = PP (ScanNAT q) x @@ -184,43 +176,41 @@ -- | iterates n times keeping only the last result -- --- >>> pz @(FoldN 4 (Succ Id) Id) 'c' --- PresentT 'g' +-- >>> pz @(FoldN 4 Succ Id) 'c' +-- Val 'g' -- --- >>> pz @(ReadP Day Id >> Id ... FoldN 5 (Succ Id) Id) "2020-07-27" --- PresentT [2020-07-27,2020-07-28,2020-07-29,2020-07-30,2020-07-31,2020-08-01] +-- >>> pz @(ReadP Day Id >> Id ... FoldN 5 Succ Id) "2020-07-27" +-- Val [2020-07-27,2020-07-28,2020-07-29,2020-07-30,2020-07-31,2020-08-01] -- --- >>> pl @(FoldN 2 (Succ Id) Id) LT --- Present GT (Last GT | [LT,EQ,GT]) --- PresentT GT +-- >>> pl @(FoldN 2 Succ Id) LT +-- Present GT ((>>) GT | {Last GT | [LT,EQ,GT]}) +-- Val GT -- --- >>> pl @(FoldN 30 (Succ Id) Id) LT --- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument (Last) --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" +-- >>> pl @(FoldN 30 Succ Id) LT +-- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument (Scanl) +-- Fail "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" -- --- >>> pl @(FoldN 6 (Succ Id) Id) 'a' --- Present 'g' (Last 'g' | "abcdefg") --- PresentT 'g' +-- >>> pl @(FoldN 6 Succ Id) 'a' +-- Present 'g' ((>>) 'g' | {Last 'g' | "abcdefg"}) +-- Val 'g' -- --- >>> pl @(FoldN 6 (Pred Id) Id) 'a' --- Present '[' (Last '[' | "a`_^]\\[") --- PresentT '[' +-- >>> pl @(FoldN 6 Pred Id) 'a' +-- Present '[' ((>>) '[' | {Last '[' | "a`_^]\\["}) +-- Val '[' -- --- >>> pl @(FoldN 0 (Succ Id) Id) LT --- Present LT (Last LT | [LT]) --- PresentT LT +-- >>> pl @(FoldN 0 Succ Id) LT +-- Present LT ((>>) LT | {Last LT | [LT]}) +-- Val LT -- --- >>> pl @(FoldN 2 (Succ Id) Id >> FoldN 2 (Pred Id) Id) LT +-- >>> pl @(FoldN 2 Succ Id >> FoldN 2 Pred Id) LT -- Present LT ((>>) LT | {Last LT | [GT,EQ,LT]}) --- PresentT LT +-- Val LT -- --- >>> pl @(FoldN 4 ((Id &&& Id) >> SapA) Id) "abc" --- Present "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" (Last "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" | ["abc","abcabc","abcabcabcabc","abcabcabcabcabcabcabcabc","abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"]) --- PresentT "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" +-- >>> pz @(FoldN 4 (Id <> Id) Id) "abc" -- same as above +-- Val "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" -- - -data FoldN n p q -type FoldNT n p q = Last (ScanN n p q) +data FoldN n p q deriving Show +type FoldNT n p q = ScanN n p q >> Last 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 @@ -228,48 +218,47 @@ -- | Foldl similar to 'foldl' -- --- >>> pl @(Foldl (Fst Id + Snd Id) 0 (1 ... 10)) () --- Present 55 (Last 55 | [0,1,3,6,10,15,21,28,36,45,55]) --- PresentT 55 +-- >>> pl @(Foldl (Fst + Snd) 0 (1 ... 10)) () +-- Present 55 ((>>) 55 | {Last 55 | [0,1,3,6,10,15,21,28,36,45,55]}) +-- Val 55 -- --- >>> pz @(Foldl (Snd Id :+ Fst Id) '[99] (1 ... 10)) () --- PresentT [10,9,8,7,6,5,4,3,2,1,99] +-- >>> pz @(Foldl (Snd :+ Fst) '[99] (1 ... 10)) () +-- Val [10,9,8,7,6,5,4,3,2,1,99] -- --- >>> pl @(Foldl (Fst Id) '() (EnumFromTo 1 9999)) () --- Error Scanl list size exceeded (Last) --- FailT "Scanl list size exceeded" +-- >>> pl @(Foldl Fst '() (EnumFromTo 1 9999)) () +-- Error Scanl list size exceeded (max is 100) +-- Fail "Scanl list size exceeded" -- --- >>> pl @(Foldl (Guard "someval" (Fst Id < Snd Id) >> Snd Id) (Head Id) (Tail Id)) [1,4,7,9,16] --- Present 16 (Last 16 | [1,4,7,9,16]) --- PresentT 16 +-- >>> pl @(Foldl (Guard "someval" (Fst < Snd) >> Snd) Head Tail) [1,4,7,9,16] +-- Present 16 ((>>) 16 | {Last 16 | [1,4,7,9,16]}) +-- Val 16 -- --- >>> pl @(Foldl (Guard (PrintT "%d not less than %d" Id) (Fst Id < Snd Id) >> Snd Id) (Head Id) (Tail Id)) [1,4,7,6,16::Int] --- Error 7 not less than 6 (Last) --- FailT "7 not less than 6" +-- >>> pl @(Foldl (Guard (PrintT "%d not less than %d" Id) (Fst < Snd) >> Snd) Head Tail) [1,4,7,6,16] +-- Error 7 not less than 6 (Scanl) +-- Fail "7 not less than 6" -- --- >>> pl @(Foldl (If ((Fst Id >> Fst Id) && (Snd Id > Snd (Fst Id))) '( 'True, Snd Id) '( 'False, Snd (Fst Id))) '( 'True, Head Id) (Tail Id)) [1,4,7,9,16] --- Present (True,16) (Last (True,16) | [(True,1),(True,4),(True,7),(True,9),(True,16)]) --- PresentT (True,16) +-- >>> pl @(Foldl (If (L11 && (Snd > L12)) '( 'True, Snd) '( 'False, L12)) '( 'True, Head) Tail) [1,4,7,9,16] +-- Present (True,16) ((>>) (True,16) | {Last (True,16) | [(True,1),(True,4),(True,7),(True,9),(True,16)]}) +-- Val (True,16) -- --- >>> pl @(Foldl (If ((Fst Id >> Fst Id) && (Snd Id > Snd (Fst Id))) '( 'True, Snd Id) '( 'False, Snd (Fst Id))) '( 'True, Head Id) (Tail Id)) [1,4,7,9,16,2] --- Present (False,16) (Last (False,16) | [(True,1),(True,4),(True,7),(True,9),(True,16),(False,16)]) --- PresentT (False,16) +-- >>> pl @(Foldl (If (L11 && (Snd > L12)) '( 'True, Snd) '( 'False, L12)) '( 'True, Head) Tail) [1,4,7,9,16,2] +-- Present (False,16) ((>>) (False,16) | {Last (False,16) | [(True,1),(True,4),(True,7),(True,9),(True,16),(False,16)]}) +-- Val (False,16) -- --- >>> pl @(Foldl (Snd Id :+ Fst Id) (MEmptyT [_]) Id) [1..5] --- Present [5,4,3,2,1] (Last [5,4,3,2,1] | [[],[1],[2,1],[3,2,1],[4,3,2,1],[5,4,3,2,1]]) --- PresentT [5,4,3,2,1] +-- >>> pl @(Foldl (Snd :+ Fst) (MEmptyT [_]) Id) [1..5] +-- Present [5,4,3,2,1] ((>>) [5,4,3,2,1] | {Last [5,4,3,2,1] | [[],[1],[2,1],[3,2,1],[4,3,2,1],[5,4,3,2,1]]}) +-- Val [5,4,3,2,1] -- --- >>> pl @('Just Uncons >> Foldl (If (Fst (Fst Id)) (If (Snd (Fst Id) < Snd Id) '( 'True,Snd Id) '( 'False, Snd Id)) (Fst Id)) '( 'True,Fst Id) (Snd Id)) [-10,-2,2,3,4,10,9,11] +-- >>> pl @('Just Uncons >> Foldl (If L11 (If (L12 < Snd) '( 'True,Snd) '( 'False, Snd)) Fst) '( 'True,Fst) Snd) [-10,-2,2,3,4,10,9,11] -- Present (False,9) ((>>) (False,9) | {Last (False,9) | [(True,-10),(True,-2),(True,2),(True,3),(True,4),(True,10),(False,9),(False,9)]}) --- PresentT (False,9) +-- Val (False,9) -- --- >>> pl @('Just Uncons >> Foldl (If (Fst (Fst Id)) (If (Snd (Fst Id) < Snd Id) '( 'True,Snd Id) '( 'False, Snd Id)) (Fst Id)) '( 'True,Fst Id) (Snd Id)) [-10,2,3,4,10,11] +-- >>> pl @('Just Uncons >> Foldl (If L11 (If (L12 < Snd) '( 'True,Snd) '( 'False, Snd)) Fst) '( 'True,Fst) Snd) [-10,2,3,4,10,11] -- Present (True,11) ((>>) (True,11) | {Last (True,11) | [(True,-10),(True,2),(True,3),(True,4),(True,10),(True,11)]}) --- PresentT (True,11) +-- Val (True,11) -- - -data Foldl p q r -type FoldLT p q r = Last (Scanl p q r) +data Foldl p q r deriving Show +type FoldLT p q r = Scanl p q r >> Last 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 @@ -278,177 +267,208 @@ -- | similar to 'Data.List.unfoldr' -- -- >>> pz @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] --- PresentT [[1,2],[3,4],[5]] +-- Val [[1,2],[3,4],[5]] -- -- >>> pl @(Unfoldr (If Null (MkNothing _) ('(Take 3 Id, Drop 1 Id) >> MkJust Id)) Id) "abcdefghi" -- Present ["abc","bcd","cde","def","efg","fgh","ghi","hi","i"] (Unfoldr "abcdefghi" ["abc","bcd","cde","def","efg","fgh","ghi","hi","i"] | s="abcdefghi") --- PresentT ["abc","bcd","cde","def","efg","fgh","ghi","hi","i"] +-- Val ["abc","bcd","cde","def","efg","fgh","ghi","hi","i"] -- -- >>> pl @(Unfoldr (If Null (MkNothing _) (Pure _ (SplitAt 2 Id))) Id) [1..5] -- Present [[1,2],[3,4],[5]] (Unfoldr [1,2,3,4,5] [[1,2],[3,4],[5]] | s=[1,2,3,4,5]) --- PresentT [[1,2],[3,4],[5]] +-- Val [[1,2],[3,4],[5]] -- -- >>> pl @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] -- Present [[1,2],[3,4],[5]] (Unfoldr [1,2,3,4,5] [[1,2],[3,4],[5]] | s=[1,2,3,4,5]) --- PresentT [[1,2],[3,4],[5]] +-- Val [[1,2],[3,4],[5]] -- -- >>> pl @(Unfoldr (If Null (MkNothing _) (Guard "yy" (Len < 3) >> Pure _ (SplitAt 2 Id))) Id) [1..5] -- Error yy (Unfoldr [1,2,3,4,5]) --- FailT "yy" +-- Fail "yy" -- -- >>> pl @(Unfoldr (MaybeBool (Not Null) (Guard "yy" (Len < 3) >> SplitAt 2 Id)) Id) [1..5] -- Error yy (Unfoldr [1,2,3,4,5]) --- FailT "yy" +-- Fail "yy" -- -- >>> pl @(Unfoldr (Guard "xx" (Len > 4) >> Uncons) Id) [1..10] -- Error xx (Unfoldr [1,2,3,4,5,6,7,8,9,10]) --- FailT "xx" +-- Fail "xx" -- -- >>> pl @(Unfoldr Uncons Id) [1..10] -- Present [1,2,3,4,5,6,7,8,9,10] (Unfoldr [1,2,3,4,5,6,7,8,9,10] [1,2,3,4,5,6,7,8,9,10] | s=[1,2,3,4,5,6,7,8,9,10]) --- PresentT [1,2,3,4,5,6,7,8,9,10] +-- Val [1,2,3,4,5,6,7,8,9,10] -- - -data Unfoldr p q +-- >>> pan @(Unfoldr (If (Id < 1) (MkNothing _) (MkJust (DivMod Id 2 >> Swap))) Id) 8 +-- P Unfoldr 8 [0,0,0,1] +-- | +-- +- P Id 8 +-- | +-- +- P i=1: If 'False Just (0,4) +-- | +-- +- P i=2: If 'False Just (0,2) +-- | +-- +- P i=3: If 'False Just (0,1) +-- | +-- +- P i=4: If 'False Just (1,0) +-- | +-- `- P i=5: If 'True Nothing +-- Val [0,0,0,1] +-- +data Unfoldr p q deriving Show -instance (PP q a ~ s - , PP p s ~ Maybe (b,s) - , P q a - , P p s - , Show s - , Show b - ) +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))] + type PP (Unfoldr p q) a = [UnfoldrT (PP p (PP q a))] eval _ opts z = do let msg0 = "Unfoldr" qq <- eval (Proxy @q) opts z - case getValueLR opts msg0 qq [] of + case getValueLR NoInline 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) []) + ff i s rs | i >= oRecursion opts = pure (rs, Left $ mkNode opts (Fail (msg1 <> ":recursion limit i=" <> show i)) ("s=" <> showL opts s) []) | otherwise = do pp :: TT (PP p s) <- evalHide @p opts s - case getValueLR opts (msg1 <> " i=" <> showIndex i <> " s=" <> show s) pp [] of + case getValueLR NoInline opts (msg1 <> " i=" <> show i <> " s=" <> show s) pp [] of Left e -> pure (rs, Left e) - Right Nothing -> pure (rs, Right ()) + Right Nothing -> pure (rs ++ [((i,Nothing), pp)], 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) + Left e -> errorInProgram $ "Unfoldr e=" ++ show (hh 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]) + Left e -> mkNodeCopy opts e msg1 (hh qq : map (hh . prefixNumberToTT) 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) + in mkNode opts (Val ret) (show3' opts msg1 ret "s=" q ) (hh qq : map (hh . prefixNumberToTT) itts) -type family UnfoldT mbs where - UnfoldT (Maybe (b,s)) = b +type family UnfoldrT mbs where + UnfoldrT (Maybe (b, _s)) = b --- | unfolds a value applying \'f\' until the condition \'p\' is true +-- | run @p@ @n@ times with state @s@ -- --- >>> pl @(IterateUntil (Id < 90) (Pred Id)) 94 +-- >>> :m + System.Random +-- >>> pz @(UnfoldN 10 (RandomRNext Int 1 100 Id) Id) (mkStdGen 3) +-- Val [64,94,33,26,12,8,81,41,21,89] +-- +data UnfoldN n p s deriving Show + +-- have to rewrite (a,s) to (a,(s,n)) hence the L11 ... +type IterateNT n p s = Unfoldr (MaybeBool (Snd > 0) ((p *** Pred) >> '(L11,'(L12,Snd)))) '(s,n) + +instance P (IterateNT n p s) x => P (UnfoldN n p s) x where + type PP (UnfoldN n p s) x = PP (IterateNT n p s) x + eval _ = eval (Proxy @(IterateNT n p s)) + + +-- | unfolds a value applying @f@ until the condition @p@ is true +-- +-- >>> pl @(IterateUntil (Id < 90) Pred) 94 -- Present [94,93,92,91,90] (Unfoldr 94 [94,93,92,91,90] | s=94) --- PresentT [94,93,92,91,90] +-- Val [94,93,92,91,90] -- -data IterateUntil p f +data IterateUntil p f deriving Show 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)) --- | unfolds a value applying \'f\' while the condition \'p\' is true +-- | unfolds a value applying @f@ while the condition @p@ is true -- --- >>> pl @(IterateWhile (Id > 90) (Pred Id)) 94 +-- >>> pl @(IterateWhile (Id > 90) Pred) 94 -- Present [94,93,92,91] (Unfoldr 94 [94,93,92,91] | s=94) --- PresentT [94,93,92,91] +-- Val [94,93,92,91] -- -data IterateWhile p f +data IterateWhile p f deriving Show 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)) --- | unfolds a value applying \'f\' while the condition \'p\' is true or \'n\' times +-- | unfolds a value applying @f@ while the condition @p@ is true or @n@ times -- --- >>> pl @(IterateNWhile 10 (Id > 90) (Pred Id)) 95 +-- >>> pl @(IterateNWhile 10 (Id > 90) Pred) 95 -- Present [95,94,93,92,91] ((>>) [95,94,93,92,91] | {Map [95,94,93,92,91] | [(10,95),(9,94),(8,93),(7,92),(6,91)]}) --- PresentT [95,94,93,92,91] +-- Val [95,94,93,92,91] -- --- >>> pl @(IterateNWhile 3 (Id > 90) (Pred Id)) 95 +-- >>> pl @(IterateNWhile 3 (Id > 90) Pred) 95 -- Present [95,94,93] ((>>) [95,94,93] | {Map [95,94,93] | [(3,95),(2,94),(1,93)]}) --- PresentT [95,94,93] +-- Val [95,94,93] -- -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 +data IterateNWhile n p f deriving Show +type IterateNWhileT n p f = '(n, Id) >> IterateWhile (Fst > 0 && (Snd >> p)) (Pred *** f) >> Map Snd 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)) --- | unfolds a value applying \'f\' until the condition \'p\' is true or \'n\' times +-- | unfolds a value applying @f@ until the condition @p@ is true or @n@ times -- --- >>> pl @(IterateNUntil 10 (Id <= 90) (Pred Id)) 95 +-- >>> pl @(IterateNUntil 10 (Id <= 90) Pred) 95 -- Present [95,94,93,92,91] ((>>) [95,94,93,92,91] | {Map [95,94,93,92,91] | [(10,95),(9,94),(8,93),(7,92),(6,91)]}) --- PresentT [95,94,93,92,91] +-- Val [95,94,93,92,91] -- --- >>> pl @(IterateNUntil 3 (Id <= 90) (Pred Id)) 95 +-- >>> pl @(IterateNUntil 3 (Id <= 90) Pred) 95 -- Present [95,94,93] ((>>) [95,94,93] | {Map [95,94,93] | [(3,95),(2,94),(1,93)]}) --- PresentT [95,94,93] +-- Val [95,94,93] -- --- >>> pl @(IterateNUntil 9999 'False I) 1 --- Error Unfoldr (9999,1):recursion limit i=100 ((9999,1) (>>) rhs failed) --- FailT "Unfoldr (9999,1):recursion limit i=100" +-- >>> pl @(IterateNUntil 9999 'False Id) 1 +-- Error Unfoldr (9999,1):recursion limit i=100 (Unfoldr (9999,1)) +-- Fail "Unfoldr (9999,1):recursion limit i=100" -- -data IterateNUntil n p f +data IterateNUntil n p f deriving Show 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)) -data ParaImpl (n :: Nat) (os :: [k]) +data ParaImpl (n :: Nat) (os :: [k]) deriving Show -- | runs values in parallel unlike 'Do' which is serial -- -- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30] --- PresentT [10,21,120] +-- Val [10,21,120] -- -- >>> pz @(Para '[Id,Id + 1,Id * 4]) [10,20,30,40] --- FailT "Para:invalid length(4) expected 3" +-- Fail "Para:invalid length(4) expected 3" -- -- >>> pl @(Para '[W 'True, Ge 12, W 'False, Lt 2]) [1,2,-99,-999] -- Present [True,False,False,True] (Para(0) [True,False,False,True] | [1,2,-99,-999]) --- PresentT [True,False,False,True] +-- Val [True,False,False,True] -- -- >>> pl @(Para '[W 'True, Ge 12, W 'False, Lt 2]) [1,2,-99] -- Error Para:invalid length(3) expected 4 --- FailT "Para:invalid length(3) expected 4" +-- Fail "Para:invalid length(3) expected 4" -- -- >>> pl @(Para '[W 'True, Ge 12, W 'False, Lt 2]) [1,2,-99,-999,1,1,2] -- Error Para:invalid length(7) expected 4 --- FailT "Para:invalid length(7) expected 4" +-- Fail "Para:invalid length(7) expected 4" -- -data Para (ps :: [k]) +data Para (ps :: [k]) deriving Show -- 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 +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) "" [] + in pure $ mkNode opts (Fail msg1) "" [] else eval (Proxy @(ParaImpl (LenT ps) ps)) opts as -- only allow non empty lists -- might need [a] ~ x but it seems fine @@ -457,102 +477,106 @@ 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] +instance ( KnownNat n + , Show a + , Show (PP p a) + , P p a + , x ~ [a] + ) => P (ParaImpl n '[p]) x where + type PP (ParaImpl n '[p]) x = [PP p (ExtractAFromTA x)] eval _ opts as' = do let msgbase0 = "Para" - msgbase1 = msgbase0 <> "(" <> show n <> ")" - n :: Int - n = nat @n + msgbase1 = msgbase0 <> "(" <> show (n-1) <> ")" + n = nat @n @Int case as' of [a] -> do pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msgbase1 pp [] of + pure $ case getValueLR NoInline 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] + Right b -> + let ret = [b] + in mkNode opts (Val ret) (msgbase1 <> " " <> showL opts ret <> 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 +instance ( KnownNat n + , GetLen ps + , P p a + , P (ParaImpl n (p1 ': ps)) x + , PP (ParaImpl n (p1 ': ps)) x ~ [PP p a] + , Show a + , Show (PP p a) + , x ~ [a] + ) + => P (ParaImpl n (p ': p1 ': ps)) x where + type PP (ParaImpl n (p ': p1 ': ps)) x = [PP p (ExtractAFromTA x)] + + eval _ _ [] = errorInProgram "ParaImpl n+1 case has no data left" + + eval _ opts (a:as) = do let cpos = n-pos-1 - msgbase0 = msgbase2 <> "(" <> showIndex cpos <> " of " <> show n <> ")" - msgbase1 = msgbase2 <> "(" <> showIndex cpos <> ")" - msgbase2 = "Para" + msgbase0 = "Para(" <> show cpos <> " of " <> show (n-1) <> ")" + msgbase1 = "Para(" <> show cpos <> ")" 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" + pp <- eval (Proxy @p) opts a + case getValueLR NoInline opts msgbase0 pp [] of + Left e -> pure e + Right b -> do + qq <- eval (Proxy @(ParaImpl n (p1 ': ps))) opts as + pure $ case getValueLR Inline opts "" qq [hh pp] of + Left e -> e + Right bs -> mkNode opts (Val (b:bs)) (msgbase1 <> " " <> showL opts (b:bs) <> showVerbose opts " | " (a:as)) [hh pp, hh qq] -- | leverages 'Para' for repeating expressions (passthrough method) -- --- >>> pz @(ParaN 4 (Succ Id)) [1..4] --- PresentT [2,3,4,5] +-- >>> pz @(ParaN 4 Succ) [1..4] +-- Val [2,3,4,5] -- --- >>> pz @(ParaN 4 (Succ Id)) "azwxm" --- FailT "Para:invalid length(5) expected 4" +-- >>> pz @(ParaN 4 Succ) "azwxm" +-- Fail "Para:invalid length(5) expected 4" -- --- >>> pz @(ParaN 4 (Succ Id)) "azwx" --- PresentT "b{xy" +-- >>> pz @(ParaN 4 Succ) "azwx" +-- Val "b{xy" -- -- >>> pl @(ParaN 5 (Guard "0-255" (Between 0 255 Id))) [1,2,3,4,12] -- Present [1,2,3,4,12] (Para(0) [1,2,3,4,12] | [1,2,3,4,12]) --- PresentT [1,2,3,4,12] +-- Val [1,2,3,4,12] -- -- >>> pl @(ParaN 5 (Guard "0-255" (Between 0 255 Id))) [1,2,3,400,12] --- Error 0-255 (Para(0) rhs failed 1) --- FailT "0-255" +-- Error 0-255 (Guard | 400 | Para(3 of 4)) +-- Fail "0-255" -- --- >>> pl @(ParaN 4 (PrintF "%03d" Id)) [141,21,3,0::Int] +-- >>> pz @(ParaN 5 (Guard (PrintF "bad value %d" Id) (Between 0 255 Id))) [1,2,3,400,12] +-- Fail "bad value 400" +-- +-- >>> pl @(ParaN 4 (PrintF "%03d" Id)) [141,21,3,0] -- Present ["141","021","003","000"] (Para(0) ["141","021","003","000"] | [141,21,3,0]) --- PresentT ["141","021","003","000"] +-- Val ["141","021","003","000"] -- - -data ParaN (n :: Nat) p +data ParaN (n :: Nat) p deriving Show -instance ( P (ParaImpl (LenT (RepeatT n p)) (RepeatT n p)) x +instance ( x ~ [a] + , 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))) -- | 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 Succ) 'c' +-- Val "dddd" -- -- >>> pz @(Repeat 4 "abc") () --- PresentT ["abc","abc","abc","abc"] +-- Val ["abc","abc","abc","abc"] -- -- >>> pl @(Repeat 4 "xy") 3 -- Present ["xy","xy","xy","xy"] ('["xy","xy","xy","xy"] ('"xy") | 3) --- PresentT ["xy","xy","xy","xy"] +-- Val ["xy","xy","xy","xy"] -- -data Repeat (n :: Nat) p +data Repeat (n :: Nat) p deriving Show 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)) @@ -560,33 +584,32 @@ -- | 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 Succ) 'c' +-- Val 'g' -- -- >>> pz @(DoN 4 (Id <> " | ")) "abc" --- PresentT "abc | | | | " +-- Val "abc | | | | " -- -- >>> pz @(DoN 4 (Id <> "|" <> Id)) "abc" --- PresentT "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" +-- Val "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" -- -- >>> pl @(DoN 4 (Id + 4)) 1 -- Present 17 ((>>) 17 | {13 + 4 = 17}) --- PresentT 17 +-- Val 17 -- -- >>> pl @(DoN 4 (Id + 7)) 3 -- Present 31 ((>>) 31 | {24 + 7 = 31}) --- PresentT 31 +-- Val 31 -- -- >>> pl @(DoN 4 9) () -- Present 9 ((>>) 9 | {'9}) --- PresentT 9 +-- Val 9 -- -- >>> pl @(DoN 4 "xy") 3 -- Present "xy" ((>>) "xy" | {'"xy"}) --- PresentT "xy" +-- Val "xy" -- - -data DoN (n :: Nat) p +data DoN (n :: Nat) p deriving Show 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
src/Predicate/Data/Json.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,13 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted json encoding and decoding functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted json encoding and decoding functions module Predicate.Data.Json ( - ParseJson' , ParseJson , EncodeJson @@ -33,9 +24,10 @@ , ParseJsonFile ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Proxy -import Data.Typeable +import Data.Proxy (Proxy(Proxy)) +import Data.Typeable (Typeable) import Data.Kind (Type) import qualified Data.Aeson as A import qualified Data.Aeson.Encode.Pretty as AP @@ -47,76 +39,75 @@ -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import Predicate.Prelude --- | parse json data using the type \'t\' -data ParseJson' t p +-- | parse json data using the type @t@ +data ParseJson' t p deriving Show -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 +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 + pure $ case getValueLR NoInline 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 + Right b -> mkNode opts (Val b) (msg0 <> " " ++ showL opts { oWidth = oWidth opts `div` 2 } b) hhs + Left e -> mkNode opts (Fail (msg1 <> " " <> e) ) (litBL opts s) hhs --- | parse json data using the type \'t\' +-- | parse json data using the type @t@ -- -- >>> pl @(ParseJson (Int,String) Id) "[10,\"abc\"]" -- Present (10,"abc") (ParseJson (Int,[Char]) (10,"abc")) --- PresentT (10,"abc") +-- Val (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 $" +-- Error ParseJson (Int,[Char])([10,"abc",99]) Error in $: cannot unpack array of length 3 into a tuple of length 2 ([10,"abc",99]) +-- Fail "ParseJson (Int,[Char])([10,\"abc\",99]) Error in $: cannot unpack array of length 3 into a tuple of length 2" -- --- >>> pl @(ParseJson (Int,Bool) (FromString _ Id)) ("[1,true]" :: String) +-- >>> pl @(ParseJson (Int,Bool) (FromString _ Id)) "[1,true]" -- Present (1,True) (ParseJson (Int,Bool) (1,True)) --- PresentT (1,True) +-- Val (1,True) -- -- >>> pl @(ParseJson (Int,Bool) Id) (A.encode (1,True)) -- Present (1,True) (ParseJson (Int,Bool) (1,True)) --- PresentT (1,True) +-- Val (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 $" +-- Error ParseJson ()([1,true]) Error in $: parsing () failed, expected an empty array ([1,true]) +-- Fail "ParseJson ()([1,true]) Error in $: parsing () failed, expected an empty array" -- -data ParseJson (t :: Type) p +data ParseJson (t :: Type) p deriving Show 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 json file \'p\' using the type \'t\' -data ParseJsonFile' t p +-- | parse json file @p@ using the type @t@ +data ParseJsonFile' t p deriving Show -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 +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 + case getValueLR NoInline opts msg0 pp [] of Left e -> pure e Right p -> do let hhs = [hh pp] @@ -126,19 +117,19 @@ 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 + Nothing -> mkNode opts (Fail msg1) "" hhs + Just Nothing -> mkNode opts (Fail (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 + Right b -> mkNode opts (Val b) (msg1 <> " " ++ showL opts b) hhs + Left e -> mkNode opts (Fail (msg1 <> " " <> e)) (litBS opts s) hhs --- | parse a json file \'p\' using the type \'t\' +-- | parse a json file @p@ using the type @t@ -- -- >>> pz @(ParseJsonFile [A.Value] "test1.json" >> Id !! 2) () --- PresentT (Object (fromList [("lastName",String "Doe"),("age",Number 45.0),("firstName",String "John"),("likesPizza",Bool False)])) +-- Val (Object (fromList [("lastName",String "Doe"),("age",Number 45.0),("firstName",String "John"),("likesPizza",Bool False)])) -- -data ParseJsonFile (t :: Type) p +data ParseJsonFile (t :: Type) p deriving Show type ParseJsonFileT (t :: Type) p = ParseJsonFile' (Hole t) p instance P (ParseJsonFileT t p) x => P (ParseJsonFile t p) x where @@ -149,13 +140,13 @@ -- -- >>> pl @(EncodeJson 'False Id) (10,"def") -- Present "[10,\"def\"]" (EncodeJson [10,"def"]) --- PresentT "[10,\"def\"]" +-- Val "[10,\"def\"]" -- -- >>> pl @(EncodeJson 'False Id >> ParseJson (Int,Bool) Id) (1,True) -- Present (1,True) ((>>) (1,True) | {ParseJson (Int,Bool) (1,True)}) --- PresentT (1,True) +-- Val (1,True) -- -data EncodeJson (pretty :: Bool) p +data EncodeJson (pretty :: Bool) p deriving Show instance ( GetBool pretty , A.ToJSON (PP p x) @@ -166,14 +157,14 @@ let msg0 = "EncodeJson" pretty = getBool @pretty pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e Right p -> let d = (if pretty then AP.encodePretty else A.encode) p - in mkNode opts (PresentT d) (msg0 <> " " <> litL opts (litBL opts d)) [hh pp] + in mkNode opts (Val d) (msg0 <> " " <> litL opts (litBL opts d)) [hh pp] -- | encode a json file with pretty option -data EncodeJsonFile (pretty :: Bool) p q +data EncodeJsonFile (pretty :: Bool) p q deriving Show instance ( GetBool pretty , PP p x ~ String @@ -185,7 +176,7 @@ eval _ opts x = do let msg0 = "EncodeJsonFile" pretty = getBool @pretty - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x [] + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] case lr of Left e -> pure e Right (p,q,pp,qq) -> do @@ -193,6 +184,6 @@ 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 + Nothing -> mkNode opts (Fail (msg0 <> " must run in IO")) "" hhs + Just () -> mkNode opts (Val ()) (msg0 <> " " <> litL opts (litBL opts d)) hhs
+ src/Predicate/Data/Lifted.hs view
@@ -0,0 +1,1326 @@+{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +-- | lifted promoted functions +module Predicate.Data.Lifted ( + -- ** functor + FMap + , type (<$>) + , type (<&>) + + -- ** applicative + , type (<*>) + , LiftA2 + , FPair + , type (<:>) + , type (<$) + , type (<*) + , type (*>) + + -- ** monad + , FFish + , type (>>=) + , Sequence + , Traverse + , Join + + -- ** alternative + , type (<|>) + + -- ** bifunctor + , type BiMap + + -- ** comonad + , Extract + , Duplicate + + -- ** function application + , type ($$) + , type ($&) + , Skip + , type (|>) + , type (>|) + , type (>|>) + , Flip + , Dot + , RDot + , K + , Lift + + -- ** error handling + , Catch + , Catch' + + -- ** miscellaneous + , ELR(..) + ) where +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import qualified GHC.TypeLits as GL +import Control.Applicative +import Control.Monad (join) +import Data.Kind (Type) +import Control.Comonad (Comonad(duplicate, extract)) +import Control.Lens +import Data.Tree (Tree) +import Data.Proxy (Proxy(..)) +import Data.Bitraversable +import Data.Bifoldable +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> import qualified Data.Text as T +-- >>> import Predicate.Prelude +-- >>> import qualified Data.Semigroup as SG +-- >>> import Data.Functor.Identity +-- >>> import Data.These +-- >>> :m + Data.Typeable +-- >>> :m + Data.Ratio +-- >>> :m + Control.Lens +-- >>> :m + Control.Lens.Action +-- >>> :m + System.Random + +-- | similar to 'Control.Applicative.<$' +-- +-- >>> pz @(Fst <$ Snd) ("abc",Just 20) +-- Val (Just "abc") +-- +-- >>> pl @(Fst <$ Snd) (4,These "xxx" 'a') +-- Present These "xxx" 4 ((<$) 4) +-- Val (These "xxx" 4) +-- +-- >>> pl @(Fst <$ Snd) (4,This 'a') +-- Present This 'a' ((<$) 4) +-- Val (This 'a') +-- +-- >>> pl @(Fst <$ Snd) (4,Just 'a') +-- Present Just 4 ((<$) 4) +-- Val (Just 4) +-- +-- >>> pl @(Fst <$ Snd) (4,Nothing @Int) +-- Present Nothing ((<$) 4) +-- Val Nothing +-- +-- >>> pl @('True <$ Id) [1..4] +-- Present [True,True,True,True] ((<$) True) +-- Val [True,True,True,True] +-- +-- >>> import Data.Functor.Compose +-- >>> pl @(C "ab" <$ Id) (Compose $ Just [1..4]) +-- Present Compose (Just "aaaa") ((<$) 'a') +-- Val (Compose (Just "aaaa")) +-- +-- >>> pl @(Snd <$ Fst) (Just 10,'x') +-- Present Just 'x' ((<$) 'x') +-- Val (Just 'x') +-- +data p <$ q deriving Show +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 NoInline 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 (Val d) (msg0 <> " " <> showL opts p) [hh pp, hh qq] + +-- | similar to Applicative 'Control.Applicative.<*' +-- +-- >>> pl @(Fst <* Snd) (Just 4,Just 'a') +-- Present Just 4 ((<*) Just 4 | p=Just 4 | q=Just 'a') +-- Val (Just 4) +-- +-- >>> pz @(Fst <* Snd) (Just "abc",Just 20) +-- Val (Just "abc") +-- +-- >>> pz @('["x","y"] <* '[1,2,3]) () +-- Val ["x","x","x","y","y","y"] +-- +data p <* q deriving Show +infixl 4 <* + +instance ( P p x + , P q x + , Show (t b) + , Show (t c) + , Applicative t + , PP p x ~ t b + , 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 NoInline 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 (Val d) (show3' opts msg0 p "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to Applicative 'Control.Applicative.*>' +-- +-- >>> pl @(Fst *> Snd) (Just 4,Just 'a') +-- Present Just 'a' ((*>) Just 4 | p=Just 4 | q=Just 'a') +-- Val (Just 'a') +-- +-- >>> pz @('["x","y"] *> '[1,2,3]) () +-- Val [1,2,3,1,2,3] +-- +data p *> q deriving Show +infixl 4 *> + +instance ( P p x + , P q x + , Show (t b) + , Show (t c) + , Applicative t + , PP p x ~ t b + , PP q x ~ t c + ) => P (p *> q) x where + type PP (p *> q) x = PP q x + eval _ opts x = do + let msg0 = "(*>)" + lr <- runPQ NoInline 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 (Val d) (show3' opts msg0 p "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to 'Control.Applicative.<|>' +-- +-- >>> pz @(Fst <|> Snd) (Nothing,Just 20) +-- Val (Just 20) +-- +-- >>> pz @(Fst <|> Snd) (Just 10,Just 20) +-- Val (Just 10) +-- +-- >>> pz @(Fst <|> Snd) (Nothing,Nothing) +-- Val Nothing +-- +-- >>> pl @(Fst <|> Snd) (Just "cdef",Just "ab") +-- Present Just "cdef" ((<|>) Just "cdef" | p=Just "cdef" | q=Just "ab") +-- Val (Just "cdef") +-- +-- >>> pl @(Fst <|> Snd) ("cdef","ab"::String) +-- Present "cdefab" ((<|>) "cdefab" | p="cdef" | q="ab") +-- Val "cdefab" +-- +data p <|> q deriving Show +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 NoInline 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 (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + + +-- | similar to 'Control.Comonad.extract' +-- +-- >>> pz @Extract (Nothing,Just 20) +-- Val (Just 20) +-- +-- >>> pz @Extract (Identity 20) +-- Val 20 +-- +-- >>> pl @Extract (10,"hello") +-- Present "hello" (Extract "hello" | (10,"hello")) +-- Val "hello" +-- +data Extract deriving Show +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 (Val d) (show3 opts msg0 d ta) [] + +-- | similar to 'Control.Comonad.duplicate' +-- +-- >>> pz @Duplicate (20,"abc") +-- Val (20,(20,"abc")) +-- +data Duplicate deriving Show + +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 (Val d) (show3 opts msg0 d ta) [] + +-- | similar to 'Control.Monad.join' +-- +-- >>> pz @Join (Just (Just 20)) +-- Val (Just 20) +-- +-- >>> pz @Join ["ab","cd","","ef"] +-- Val "abcdef" +-- +data Join deriving Show + +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 (Val d) (show3 opts msg0 d tta) [] + +-- | function application for pure functions appearing on the rhs: similar to 'GHC.Base.$' +-- +-- >>> :m + Text.Show.Functions +-- >>> pz @(Fst $$ Snd) ((*16),4) +-- Val 64 +-- +-- >>> pz @(Id $$ "def") ("abc"<>) +-- Val "abcdef" +-- +-- >>> pz @(Id $$ 12) (*13) +-- Val 156 +-- +-- >>> pz @(Id $$ 7 $$ 3) (*) +-- Val 21 +-- +-- >>> pz @(Id $$ 7 $$ 3) (,) +-- Val (7,3) +-- +-- >>> pz @(Id $$ "abc" $$ 'True) (,) +-- Val ("abc",True) +-- +-- >>> pz @(Id $$ "asdf" $$ 99 $$ C "A") (,,) +-- Val ("asdf",99,'A') +-- +-- >>> (fmap.fmap) ($ 9999) $ pz @Id (*33) +-- Val 329967 +-- +-- >>> (fmap.fmap) ($ 9999) $ pz @(Id $$ 1 $$ 'True) (,,) +-- Val (1,True,9999) +-- +-- >>> (fmap.fmap.fmap) ($ 8) $ pz @'("xxx",Id) (*33) +-- Val ("xxx",264) +-- +-- >>> pz @('True $& 4 $& Id $$ "aa") (,,) +-- Val (4,True,"aa") +-- +-- >>> pz @(Id $$ '(100,120)) (flip randomR (mkStdGen 7)) +-- Val (114,320112 40692) +-- +-- >>> pz @(Id $$ GenPure 12) (randomR ('a','f')) +-- Val ('f',520182 40692) +-- +-- >>> pz @(Id $$ GenIO) (randomR ('a','f')) ^!? acts . _Val . _1 . nearly 'a' (`elem` ['a'..'f']) +-- Just () +-- +-- >>> pz @((Id $$ "abc" $$ Wrap (SG.Sum _) 14) >> Id <> Id) These +-- Val (These "abcabc" (Sum {getSum = 28})) +-- +data p $$ q deriving Show +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 NoInline 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 (Val 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.&' +-- +-- >>> :m + Text.Show.Functions +-- >>> pz @(Snd $& Fst) ((*16),4) +-- Val 64 +-- +-- >>> pz @("def" $& Id) ("abc"<>) +-- Val "abcdef" +-- +-- >>> pz @('True $& 4 $& Id) (,) +-- Val (4,True) +-- +data q $& p deriving Show +-- 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 NoInline 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 (Val d) (msg0 <> " " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- | similar to 'sequenceA' +-- +-- >>> pz @Sequence [Just 10, Just 20, Just 30] +-- Val (Just [10,20,30]) +-- +-- >>> pz @Sequence [Just 10, Just 20, Just 30, Nothing, Just 40] +-- Val Nothing +-- +data Sequence deriving Show + +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 msg = "Sequence" + d = sequenceA tfa + in pure $ mkNode opts (Val d) (msg <> " " <> showL opts d <> showVerbose opts " | " tfa) [] + +-- | like 'traverse' +-- +-- >>> pl @(Traverse (If (Gt 3) (Pure Maybe Id) (EmptyT Maybe))) [1..5] +-- Present Nothing ((>>) Nothing | {Sequence Nothing | [Nothing,Nothing,Nothing,Just 4,Just 5]}) +-- Val Nothing +-- +-- >>> pl @(Traverse (MaybeBool (Le 3) Id)) [1..5] +-- Present Nothing ((>>) Nothing | {Sequence Nothing | [Just 1,Just 2,Just 3,Nothing,Nothing]}) +-- Val Nothing +-- +-- >>> pl @(Traverse (If (Gt 0) (Pure Maybe Id) (EmptyT Maybe))) [1..5] +-- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) +-- Val (Just [1,2,3,4,5]) +-- +-- >>> pl @(Traverse (If (Gt 0) (Pure Maybe Id) (MkNothing _))) [1..5] +-- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) +-- Val (Just [1,2,3,4,5]) +-- +-- >>> pl @(Traverse (MaybeBool (Id >= 0) Id)) [1..5] +-- Present Just [1,2,3,4,5] ((>>) Just [1,2,3,4,5] | {Sequence Just [1,2,3,4,5] | [Just 1,Just 2,Just 3,Just 4,Just 5]}) +-- Val (Just [1,2,3,4,5]) +-- +-- >>> pl @(Traverse (MaybeBool (Id <= 3) Id)) [1..5] +-- Present Nothing ((>>) Nothing | {Sequence Nothing | [Just 1,Just 2,Just 3,Nothing,Nothing]}) +-- Val Nothing +-- +data Traverse p deriving Show +type TraverseT p = FMap p >> Sequence + +instance P (TraverseT p) x => P (Traverse p) x where + type PP (Traverse p) x = PP (TraverseT p) x + eval _ = eval (Proxy @(TraverseT p)) + +-- | just run the effect ignoring the result passing the original value through +-- +-- for example for use with Stdout so it doesnt interfere with the @a@ on the rhs unless it fails +data Skip p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> mkNode opts (Val a) (msg0 <> " " <> showL opts p) [hh pp] + +-- | run @p@ for the effect and then run @q@ using that original value +data p |> q deriving Show +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)) + +-- | run run @p@ and then @q@ for the effect but using the result from @p@ +data p >| q deriving Show +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)) + +-- | run both @p@ and @q@ for their effects but ignoring the results +data p >|> q deriving Show +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)) + +-- | run an expression @p@ and on failure run @q@ +-- +-- >>> pz @(Catch Succ (Fst >> Second (ShowP Id) >> PrintT "%s %s" Id >> 'LT)) GT +-- Val LT +-- +-- >>> pz @(Len > 1 && Catch (Id !! 3 == 66) 'False) [1,2] +-- Val False +-- +-- >>> pl @(Catch (Resplit "\\d+(") (Snd >> MEmptyP)) "123" +-- Present [] (Catch caught exception[Regex failed to compile]) +-- Val [] +-- +-- >>> pl @(Catch OneP 99) [10,11] +-- Present 99 (Catch caught exception[OneP:expected one element(2)]) +-- Val 99 +-- +-- >>> pl @(Catch OneP 99) [10] +-- Present 10 (Catch did not fire) +-- Val 10 +-- +-- >>> pl @(Catch OneP 'True) [False] +-- Present False (Catch did not fire) +-- Val False +-- +-- >>> pl @(Catch OneP 'False) [True,True,False] +-- False (Catch caught exception[OneP:expected one element(3)]) +-- Val False +-- +-- >>> pl @(Catch OneP 'True) [] +-- True (Catch caught exception[OneP:expected one element(empty)]) +-- Val True +-- +data Catch p q deriving Show + +-- | run an expression @p@ and on failure print a custom error @s@ using the error string and the input value +-- +-- >>> pz @(Catch' Succ (Second (ShowP Id) >> PrintT "%s %s" Id)) GT +-- Fail "Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT" +-- +-- >>> pz @(Catch' Succ (Second (ShowP Id) >> PrintT "%s %s" Id)) LT +-- Val EQ +-- +-- >>> pl @(Catch' (FailT Int "someval") (PrintT "msg=%s caught(%03d)" Id)) 44 +-- Error msg=someval caught(044) (Catch default condition failed) +-- Fail "msg=someval caught(044)" +-- +-- >>> pl @(Catch' OneP (Second (ShowP Id) >> PrintT "msg=%s caught(%s)" Id)) [10,12,13] +-- Error msg=OneP:expected one element(3) caught([10,12,13]) (Catch default condition failed) +-- Fail "msg=OneP:expected one element(3) caught([10,12,13])" +-- +-- >>> pl @(Catch' OneP (PrintT "msg=%s caught(%s)" (Second (ShowP Id)))) [10] +-- Present 10 (Catch did not fire) +-- Val 10 +-- +-- >>> pl @(Catch' OneP (PrintT "msg=%s err s=%s" (Second (ShowP Id)))) [10,11] +-- Error msg=OneP:expected one element(2) err s=[10,11] (Catch default condition failed) +-- Fail "msg=OneP:expected one element(2) err s=[10,11]" +-- +data Catch' p s deriving Show +type CatchT' p s = Catch p (FailCatchT s) -- eg set eg s=PrintF "%d" Id or PrintF "%s" (ShowP Id) +type FailCatchT s = Fail (Snd >> UnproxyT) (Fst >> 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 NoInline opts msg0 pp [] of + Left p -> do + let emsg = p ^. ttVal . singular _Fail -- extract the Fail string and push it back into the fail case + qq <- eval (Proxy @q) opts ((emsg, x), Proxy @(PP p x)) + pure $ case getValueLR NoInline opts (msg0 <> " default condition failed") qq [hh pp] of + Left e1 -> e1 + Right _ -> mkNodeCopy opts qq (msg0 <> " caught exception[" <> emsg <> "]") [hh pp, hh qq] + Right _ -> pure $ mkNodeCopy opts pp (msg0 <> " did not fire") [hh pp] + +-- | compose simple functions +-- +-- >>> pl @(Dot '[L3,L2,L1] Id) ((1,(2,9,10)),(3,4)) +-- Present 10 (Thd 10 | (2,9,10)) +-- Val 10 +-- +data Dot (ps :: [Type -> Type]) (q :: Type) deriving Show +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 version of 'Dot' +-- +-- >>> pl @(RDot '[L1,L2,L3] Id) ((1,(2,9,10)),(3,4)) +-- Present 10 (Thd 10 | (2,9,10)) +-- Val 10 +-- +-- >>> pl @(RDot '[L1,L2] Id) (('a',2),(True,"zy")) +-- Present 2 (Snd 2 | ('a',2)) +-- Val 2 +-- +data RDot (ps :: [Type -> Type]) (q :: Type) deriving Show +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) + +-- | similar to 'const':types dont need to match on rhs! +-- +-- >>> pl @(RDot '[L1,L2,L3,K "xxx"] Id) 12345 +-- Present "xxx" (K '"xxx") +-- Val "xxx" +-- +-- >>> pl @(RDot '[L1,L2,L3,K '("abc",Id)] Id) () +-- Present ("abc",()) (K '("abc",())) +-- Val ("abc",()) +-- +-- >>> pl @(Dot '[K "skip",L6,Lift Dup,Lift Succ] Id) () +-- Present "skip" (K '"skip") +-- Val "skip" +-- +-- >>> pl @(L3 $ L2 $ L1 $ K Id "dud") ((1,("X",9,'a')),(3,4)) +-- Present 'a' (Thd 'a' | ("X",9,'a')) +-- Val 'a' +-- +-- >>> pl @((L3 $ L2 $ L1 $ K Id "dud") >> Pred) ((1,("X",9,'a')),(3,4)) +-- Present '`' ((>>) '`' | {Pred '`' | 'a'}) +-- Val '`' +-- +-- >>> pl @(K "ss" $ L3 $ L3 $ Fst) () +-- Present "ss" (K '"ss") +-- Val "ss" +-- +data K (p :: k) (q :: k1) deriving Show +instance P p a => P (K p q) a where + type PP (K p q) a = PP p a + eval _ = eval (Proxy @(MsgI "K " p)) + +-- | Lift a no arg Adt to a function of one argument (for use with 'Dot' and 'RDot') +-- +-- >>> pl @(Lift Len Snd) (True,"abcdef") +-- Present 6 ((>>) 6 | {Len 6 | "abcdef"}) +-- Val 6 +-- +data Lift p q deriving Show +type LiftT p q = q >> p + +instance P (LiftT p q) x => P (Lift p q) x where + type PP (Lift p q) x = PP (LiftT p q) x + eval _ = eval (Proxy @(LiftT p q)) + +-- | similar to 'Data.Functor.<$>' +-- +-- >>> pl @(FMap Succ) (Right 'a') +-- Present Right 'b' (FMap Succ 'b' | 'a') +-- Val (Right 'b') +-- +-- >>> pl @(FMap Succ) (Left "Sf") +-- Present Left "Sf" (FMap <skipped>) +-- Val (Left "Sf") +-- +-- >>> pz @(FMap (MkDay Id) >> Join) (Just (2020,01,01)) +-- Val (Just 2020-01-01) +-- +-- >>> pz @(FMap (MkDay Id) >> Join) (Just (2020,01,32)) +-- Val Nothing +-- +-- >>> pz @(FMap Succ) (Just LT) +-- Val (Just EQ) +-- +-- >>> pz @(FMap Pred) (Just LT) +-- Fail "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" +-- +-- >>> pz @(FMap (ShowP Id)) (Just 10) +-- Val (Just "10") +-- +-- >>> pan @(FMap $ FMap $ FMap Succ) [Just "abcdefG",Nothing,Just "X"] +-- P FMap FMap FMap Succ 'b' | Succ 'c' | Succ 'd' | Succ 'e' | Succ 'f' | Succ 'g' | Succ 'H' | FMap <skipped> | FMap FMap Succ 'Y' +-- | +-- +- P FMap FMap Succ 'b' | Succ 'c' | Succ 'd' | Succ 'e' | Succ 'f' | Succ 'g' | Succ 'H' +-- | | +-- | `- P FMap Succ 'b' | Succ 'c' | Succ 'd' | Succ 'e' | Succ 'f' | Succ 'g' | Succ 'H' +-- | | +-- | +- P Succ 'b' +-- | | +-- | +- P Succ 'c' +-- | | +-- | +- P Succ 'd' +-- | | +-- | +- P Succ 'e' +-- | | +-- | +- P Succ 'f' +-- | | +-- | +- P Succ 'g' +-- | | +-- | `- P Succ 'H' +-- | +-- +- P FMap <skipped> +-- | +-- `- P FMap FMap Succ 'Y' +-- | +-- `- P FMap Succ 'Y' +-- | +-- `- P Succ 'Y' +-- Val [Just "bcdefgH",Nothing,Just "Y"] +-- +-- >>> pan @(FMap (FromEnum > 97)) "abc" +-- P FMap 97 > 97 | 98 > 97 | 99 > 97 +-- | +-- +- False 97 > 97 +-- | | +-- | +- P FromEnum 97 +-- | | +-- | `- P '97 +-- | +-- +- True 98 > 97 +-- | | +-- | +- P FromEnum 98 +-- | | +-- | `- P '97 +-- | +-- `- True 99 > 97 +-- | +-- +- P FromEnum 99 +-- | +-- `- P '97 +-- Val [False,True,True] +-- +-- >>> pan @(FMap (FromEnum > 97 >> Id)) "abc" +-- P FMap (>>) False | (>>) True | (>>) True +-- | +-- +- P (>>) False +-- | | +-- | +- False 97 > 97 +-- | | | +-- | | +- P FromEnum 97 +-- | | | +-- | | `- P '97 +-- | | +-- | `- P Id False +-- | +-- +- P (>>) True +-- | | +-- | +- True 98 > 97 +-- | | | +-- | | +- P FromEnum 98 +-- | | | +-- | | `- P '97 +-- | | +-- | `- P Id True +-- | +-- `- P (>>) True +-- | +-- +- True 99 > 97 +-- | | +-- | +- P FromEnum 99 +-- | | +-- | `- P '97 +-- | +-- `- P Id True +-- Val [False,True,True] +-- +-- >>> pan @(FMap IdBool) (Just True) +-- P FMap IdBool +-- | +-- `- True IdBool +-- Val (Just True) +-- +-- >>> pz @(FMap (Pure (Either String) Id)) [1,2,4] +-- Val [Right 1,Right 2,Right 4] +-- +-- >>> pl @(FMap (Pure [] Id)) (Just 10) +-- Present Just [10] (FMap Pure [10] | 10) +-- Val (Just [10]) +-- +-- >>> pl @(FMap (Pure SG.Sum Id)) (Just 20) +-- Present Just (Sum {getSum = 20}) (FMap Pure Sum {getSum = 20} | 20) +-- Val (Just (Sum {getSum = 20})) +-- +-- >>> pz @(FMap (Coerce (SG.Sum Integer))) [Identity (-13), Identity 4, Identity 99] +-- Val [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] +-- +-- >>> pz @(FMap (Coerce (SG.Sum Integer))) (Just (Identity (-13))) +-- Val (Just (Sum {getSum = -13})) +-- +-- >>> pz @(FMap (Coerce (SG.Sum Int))) (Nothing @(Identity Int)) +-- Val Nothing +-- +-- >>> pl @(FMap (Coerce (SG.Sum Int))) (Just (10 :: Int)) +-- Present Just (Sum {getSum = 10}) (FMap Coerce Sum {getSum = 10} | 10) +-- Val (Just (Sum {getSum = 10})) +-- +-- >>> pz @(Proxy Char >> FMap Succ) () ^!? acts . _Val . to typeRep +-- Just Char +-- +data FMap p deriving Show + +instance ( Traversable n + , P p a + ) => P (FMap p) (n a) where + type PP (FMap p) (n a) = n (PP p a) + eval _ opts na = do + let msg0 = "FMap" + _fmapImpl opts (Proxy @p) msg0 [] na + +-- | similar to 'Data.Functor.<$>' +-- +-- >>> pz @(Len <$> Snd) (1,Just "abcdef") +-- Val (Just 6) +-- +-- >>> pz @(Len <$> (Id <> Id <> "extra" <$> Snd)) (1,Just "abcdef") +-- Val (Just 17) +-- +-- >>> pz @(Len <$> (Id <> Id <> "extra" <$> Snd)) (1,Right "abcdef") +-- Val (Right 17) +-- +-- >>> pz @(FMap $ FMap (Succ <$> Id)) (True,Just (These 12 'c')) +-- Val (True,Just (These 12 'd')) +-- +-- >>> pz @(FMap (Second (Succ <$> Id))) [(True, (These 12 'c'))] +-- Val [(True,These 12 'd')] +-- +data p <$> q deriving Show +infixl 4 <$> + +instance ( Traversable n + , P q a + , P p b + , PP q a ~ n b + , PP p b ~ c + ) => P (p <$> q) a where + type PP (p <$> q) a = (ExtractTFromTA (PP q a)) (PP p (ExtractAFromTA (PP q a))) + eval _ opts x = do + let msg0 = "(<$>)" + qq <- eval (Proxy @q) opts x + case getValueLR NoInline opts msg0 qq [] of + Left e -> pure e + Right q -> _fmapImpl opts (Proxy @p) msg0 [hh qq] q + +_fmapImpl :: forall m n p a + . ( P p a + , Traversable n + , MonadEval m + ) => POpts + -> Proxy p + -> String + -> [Tree PE] + -> n a + -> m (TT (n (PP p a))) +_fmapImpl opts proxyp msg0 hhs na = do + nttb <- traverse (fmap (\tt -> tt & ttString %~ litL opts + & ttForest .~ [hh tt]) . eval proxyp opts) na + let ttnb = sequenceA nttb + pure $ case getValueLR Inline opts "" ttnb hhs of + Left e -> e + Right ret -> + let ind = if null ret then " <skipped>" else "" + in ttnb & ttVal .~ Val ret + & ttForest %~ (hhs <>) + & ttString %~ (msg0 <>) . (ind <>) . nullIf " " + +-- | similar to 'Data.Functor.<&>' +-- +-- >>> pz @('[1,2,3] <&> Succ) () +-- Val [2,3,4] +-- +data p <&> q deriving Show +infixl 1 <&> +type FMapFlipT p q = q <$> p + +instance P (FMapFlipT p q) x => P (p <&> q) x where + type PP (p <&> q) x = PP (FMapFlipT p q) x + eval _ = eval (Proxy @(FMapFlipT p q)) + +-- | runs 'Control.Applicative.liftA2' (,) against two values: LiftA2 is traversable and provides better debugging +-- +-- >>> pz @(FPair Fst Snd) (Just 10, Just True) +-- Val (Just (10,True)) +-- +-- >>> pz @(FPair Fst Snd >> FMap (ShowP Fst <> "---" <> ShowP Snd)) (Just 10, Just True) +-- Val (Just "10---True") +-- +-- >>> pz @(FPair Fst Snd >> FMap (Fst + Snd)) (Just 10, Just 13) +-- Val (Just 23) +-- +-- >>> pz @(FPair (EnumFromTo Fst Snd) ('LT ... 'GT) ) (10,11) +-- Val [(10,LT),(10,EQ),(10,GT),(11,LT),(11,EQ),(11,GT)] +-- +data FPair p q deriving Show + +instance ( Applicative n + , PP p a ~ n x + , PP q a ~ n y + , JoinT (PP p a) (PP q a) ~ n (x,y) + , P p a + , P q a + ) + => P (FPair p q) a where + type PP (FPair p q) a = JoinT (PP p a) (PP q a) + eval _ opts a = do + let msg0 = "FPair" + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts a [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = liftA2 (,) p q + in mkNode opts (Val d) msg0 [hh pp, hh qq] + +-- | see 'FPair' +-- +-- >>> pz @(Fst <:> Snd) (Just 10, Just True) +-- Val (Just (10,True)) +-- +-- >>> pz @(Fst <:> Snd) ("abc",[10,12,14]) +-- Val [('a',10),('a',12),('a',14),('b',10),('b',12),('b',14),('c',10),('c',12),('c',14)] +-- +-- >>> pz @('[1,2] <:> "abcdef") () +-- Val [(1,'a'),(1,'b'),(1,'c'),(1,'d'),(1,'e'),(1,'f'),(2,'a'),(2,'b'),(2,'c'),(2,'d'),(2,'e'),(2,'f')] +-- +-- >>> pz @(EnumFromTo Fst Snd <:> ('LT ... 'GT)) (10,11) +-- Val [(10,LT),(10,EQ),(10,GT),(11,LT),(11,EQ),(11,GT)] +-- +-- >>> pz @(MkJust Succ <:> MkJust 4) () -- uses Succ on (): instead use LiftA2 with Pop0 or <*> (see next 2 tests) +-- Fail "Succ IO e=Prelude.Enum.().succ: bad argument" +-- +-- >>> pz @(LiftA2 (Pop0 Fst Snd) (MkJust (Proxy Succ)) (MkJust 4)) () +-- Val (Just 5) +-- +-- >>> pz @(MkJust Succ <*> MkJust 4) () +-- Val (Just 5) +-- +data p <:> q deriving Show +type FPairT p q = FPair p q +infixl 6 <:> + +instance P (FPairT p q) x => P (p <:> q) x where + type PP (p <:> q) x = PP (FPairT p q) x + eval _ = eval (Proxy @(FPairT p q)) + +-- | similar to monad operator 'Control.Monad.>=>' +-- +-- >>> pz @(FFish Uncons (Snd >> Uncons) "abcdef") () +-- Val (Just ('b',"cdef")) +-- +-- >>> :m + Data.Time +-- >>> pz @(FFish (ReadMaybe Day Id >> FMap Fst) (MkJust Succ) "2020-02-02") () +-- Val (Just 2020-02-03) +-- +-- >>> pz @(FFish Uncons (Lookup Fst "abcdef") [3,14,12]) () +-- Val (Just 'd') +-- +data FFish amb bmc a deriving Show +type FFishT amb bmc a = a >> amb >> FMap bmc >> Join + +instance P (FFishT p q r) x => P (FFish p q r) x where + type PP (FFish p q r) x = PP (FFishT p q r) x + eval _ = eval (Proxy @(FFishT p q r)) + +-- | similar to monad bind operator 'Control.Monad.>>=' +-- +-- >>> pz @(Id >>= HeadMay) (Just "abcdef") +-- Val (Just 'a') +-- +-- >>> pz @(Uncons >>= (Snd >> HeadMay)) "abcdef" +-- Val (Just 'b') +-- +-- >>> pz @((1 ... 10) >>= EmptyBool [] Even '[Id,Id]) () +-- Val [[2,2],[4,4],[6,6],[8,8],[10,10]] +-- +-- >>> pz @( (1 ... 10) >>= If Even '[Id,Id] (EmptyT [])) () +-- Val [2,2,4,4,6,6,8,8,10,10] +-- +-- >>> pz @(Lookup 0 Id >>= Lookup 1 Id) [[1,2,3]] +-- Val (Just 2) +-- +-- >>> pz @(Lookup 4 Id >>= Lookup 1 Id) [[1,2,3]] +-- Val Nothing +-- +-- >>> pz @(Lookup 0 Id >>= Lookup 5 Id) [[1,2,3]] +-- Val Nothing +-- +-- >>> pz @(Lookup 0 Id >>= Lookup 1 Id >>= MaybeBool Even '(Id,"is even!")) [[1,2,3]] +-- Val (Just (2,"is even!")) +-- +-- >>> pz @(Lookup 0 Id >>= Lookup 1 Id >>= MaybeBool Even '(Id,"is even!")) [[1,5,3]] +-- Val Nothing +-- +-- >>> pz @((48...55) >>= '[ '[ToEnum Char << Id,ToEnum Char << (Id+3),ToEnum Char << (Id+6)] ]) () +-- Val ["036","147","258","369","47:","58;","69<","7:="] +-- +-- >>> pz @((48...55) >>= '[ Map (ToEnum Char) << '[ Id, Id+3 ,Id+6 ] ]) () +-- Val ["036","147","258","369","47:","58;","69<","7:="] +-- +data ma >>= amb deriving Show +type MBindT ma amb = ma >> FMap amb >> Join +infixl 1 >>= + +instance P (MBindT p q) x => P (p >>= q) x where + type PP (p >>= q) x = PP (MBindT p q) x + eval _ = eval (Proxy @(MBindT p q)) + +-- | applicative bind similar to 'Control.Applicative.<*>' but functions have to be fully saturated: ie Len is ok but not Length +-- can use Proxy to delay evaluation until Pop0 +-- +-- >>> pz @(MkJust '("sdf",Id) <*> MkJust 4) () +-- Val (Just ("sdf",4)) +-- +-- >>> pz @(MkJust Succ <*> MkJust 4) () +-- Val (Just 5) +-- +-- >>> pz @('[Succ,Id,Pred] <*> "abcdef") undefined +-- Val "ba`cbadcbedcfedgfe" +-- +-- >>> pz @(MkJust "abc" <*> MkJust "def") () -- no function to apply so has to choose ie first one +-- Val (Just "abc") +-- +-- >>> pz @('[1,2] <*> "abcdef") () -- [1,2] <* "abcdef" -- ie skips rhs "abcdef" but still runs the effects +-- Val [1,2,1,2,1,2,1,2,1,2,1,2] +-- +-- >>> pz @(MkJust ((*) 3 Id) <*> MkJust 4) () +-- Val (Just 12) +-- +-- >>> pz @(MkJust ((*) 3 Len) <*> MkJust '["aa","bb","c","d","e"]) () +-- Val (Just 15) +-- +-- >>> pz @(ShowP Id <$> MkJust Succ <*> MkJust 4) () +-- Val (Just "5") +-- +-- >>> pz @('["x","y"] <*> '[1,2,3]) () +-- Val ["x","y","x","y","x","y"] +-- +data p <*> q deriving Show +--type AppT fab fa = fab >>= (Id <$> fa) -- need some way to flip function application +-- expecting (a -> b) -> f a -> f b +-- but we want a -> (f (a -> b)) -> f b +infixl 1 <*> + +type AppT fab fa = fa >>= (Id <$> fab) -- this works surprisingly well but args are flipped + +instance P (AppT p q) x => P (p <*> q) x where + type PP (p <*> q) x = PP (AppT p q) x + eval _ = eval (Proxy @(AppT p q)) + +-- | similar to 'flip':see also 'Predicate.Misc.FlipT' +-- +-- >>> pz @(Flip Map' Id Succ) [1..5] +-- Val [2,3,4,5,6] +-- +-- >>> pz @( Flip '(,) 'True 2) () +-- Val (2,True) +-- +-- >>> pz @( Flip ('(,,) 1) 2 Id) "ab" +-- Val (1,"ab",2) +-- +data Flip (p :: k1 -> k2 -> k3) (q :: k2) (r :: k1) deriving Show +-- needs explicit types + +instance P (p r q) x => P (Flip p q r) x where + type PP (Flip p q r) x = PP (p r q) x + eval _ = eval (Proxy @(p r q)) + + +-- | similar to 'Control.Applicative.liftA2' +-- +-- >>> pan @(LiftA2 Id (MkJust 12) (MkJust "abc")) () +-- P LiftA2 Id (12,"abc") +-- | +-- +- P MkJust Just 12 +-- | | +-- | `- P '12 +-- | +-- +- P MkJust Just "abc" +-- | | +-- | `- P '"abc" +-- | +-- `- P Id (12,"abc") +-- Val (Just (12,"abc")) +-- +-- >>> pan @(LiftA2 Swap (MkJust 12) (MkNothing _)) () +-- P LiftA2 <skipped> +-- | +-- +- P MkJust Just 12 +-- | | +-- | `- P '12 +-- | +-- `- P MkNothing +-- Val Nothing +-- +-- >>> pz @(LiftA2 (ShowP Fst <> "---" <> ShowP Snd) Fst Snd) (Just 10, Just True) +-- Val (Just "10---True") +-- +-- >>> pz @(LiftA2 (Fst + Snd) Fst Snd) (Just 10, Just 13) +-- Val (Just 23) +-- +-- >>> pz @(LiftA2 Fst '["x","y"] '[1,2,3]) () +-- Val ["x","x","x","y","y","y"] +-- +-- >>> pz @(LiftA2 Snd '["x","y"] '[1,2,3]) () +-- Val [1,2,3,1,2,3] +-- +-- >>> pz @(LiftA2 (Pop0 Fst Snd) '[ Proxy Len ] '[ "abc", "def", "aaaaaaaaaaa"]) () +-- Val [3,3,11] +-- +-- >>> pz @(LiftA2 (Fst * Snd) (FromList (ZipList _) << (10...15)) (FromList (ZipList _) << (1...10))) () +-- Val (ZipList {getZipList = [10,22,36,52,70,90]}) +-- +data LiftA2 p q r deriving Show +-- i provide the rhs as the environment to fa and fb? so fails Succ +-- use <*> as it works way better +-- use Proxy to delay setting the environment and then use Pop1 to run against a specific environment + +instance ( Traversable n + , Applicative n + , P p (a,b) + , P q x + , P r x + , PP p (a,b) ~ c + , PP q x ~ n a + , PP r x ~ n b + ) => P (LiftA2 p q r) x where + type PP (LiftA2 p q r) x = (ExtractTFromTA (PP q x)) (PP p (ExtractAFromTA (PP q x), ExtractAFromTA (PP r x))) + eval _ opts x = do + let msg0 = "LiftA2" + lr <- runPQ NoInline msg0 (Proxy @q) (Proxy @r) opts x [] + case lr of + Left e -> pure e + Right (q,r,qq,rr) -> do + let w = liftA2 (,) q r + _fmapImpl opts (Proxy @p) msg0 [hh qq, hh rr] w + +-- | similar to 'Data.Bifunctor.bimap' +-- +-- >>> pz @(BiMap Succ Head) (Left @_ @String 12) -- needs a type signature for Right +-- Val (Left 13) +-- +-- >>> pz @(BiMap Succ Head) (Right "xyz") +-- Val (Right 'x') +-- +-- >>> pz @(FMap (BiMap Succ Head)) [Right "xyz",Left 'a',Right "ab",Left 'x'] +-- Val [Right 'x',Left 'b',Right 'a',Left 'y'] +-- +-- >>> pz @(FMap (BiMap Succ Pred)) [These 12 'b', This 1, That 'd',That 'e'] +-- Val [These 13 'a',This 2,That 'c',That 'd'] +-- +-- >>> pz @(BiMap Succ Pred) (True,12,'b') +-- Val (True,13,'a') +-- +-- >>> pl @(FMap $ BiMap Succ (Not Id)) [This @Int @Bool 1, This 2,That True,These 4 False] +-- Present [This 2,This 3,That False,These 5 True] (FMap BiMap(L) Succ 2 | 1 | BiMap(L) Succ 3 | 2 | BiMap(R) Not (Id True) | BiMap(B) Succ 5 | 4 | Not (Id False)) +-- Val [This 2,This 3,That False,These 5 True] +-- +-- >>> pl @(BiMap Succ (Not Id)) (This @Int @Bool 1) +-- Present This 2 (BiMap(L) Succ 2 | 1) +-- Val (This 2) +-- +-- >>> pl @(BiMap Succ (Not Id)) (That @Int @Bool True) +-- Present That False (BiMap(R) Not (Id True)) +-- Val (That False) +-- +-- >>> pl @(BiMap Succ (Not Id)) (These @Int @Bool 1 True) +-- Present These 2 False (BiMap(B) Succ 2 | 1 | Not (Id True)) +-- Val (These 2 False) +-- +-- >>> pan @(FMap $ BiMap Succ (Not Id)) [This @Int @Bool 1, This 2,That True,These 4 False] +-- P FMap BiMap(L) Succ 2 | BiMap(L) Succ 3 | BiMap(R) Not | BiMap(B) Succ 5 | Not +-- | +-- +- P BiMap(L) Succ 2 +-- | | +-- | `- P Succ 2 +-- | +-- +- P BiMap(L) Succ 3 +-- | | +-- | `- P Succ 3 +-- | +-- +- P BiMap(R) Not +-- | | +-- | `- False Not +-- | | +-- | `- True Id True +-- | +-- `- P BiMap(B) Succ 5 | Not +-- | +-- +- P Succ 5 +-- | +-- `- True Not +-- | +-- `- False Id False +-- Val [This 2,This 3,That False,These 5 True] +-- +-- >>> pl @(BiMap Succ Head) (EEmpty @Int @String) +-- Present EEmpty (BiMap <skipped>) +-- Val EEmpty +-- +-- >>> pl @(BiMap Succ Head) (ELeft @Int @String 10) +-- Present ELeft 11 (BiMap(L) Succ 11 | 10) +-- Val (ELeft 11) +-- +-- >>> pl @(BiMap Succ Head) (ERight @Int @String "xyz") +-- Present ERight 'x' (BiMap(R) Head 'x' | "xyz") +-- Val (ERight 'x') +-- +-- >>> pl @(BiMap Succ Head) (EBoth @Int @String 10 "xyz") +-- Present EBoth 11 'x' (BiMap(B) Succ 11 | 10 | Head 'x' | "xyz") +-- Val (EBoth 11 'x') +-- +-- >>> pan @(FMap $ BiMap Succ Head) [EEmpty,ELeft 10,ERight "abc",EBoth 10 "xyz"] +-- P FMap BiMap <skipped> | BiMap(L) Succ 11 | BiMap(R) Head 'a' | BiMap(B) Succ 11 | Head 'x' +-- | +-- +- P BiMap <skipped> +-- | +-- +- P BiMap(L) Succ 11 +-- | | +-- | `- P Succ 11 +-- | +-- +- P BiMap(R) Head 'a' +-- | | +-- | `- P Head 'a' +-- | +-- `- P BiMap(B) Succ 11 | Head 'x' +-- | +-- +- P Succ 11 +-- | +-- `- P Head 'x' +-- Val [EEmpty,ELeft 11,ERight 'a',EBoth 11 'x'] +-- +data BiMap p q deriving Show + +instance ( Bitraversable n + , P p a + , P q b + ) => P (BiMap p q) (n a b) where + type PP (BiMap p q) (n a b) = n (PP p a) (PP q b) + eval _ opts nab = do + let msg0 = "BiMap" + _bimapImpl opts (Proxy @p) (Proxy @q) msg0 [] nab + +_bimapImpl :: forall m n p q a b + . ( P p a + , P q b + , Bitraversable n + , MonadEval m + ) => POpts + -> Proxy p + -> Proxy q + -> String + -> [Tree PE] + -> n a b + -> m (TT (n (PP p a) (PP q b))) +_bimapImpl opts proxyp proxyq msg0 hhs nab = do + nttb <- bitraverse + (fmap (\tt -> tt & ttString %~ litL opts + & ttForest .~ [hh tt]) . eval proxyp opts) + (fmap (\tt -> tt & ttString %~ litL opts + & ttForest .~ [hh tt]) . eval proxyq opts) + nab + let ttnb = bisequence nttb + pure $ case getValueLR Inline opts "" ttnb hhs of + Left e -> e + Right ret -> +-- let ind = case bifoldMap (\x -> ([x],[])) (\x -> ([],[x])) ret of + let ind = case bifoldMap ((,mempty) . pure) ((mempty,) . pure) ret of + ([], []) -> " <skipped>" + (_:_, []) -> "(L)" + ([], _:_) -> "(R)" + (_:_, _:_) -> "(B)" + in ttnb & ttVal .~ Val ret + & ttForest %~ (hhs <>) + & ttString %~ (msg0 <>) . (ind <>) . nullIf " " + + +data ELR a b = EEmpty | ELeft !a | ERight !b | EBoth !a !b deriving (Show,Eq,Ord,Foldable,Functor,Traversable) + +instance Bifunctor ELR where + bimap f g x = + case x of + EEmpty -> EEmpty + ELeft a -> ELeft (f a) + ERight b -> ERight (g b) + EBoth a b -> EBoth (f a) (g b) + +instance Bifoldable ELR where + bifoldMap f g x = + case x of + EEmpty -> mempty + ELeft a -> f a + ERight b -> g b + EBoth a b -> f a <> g b + +instance Bitraversable ELR where + bitraverse f g x = + case x of + EEmpty -> pure EEmpty + ELeft a -> ELeft <$> f a + ERight b -> ERight <$> g b + EBoth a b -> EBoth <$> f a <*> g b
src/Predicate/Data/List.hs view
@@ -1,1885 +1,2147 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoOverloadedLists #-} -{-# LANGUAGE NoStarIsType #-} -{- | - promoted list functions --} -module Predicate.Data.List ( - - -- ** constructors - type (:+) - , type (+:) - , type (++) - , Singleton - , EmptyT - , EmptyList - , EmptyList' - - -- ** destructors - , Uncons - , Unsnoc - , Head - , Tail - , Init - , Last - - -- ** sort - , SortBy - , SortOn - , SortOnDesc - - -- ** zip related - , Unzip - , Unzip3 - , ZipL - , ZipR - , Zip - , ZipWith - - -- ** higher order methods - , Partition - , PartitionBy - , GroupBy - , Filter - , Break - , Span - , Intercalate - - -- ** miscellaneous - , Len - , Length - , Elem - , Inits - , Tails - , Ones - , PadL - , PadR - , SplitAts - , SplitAt - , ChunksOf - , Rotate - , Take - , Drop - , Remove - , Keep - , Reverse - , ReverseL - - , Sum - , Product - , Min - , Max - - ) where -import Predicate.Core -import Predicate.Util -import Predicate.Data.Ordering (type (==), OrdA) -import Predicate.Data.Numeric (Mod) -import Predicate.Data.Monoid (type (<>)) -import Control.Lens hiding (iall) -import Data.List -import Data.Proxy -import Control.Monad -import Data.Kind (Type) -import Data.Foldable (toList) -import Control.Arrow -import qualified Data.Sequence as Seq -import Data.Bool -import qualified Data.Map.Strict as M -import Control.Applicative - --- $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 Data.These --- >>> import Predicate.Prelude - --- | 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] --- --- >>> pl @(FlipT (:+) (Fst Id) (Snd Id)) ([1..5],99) --- Present [99,1,2,3,4,5] ((:+) [99,1,2,3,4,5] | p=99 | q=[1,2,3,4,5]) --- PresentT [99,1,2,3,4,5] --- --- >>> pl @(Fst Id :+ Snd Id) (99,[1..5]) --- Present [99,1,2,3,4,5] ((:+) [99,1,2,3,4,5] | p=99 | q=[1,2,3,4,5]) --- PresentT [99,1,2,3,4,5] --- --- >>> pl @(4 :+ '[1,2,3]) () --- Present [4,1,2,3] ((:+) [4,1,2,3] | p=4 | q=[1,2,3]) --- PresentT [4,1,2,3] --- --- >>> pl @(Fst Id :+ Snd Id) (4,[1,2,3]) --- Present [4,1,2,3] ((:+) [4,1,2,3] | p=4 | q=[1,2,3]) --- PresentT [4,1,2,3] --- --- >>> pl @(FlipT (:+) '[1,2,3] 5) () --- Present [5,1,2,3] ((:+) [5,1,2,3] | p=5 | q=[1,2,3]) --- PresentT [5,1,2,3] --- -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] --- --- >>> pl @('[1,2,3] +: 4) () --- Present [1,2,3,4] ((+:) [1,2,3,4] | p=[1,2,3] | q=4) --- PresentT [1,2,3,4] --- --- >>> pl @(Snd Id +: Fst Id) (4,[1,2,3]) --- Present [1,2,3,4] ((+:) [1,2,3,4] | p=[1,2,3] | q=4) --- PresentT [1,2,3,4] --- --- >>> pl @("abc" +: Char1 "x") () --- Present "abcx" ((+:) "abcx" | p="abc" | q='x') --- PresentT "abcx" --- --- >>> pl @(Fst Id +: Snd Id) ("abc" :: T.Text,'x') --- Present "abcx" ((+:) "abcx" | p="abc" | q='x') --- PresentT "abcx" --- -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] - --- | similar to '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")) --- --- >>> pl @Uncons ("asfd" :: T.Text) --- Present Just ('a',"sfd") (Uncons Just ('a',"sfd") | "asfd") --- PresentT (Just ('a',"sfd")) --- --- >>> pl @Uncons ("" :: T.Text) --- Present Nothing (Uncons Nothing | "") --- PresentT Nothing --- --- >>> pl @Uncons [1..5] -- with Typeable would need to specify the type of [1..5] --- Present Just (1,[2,3,4,5]) (Uncons Just (1,[2,3,4,5]) | [1,2,3,4,5]) --- PresentT (Just (1,[2,3,4,5])) --- - -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) [] - --- | similar to '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')) --- --- >>> pl @Unsnoc ("asfd" :: T.Text) --- Present Just ("asf",'d') (Unsnoc Just ("asf",'d') | "asfd") --- PresentT (Just ("asf",'d')) --- --- >>> pl @Unsnoc ("" :: T.Text) --- Present Nothing (Unsnoc Nothing | "") --- PresentT Nothing --- --- >>> pl @Unsnoc [1..5] --- Present Just ([1,2,3,4],5) (Unsnoc Just ([1,2,3,4],5) | [1,2,3,4,5]) --- PresentT (Just ([1,2,3,4],5)) --- - -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) [] - --- | rotate a list \'p\' \'n\' units --- --- >>> pz @(Rotate 0 Id) [1,2,3,4] --- PresentT [1,2,3,4] --- --- >>> pz @(Rotate (Negate 1) Id) [1,2,3,4] --- PresentT [4,1,2,3] --- --- >>> pz @(Rotate 2 Id) [1,2,3,4] --- PresentT [3,4,1,2] --- --- >>> pz @(Map (Rotate Id "abcd") Id) [-3..7] --- PresentT ["bcda","cdab","dabc","abcd","bcda","cdab","dabc","abcd","bcda","cdab","dabc"] --- -data Rotate n p -type RotateT n p = SplitAt (n `Mod` Length p) p >> Swap >> Fst Id <> Snd Id - -instance P (RotateT n p) x => P (Rotate n p) x where - type PP (Rotate n p) x = PP (RotateT n p) x - eval _ = eval (Proxy @(RotateT n p)) - - --- | 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],[]) --- --- >>> pl @(Partition (Lt 2) Id >> Id) [1,2,3,4,5] --- Present ([1],[2,3,4,5]) ((>>) ([1],[2,3,4,5]) | {Id ([1],[2,3,4,5])}) --- PresentT ([1],[2,3,4,5]) --- --- >>> pl @(Partition (Gt 3) Id) [1..10] --- Present ([4,5,6,7,8,9,10],[1,2,3]) (Partition ([4,5,6,7,8,9,10],[1,2,3]) | s=[1,2,3,4,5,6,7,8,9,10]) --- PresentT ([4,5,6,7,8,9,10],[1,2,3]) --- --- >>> pl @(Partition Even Id) [1..6] --- Present ([2,4,6],[1,3,5]) (Partition ([2,4,6],[1,3,5]) | s=[1,2,3,4,5,6]) --- PresentT ([2,4,6],[1,3,5]) --- --- >>> pl @(Partition Even Id >> Null *** (Len > 4) >> Fst Id == Snd Id) [1..6] --- True ((>>) True | {False == False}) --- TrueT --- --- >>> pl @(Partition (ExitWhen "ExitWhen" (Gt 10) >> Gt 2) Id) [1..11] --- Error ExitWhen (Partition(i=10, a=11) excnt=1) --- FailT "ExitWhen" --- --- >>> pl @(Partition (Prime Id) Id) [1..15] --- Present ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) (Partition ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) | s=[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]) --- PresentT ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) --- -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 @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 @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 () -> - 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 @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]) --- --- >>> pl @(Break (Gt 2) Id) [1..11] --- Present ([1,2],[3,4,5,6,7,8,9,10,11]) (Break cnt=(2,9)) --- PresentT ([1,2],[3,4,5,6,7,8,9,10,11]) --- --- >>> pl @(Break (If (Gt 2) 'True (If (Gt 4) (Failt _ "ASfd") 'False)) Id) [1..8] --- Present ([1,2],[3,4,5,6,7,8]) (Break cnt=(2,6)) --- PresentT ([1,2],[3,4,5,6,7,8]) --- --- >>> pl @(Break (Case 'False '[Gt 2,Gt 4] '[ W 'True, Failt _ "ASfd"] Id) Id) [1..8] -- case version --- Present ([1,2],[3,4,5,6,7,8]) (Break cnt=(2,6)) --- PresentT ([1,2],[3,4,5,6,7,8]) --- --- >>> pl @(Break (If (Gt 2) (Failt _ "ASfd") 'False) Id) [1..8] --- Error ASfd (Break predicate failed) --- FailT "ASfd" --- --- >>> pl @(Break (Snd Id) Id) (zip [1..] [False,False,False,True,True,False]) --- Present ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)]) (Break cnt=(3,3)) --- PresentT ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)]) --- --- >>> pl @(Break (Snd Id) Id) (zip [1..] [False,False,False,False]) --- Present ([(1,False),(2,False),(3,False),(4,False)],[]) (Break cnt=(4,0)) --- PresentT ([(1,False),(2,False),(3,False),(4,False)],[]) --- --- >>> pl @(Break (Snd Id) Id) (zip [1..] [True,True,True,True]) --- Present ([],[(1,True),(2,True),(3,True),(4,True)]) (Break cnt=(0,4)) --- PresentT ([],[(1,True),(2,True),(3,True),(4,True)]) --- - -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 @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 - --- | similar to 'span' --- --- >>> pl @(Span (Lt 4) Id) [1..11] --- Present ([1,2,3],[4,5,6,7,8,9,10,11]) (Break cnt=(3,8)) --- PresentT ([1,2,3],[4,5,6,7,8,9,10,11]) --- - -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)) - --- | 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] --- --- >>> pl @(Intercalate (Fst Id) (Snd Id)) ([0,1], [12,13,14,15,16]) --- Present [12,0,1,13,0,1,14,0,1,15,0,1,16] (Intercalate [12,0,1,13,0,1,14,0,1,15,0,1,16] | [0,1] | [12,13,14,15,16]) --- PresentT [12,0,1,13,0,1,14,0,1,15,0,1,16] --- --- >>> pl @((Pure [] (Negate Len) &&& Id) >> Intercalate (Fst Id) (Snd Id)) [12,13,14,15,16] --- Present [12,-5,13,-5,14,-5,15,-5,16] ((>>) [12,-5,13,-5,14,-5,15,-5,16] | {Intercalate [12,-5,13,-5,14,-5,15,-5,16] | [-5] | [12,13,14,15,16]}) --- PresentT [12,-5,13,-5,14,-5,15,-5,16] --- -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 - --- | 'elem' function --- --- >>> pz @(Elem (Fst Id) (Snd Id)) ('x',"abcdxy") --- TrueT --- --- >>> pz @(Elem (Fst Id) (Snd Id)) ('z',"abcdxy") --- FalseT --- --- >>> pl @(Elem Id '[2,3,4]) 2 --- True (2 `elem` [2,3,4]) --- TrueT --- --- >>> pl @(Elem Id '[2,3,4]) 6 --- False (6 `elem` [2,3,4]) --- FalseT --- --- >>> pl @(Elem Id '[13 % 2]) 6.5 --- True (13 % 2 `elem` [13 % 2]) --- TrueT --- --- >>> pl @(Elem Id '[13 % 2, 12 % 1]) 6.5 --- True (13 % 2 `elem` [13 % 2,12 % 1]) --- TrueT --- --- >>> pl @(Elem Id '[13 % 2, 12 % 1]) 6 --- False (6 % 1 `elem` [13 % 2,12 % 1]) --- 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] - --- | 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 [[]] --- --- >>> pl @Tails "abcd" --- Present ["abcd","bcd","cd","d",""] (Tails ["abcd","bcd","cd","d",""] | "abcd") --- PresentT ["abcd","bcd","cd","d",""] --- -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] - -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]) - --- | left pad \'q\' with \'n\' values from \'p\' --- --- >>> pl @(PadL 5 0 Id) [1..3] --- Present [0,0,1,2,3] (PadL 5 pad=0 [0,0,1,2,3] | [1,2,3]) --- PresentT [0,0,1,2,3] --- --- >>> 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] --- --- >>> pl @(PadL 10 0 Id) [1..3] --- Present [0,0,0,0,0,0,0,1,2,3] (PadL 10 pad=0 [0,0,0,0,0,0,0,1,2,3] | [1,2,3]) --- PresentT [0,0,0,0,0,0,0,1,2,3] --- -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)) - --- | right pad \'q\' with \'n\' values from \'p\' --- --- >>> pl @(PadR 5 8 Id) [1..3] --- Present [1,2,3,8,8] (PadR 5 pad=8 [1,2,3,8,8] | [1,2,3]) --- PresentT [1,2,3,8,8] --- --- >>> pl @(PadR 5 0 Id) [1..5] --- Present [1,2,3,4,5] (PadR 5 pad=0 [1,2,3,4,5] | [1,2,3,4,5]) --- PresentT [1,2,3,4,5] --- --- >>> pl @(PadR 5 0 Id) [1..6] --- Present [1,2,3,4,5,6] (PadR 5 pad=0 [1,2,3,4,5,6] | [1,2,3,4,5,6]) --- PresentT [1,2,3,4,5,6] --- -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","",""] --- --- >>> pl @(SplitAts '[1,3,4] Id) [1..12] --- Present [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] (SplitAts [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] | ns=[1,3,4] | [1,2,3,4,5,6,7,8,9,10,11,12]) --- PresentT [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] --- --- >>> pl @(SplitAts '[3,1,1,1] Id >> Filter (Not Null) Id) [1..4] --- Present [[1,2,3],[4]] ((>>) [[1,2,3],[4]] | {Fst [[1,2,3],[4]] | ([[1,2,3],[4]],[[],[]])}) --- PresentT [[1,2,3],[4]] --- -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") --- --- >>> pl @(Snd Id >> SplitAt 2 Id >> Len *** Len >> Fst Id > Snd Id) ('x',[1..5]) --- False ((>>) False | {2 > 3}) --- FalseT --- -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)) - --- | 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 - --- empty lists at the type level wont work here - -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] - --- | filters a list \'q\' keeping 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] --- -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)) - --- | filters a list \'q\' removing those elements in \'p\' --- --- >>> 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 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)) - --- | takes the head of a list-like container: similar to 'head' --- --- >>> pz @(Head Id) "abcd" --- PresentT 'a' --- --- >>> pz @(Head Id) [] --- FailT "Head(empty)" --- --- >>> pl @(Head Id) ([] :: [Int]) --- Error Head(empty) --- FailT "Head(empty)" --- --- >>> pl @(Head Id) ([] :: [Double]) --- Error Head(empty) --- FailT "Head(empty)" --- --- >>> pl @(Head (Fst Id) >> Le 6) ([]::[Int], True) --- Error Head(empty) ((>>) lhs failed) --- FailT "Head(empty)" --- --- >>> pl @(Head Id) [1,2,3] --- Present 1 (Head 1 | [1,2,3]) --- PresentT 1 --- - -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: similar to 'tail' --- --- >>> pz @(Tail Id) "abcd" --- PresentT "bcd" --- --- >>> pl @(Tail Id) [1..5] --- Present [2,3,4,5] (Tail [2,3,4,5] | [1,2,3,4,5]) --- PresentT [2,3,4,5] --- --- >>> pl @(Tail Id) ([] :: [()]) --- Error Tail(empty) --- 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: similar to 'last' --- --- >>> pz @(Last Id) "abcd" --- PresentT 'd' --- --- >>> pz @(Last Id) [] --- FailT "Last(empty)" --- --- >>> pl @(Last Id) [1,2,3] --- Present 3 (Last 3 | [1,2,3]) --- PresentT 3 --- - -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: similar to 'init' --- --- >>> pz @(Init Id) "abcd" --- PresentT "abc" --- --- >>> pz @(Init Id) (T.pack "abcd") --- PresentT "abc" --- --- >>> pz @(Init Id) [] --- FailT "Init(empty)" --- --- >>> pl @(Init Id) [1..5] --- Present [1,2,3,4] (Init [1,2,3,4] | [1,2,3,4,5]) --- PresentT [1,2,3,4] --- --- >>> pl @(Init Id) ([] :: [()]) --- Error Init(empty) --- 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] - - --- | '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) - --- | 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")] --- --- >>> pl @(SortBy (Swap >> OrdA (Fst Id)) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) --- Present [('z',1),('m',22),('a',10)] (SortBy [('z',1),('m',22),('a',10)]) --- PresentT [('z',1),('m',22),('a',10)] --- --- >>> pl @(SortBy (OrdA Reverse) Id) ["az","by","cx","aa"] --- Present ["aa","cx","by","az"] (SortBy ["aa","cx","by","az"]) --- PresentT ["aa","cx","by","az"] --- --- >>> pl @(SortBy (If (Fst Id==5 && Snd Id==3) (Failt _ (PrintT "pivot=%d value=%d" Id)) 'GT) (Snd Id)) ((), [5,7,3,1,6,2,1,3]) --- Error pivot=5 value=3(2) (SortBy) --- FailT "pivot=5 value=3(2)" --- --- >>> 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]) --- Present [1,1,2,3,3,5,6,7] (SortBy [1,1,2,3,3,5,6,7]) --- PresentT [1,1,2,3,3,5,6,7] --- -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 @(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] - --- | similar to 'sortOn' --- --- >>> pl @(SortOn Id Id) [10,4,2,12,14] --- Present [2,4,10,12,14] (SortBy [2,4,10,12,14]) --- PresentT [2,4,10,12,14] --- --- >>> pl @(SortOn (Negate Id) Id) [10,4,2,12,14] --- Present [14,12,10,4,2] (SortBy [14,12,10,4,2]) --- PresentT [14,12,10,4,2] --- --- >>> pl @(SortOn (Fst Id) Id) (zip "cabdaz" [10,4,2,12,14,1]) --- Present [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)] (SortBy [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)]) --- PresentT [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)] --- --- >>> pl @(SortOn (FailS "asdf") Id) [10,4,2,12,14] --- Error asdf(4) (SortBy) --- FailT "asdf(4)" --- --- >>> pl @(SortOn (Snd Id) (Snd Id)) ((),[('z',14),('a',10),('m',22),('a',1)]) --- Present [('a',1),('a',10),('z',14),('m',22)] (SortBy [('a',1),('a',10),('z',14),('m',22)]) --- PresentT [('a',1),('a',10),('z',14),('m',22)] --- --- >>> pl @(SortOn (Fst Id) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) --- Present [('a',10),('m',22),('z',1)] (SortBy [('a',10),('m',22),('z',1)]) --- PresentT [('a',10),('m',22),('z',1)] --- --- >>> pl @(SortOn (Fst Id) Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] --- Present [('a',10),('a',9),('m',22),('m',10),('z',1)] (SortBy [('a',10),('a',9),('m',22),('m',10),('z',1)]) --- PresentT [('a',10),('a',9),('m',22),('m',10),('z',1)] --- --- >>> pl @(SortOn Id Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] --- Present [('a',9),('a',10),('m',10),('m',22),('z',1)] (SortBy [('a',9),('a',10),('m',10),('m',22),('z',1)]) --- PresentT [('a',9),('a',10),('m',10),('m',22),('z',1)] --- -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)) - --- | 'SortOn' but descending order --- --- >>> pl @(SortOnDesc Id Id) [10,4,2,12,14] --- Present [14,12,10,4,2] (SortBy [14,12,10,4,2]) --- PresentT [14,12,10,4,2] --- --- >>> pl @(SortOnDesc (Fst Id) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) --- Present [('z',1),('m',22),('a',10)] (SortBy [('z',1),('m',22),('a',10)]) --- PresentT [('z',1),('m',22),('a',10)] --- -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 '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" --- --- >>> pl @ReverseL ("asfd" :: T.Text) --- Present "dfsa" (ReverseL "dfsa" | "asfd") --- PresentT "dfsa" --- -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) [] - --- | 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] - -data EmptyList' t - -instance P (EmptyList' t) x where - type PP (EmptyList' t) x = [PP t x] - eval _ opts _ = - pure $ mkNode opts (PresentT []) "EmptyList" [] - --- | creates an empty list for the given type --- --- >>> pz @(Id :+ EmptyList _) 99 --- PresentT [99] --- -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)) - - --- | like 'zipWith' --- --- >>> pz @(ZipWith Id (1...5) (Char1 "a" ... Char1 "e")) () --- PresentT [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e')] --- --- >>> pz @(ZipWith (ShowP (Fst Id) <> ShowP (Snd Id)) (1...5) (Char1 "a" ... Char1 "e")) () --- PresentT ["1'a'","2'b'","3'c'","4'd'","5'e'"] --- --- >>> pz @(ZipWith (MkThese (Fst Id) (Snd Id)) (1...6) (Char1 "a" ... Char1 "f")) () --- PresentT [These 1 'a',These 2 'b',These 3 'c',These 4 'd',These 5 'e',These 6 'f'] --- --- >>> pz @(ZipWith (MkThese (Fst Id) (Snd Id)) '[] (Char1 "a" ... Char1 "f")) () --- FailT "ZipWith(0,6) length mismatch" --- --- >>> pz @(ZipWith (MkThese (Fst Id) (Snd Id)) (1...3) (Char1 "a" ... Char1 "f")) () --- FailT "ZipWith(3,6) length mismatch" --- -data ZipWith p q r - -instance (PP q a ~ [x] - , PP r a ~ [y] - , P q a - , P r a - , P p (x,y) - , Show x - , Show y - , Show (PP p (x,y)) - ) => P (ZipWith p q r) a where - type PP (ZipWith p q r) a = [PP p (ExtractAFromList (PP q a), ExtractAFromList (PP r a))] - eval _ opts a = do - let msg0 = "ZipWith" - lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts a [] - case lr of - Left e -> pure e - Right (q,r,qq,rr) -> - let hhs = [hh qq, hh rr] - in case chkSize opts msg0 q hhs <* chkSize opts msg0 r hhs of - Left e -> pure e - Right () -> do - let lls = (length q, length r) - if uncurry (==) lls then do - ts <- zipWithM (\i (x,y) -> ((i, (x,y)),) <$> evalHide @p opts (x,y)) [0::Int ..] (zip q r) - 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 = map fst kvs - in mkNode opts (PresentT ret) (show01' opts msg0 ret "s=" q ) (hh qq : map (hh . fixit) itts) - - else do - let msg1 = msg0 ++ show lls - pure $ mkNode opts (FailT (msg1 <> " length mismatch")) (showVerbose opts "q=" q <> showVerbose opts " | r=" r) hhs - --- | Zip two lists to their maximum length using optional padding --- --- >>> 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 optionally padding the left hand side --- --- >>> 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" --- --- >>> pl @(ZipL 99 Id "abcdefg") [1..4] --- Present [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] (ZipL [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] | p=[1,2,3,4] | q="abcdefg") --- PresentT [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] --- --- >>> pl @(ZipL (99 % 4) '[1 % 1 , 2 % 1 , 3 % 1] Id) "abcde" --- Present [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] (ZipL [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] | p=[1 % 1,2 % 1,3 % 1] | q="abcde") --- PresentT [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] --- --- >>> pl @(ZipL "X" (EmptyT _ Id) Id) ("abcd" :: String) --- Present [("X",'a'),("X",'b'),("X",'c'),("X",'d')] (ZipL [("X",'a'),("X",'b'),("X",'c'),("X",'d')] | p=[] | q="abcd") --- PresentT [("X",'a'),("X",'b'),("X",'c'),("X",'d')] --- - -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 optionally padding the right hand side --- --- >>> 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" --- --- >>> pl @(ZipR (Char1 "Y") (EmptyT _ Id) Id) "abcd" --- Error ZipR(0,4) rhs would be truncated (p=[] | q="abcd") --- FailT "ZipR(0,4) 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" --- --- >>> pl @(Zip "abc" Id) [1..7] --- Error Zip(3,7) length mismatch (p="abc" | q=[1,2,3,4,5,6,7]) --- FailT "Zip(3,7) 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 - --- | 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] - - --- | 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) [] - +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted list functions +module Predicate.Data.List ( + + -- ** constructors + type (:+) + , type (+:) + , type (++) + , Singleton + , EmptyT + , EmptyList + , EmptyList' + + -- ** destructors + , Uncons + , Unsnoc + , Head + , Tail + , Init + , Last + + -- ** sort + , SortBy + , SortOn + , SortOnDesc + , Sort + + -- ** zip related + , Unzip + , Unzip3 + , ZipL + , ZipR + , Zip + , ZipWith + , ZipCartesian + , ZipPad + + -- ** higher order methods + , Partition + , Quant + , All1 + , PartitionBy + , Group + , GroupBy + , GroupCnt + , GroupCntStable + , Filter + , Break + , Span + , Intercalate + + -- ** miscellaneous + , Elem + , Inits + , Tails + , Ones + , PadL + , PadR + , SplitAts + , SplitAt + , ChunksOf + , ChunksOf' + , Rotate + , Take + , Drop + , Remove + , Keep + , Reverse + , ReverseL + , Nub + + , Sum + , Product + , Min + , Max + + , IsPrefix + , IsInfix + , IsSuffix + + ) where +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import Predicate.Data.Ordering (type (==), OrdA', type (>)) +import Predicate.Data.Numeric (Mod) +import Predicate.Data.Monoid (type (<>)) +import Control.Lens +import Data.List (partition, intercalate, inits, tails, unfoldr, isInfixOf, isPrefixOf, isSuffixOf, sortOn) +import Data.Proxy (Proxy(Proxy)) +import Control.Monad (zipWithM) +import Data.Kind (Type) +import Data.Foldable (toList) +import Control.Arrow (Arrow((***), (&&&))) +import qualified Data.Sequence as Seq +import Data.Bool (bool) +import qualified Data.Map.Strict as M +import Control.Applicative (Alternative(empty), liftA2) +import Data.Containers.ListUtils (nubOrd) +import qualified Data.List.NonEmpty as NE +-- $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 Data.These +-- >>> import Predicate.Prelude + +-- | similar to (++) +-- +-- >>> pz @(Fst ++ Snd) ([9,10,11],[1,2,3,4]) +-- Val [9,10,11,1,2,3,4] +-- +-- >>> pz @(Snd ++ Fst) ([],[5]) +-- Val [5] +-- +-- >>> pz @(C "xyz" :+ W "ab" ++ W "cdefg") () +-- Val "xabcdefg" +-- +-- >>> pz @([1,2,3] ++ EmptyList _) "somestuff" +-- Val [1,2,3] +-- +data p ++ q deriving Show +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 NoInline 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 (Val b) (show3' 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 :+ Snd) (99,[1,2,3,4]) +-- Val [99,1,2,3,4] +-- +-- >>> pz @(Snd :+ Fst) ([],5) +-- Val [5] +-- +-- >>> pz @(123 :+ EmptyList _) "somestuff" +-- Val [123] +-- +-- >>> pl @(FlipT (:+) Fst Snd) ([1..5],99) +-- Present [99,1,2,3,4,5] ((:+) [99,1,2,3,4,5] | p=99 | q=[1,2,3,4,5]) +-- Val [99,1,2,3,4,5] +-- +-- >>> pl @(Fst :+ Snd) (99,[1..5]) +-- Present [99,1,2,3,4,5] ((:+) [99,1,2,3,4,5] | p=99 | q=[1,2,3,4,5]) +-- Val [99,1,2,3,4,5] +-- +-- >>> pl @(4 :+ '[1,2,3]) () +-- Present [4,1,2,3] ((:+) [4,1,2,3] | p=4 | q=[1,2,3]) +-- Val [4,1,2,3] +-- +-- >>> pl @(Fst :+ Snd) (4,[1,2,3]) +-- Present [4,1,2,3] ((:+) [4,1,2,3] | p=4 | q=[1,2,3]) +-- Val [4,1,2,3] +-- +-- >>> pl @(FlipT (:+) '[1,2,3] 5) () +-- Present [5,1,2,3] ((:+) [5,1,2,3] | p=5 | q=[1,2,3]) +-- Val [5,1,2,3] +-- +data p :+ q deriving Show +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 NoInline 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 (Val b) (show3' opts msg0 b "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to snoc +-- +-- >>> pz @(Snd +: Fst) (99,[1,2,3,4]) +-- Val [1,2,3,4,99] +-- +-- >>> pz @(Fst +: Snd) ([],5) +-- Val [5] +-- +-- >>> pz @(EmptyT [] +: 5) 5 +-- Val [5] +-- +-- >>> pl @('[1,2,3] +: 4) () +-- Present [1,2,3,4] ((+:) [1,2,3,4] | p=[1,2,3] | q=4) +-- Val [1,2,3,4] +-- +-- >>> pl @(Snd +: Fst) (4,[1,2,3]) +-- Present [1,2,3,4] ((+:) [1,2,3,4] | p=[1,2,3] | q=4) +-- Val [1,2,3,4] +-- +-- >>> pl @("abc" +: C "x") () +-- Present "abcx" ((+:) "abcx" | p="abc" | q='x') +-- Val "abcx" +-- +-- >>> pl @(Fst +: Snd) ("abc" :: T.Text,'x') +-- Present "abcx" ((+:) "abcx" | p="abc" | q='x') +-- Val "abcx" +-- +data p +: q deriving Show +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 NoInline 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 (Val b) (show3' opts msg0 b "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | similar to 'Control.Lens.uncons' +-- +-- >>> pz @Uncons [1,2,3,4] +-- Val (Just (1,[2,3,4])) +-- +-- >>> pz @Uncons [] +-- Val Nothing +-- +-- >>> pz @Uncons (Seq.fromList "abc") +-- Val (Just ('a',fromList "bc")) +-- +-- >>> pz @Uncons ("xyz" :: T.Text) +-- Val (Just ('x',"yz")) +-- +-- >>> pl @Uncons ("asfd" :: T.Text) +-- Present Just ('a',"sfd") (Uncons Just ('a',"sfd") | "asfd") +-- Val (Just ('a',"sfd")) +-- +-- >>> pl @Uncons ("" :: T.Text) +-- Present Nothing (Uncons Nothing | "") +-- Val Nothing +-- +-- >>> pl @Uncons [1..5] -- with Typeable would need to specify the type of [1..5] +-- Present Just (1,[2,3,4,5]) (Uncons Just (1,[2,3,4,5]) | [1,2,3,4,5]) +-- Val (Just (1,[2,3,4,5])) +-- +data Uncons deriving Show + +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 (Val b) (show3 opts msg0 b as) [] + +-- | similar to 'Control.Lens.unsnoc' +-- +-- >>> pz @Unsnoc [1,2,3,4] +-- Val (Just ([1,2,3],4)) +-- +-- >>> pz @Unsnoc [] +-- Val Nothing +-- +-- >>> pz @Unsnoc ("xyz" :: T.Text) +-- Val (Just ("xy",'z')) +-- +-- >>> pl @Unsnoc ("asfd" :: T.Text) +-- Present Just ("asf",'d') (Unsnoc Just ("asf",'d') | "asfd") +-- Val (Just ("asf",'d')) +-- +-- >>> pl @Unsnoc ("" :: T.Text) +-- Present Nothing (Unsnoc Nothing | "") +-- Val Nothing +-- +-- >>> pl @Unsnoc [1..5] +-- Present Just ([1,2,3,4],5) (Unsnoc Just ([1,2,3,4],5) | [1,2,3,4,5]) +-- Val (Just ([1,2,3,4],5)) +-- +data Unsnoc deriving Show + +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 (Val b) (show3 opts msg0 b as) [] + +-- | rotate a list @p@ @n@ units +-- +-- >>> pz @(Rotate 0 Id) [1,2,3,4] +-- Val [1,2,3,4] +-- +-- >>> pz @(Rotate (Negate 1) Id) [1,2,3,4] +-- Val [4,1,2,3] +-- +-- >>> pz @(Rotate 2 Id) [1,2,3,4] +-- Val [3,4,1,2] +-- +-- >>> pz @(Map (Rotate Id "abcd")) [-3..7] +-- Val ["bcda","cdab","dabc","abcd","bcda","cdab","dabc","abcd","bcda","cdab","dabc"] +-- +data Rotate n p deriving Show +type RotateT n p = SplitAt (n `Mod` Length p) p >> Swap >> Fst <> Snd + +instance P (RotateT n p) x => P (Rotate n p) x where + type PP (Rotate n p) x = PP (RotateT n p) x + eval _ = eval (Proxy @(RotateT n p)) + + +-- | similar to 'Data.List.partition' +-- +-- >>> pz @(Partition (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- Val ([10,4,7,3,3,5],[1,1]) +-- +-- >>> pz @(Partition IsPrime Id) [10,4,1,7,3,1,3,5] +-- Val ([7,3,3,5],[10,4,1,1]) +-- +-- >>> pz @(Partition (Ge 300) Id) [10,4,1,7,3,1,3,5] +-- Val ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pz @(Partition (Id < 300) Id) [10,4,1,7,3,1,3,5] +-- Val ([10,4,1,7,3,1,3,5],[]) +-- +-- >>> pl @(Partition (Lt 2) Id >> Id) [1,2,3,4,5] +-- Present ([1],[2,3,4,5]) ((>>) ([1],[2,3,4,5]) | {Id ([1],[2,3,4,5])}) +-- Val ([1],[2,3,4,5]) +-- +-- >>> pl @(Partition (Gt 3) Id) [1..10] +-- Present ([4,5,6,7,8,9,10],[1,2,3]) (Partition ([4,5,6,7,8,9,10],[1,2,3]) | s=[1,2,3,4,5,6,7,8,9,10]) +-- Val ([4,5,6,7,8,9,10],[1,2,3]) +-- +-- >>> pl @(Partition Even Id) [1..6] +-- Present ([2,4,6],[1,3,5]) (Partition ([2,4,6],[1,3,5]) | s=[1,2,3,4,5,6]) +-- Val ([2,4,6],[1,3,5]) +-- +-- >>> pl @(Partition Even Id >> Null *** (Len > 4) >> Fst == Snd) [1..6] +-- True ((>>) True | {False == False}) +-- Val True +-- +-- >>> pl @(Partition (ExitWhen "ExitWhen" (Gt 10) >> Gt 2) Id) [1..11] +-- Error ExitWhen (Partition(i=10, a=11) excnt=1) +-- Fail "ExitWhen" +-- +-- >>> pl @(Partition IsPrime Id) [1..15] +-- Present ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) (Partition ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) | s=[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]) +-- Val ([2,3,5,7,11,13],[1,4,6,8,9,10,12,14,15]) +-- +data Partition p q deriving Show + +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 NoInline 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 @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 (Val zz1) (show3' opts msg0 zz1 "s=" q) (hh qq : map (hh . prefixNumberToTT) itts) + +-- | counts number on matches and non matches: ie All is length snd==0 and Any is length fst > 0 +-- +-- >>> pz @(Quant Even) [2,3,3,7,2,8,1,5,9] +-- Val (3,6) +-- +-- >>> pz @(Quant (Gt 10)) [2,8,1,5,9] +-- Val (0,5) +-- +-- >>> pz @(Quant (Gt 10)) [] +-- Val (0,0) +-- +-- >>> pz @(Quant (Same 4)) [3] +-- Val (0,1) +-- +-- >>> pz @(Quant (Same 4)) [4] +-- Val (1,0) +-- +data Quant p deriving Show +type QuantT p = Partition p Id >> '(Length Fst,Length Snd) + +instance P (QuantT p) x => P (Quant p) x where + type PP (Quant p) x = PP (QuantT p) x + eval _ = eval (Proxy @(QuantT p)) + +-- | similar to 'Predicate.All' for non-empty lists +-- +-- >>> pz @(All1 Even) [2,4,6] +-- Val True +-- +-- >>> pz @(All1 Even) [2,3,3,7,2,8,1,5,9] +-- Val False +-- +-- >>> pz @(All1 Even) [] +-- Val False +-- +-- >>> pz @(All1 Even) [1] +-- Val False +-- +-- >>> pz @(All1 Even) [2] +-- Val True +-- +data All1 p deriving Show + +-- partially hidden example +instance P (Quant p) x => P (All1 p) x where + type PP (All1 p) x = Bool + eval _ opts + | isVerbose opts = eval (Proxy @(Quant p >> Fst > 0 && Snd == 0)) opts + | otherwise = eval (Proxy @(Hide (Quant p) >> Fst > 0 && Snd == 0)) opts + +-- | partition values based on a function +-- +-- >>> pz @(PartitionBy Ordering (Id ==! 0) Id) [17,3,-12,0,1,0,-3] +-- Val (fromList [(LT,[-3,-12]),(EQ,[0,0]),(GT,[1,3,17])]) +-- +-- >>> pz @(PartitionBy Char (Mod Id 16 >> ShowBase 16 >> Head) Id) [-4,-2,5,0,15,12,-1,2,-3,4,0] +-- Val (fromList [('0',[0,0]),('2',[2]),('4',[4]),('5',[5]),('c',[12,-4]),('d',[-3]),('e',[-2]),('f',[-1,15])]) +-- +-- >>> 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]) +-- Val (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) +-- Fail "xyzxyzxyzzyyysyfsyfydf" +-- +-- >>> pz @(PartitionBy Ordering (Case 'EQ '[Id < 0, Id > 0] '[ 'LT, 'GT] Id) Id) [-4,-2,5,6,7,0,-1,2,-3,4,0] +-- Val (fromList [(LT,[-3,-1,-2,-4]),(EQ,[0,0]),(GT,[4,2,7,6,5])]) +-- +data PartitionBy t p q deriving Show + +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 NoInline 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 @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 (Val ret) (show3' opts msg0 ret "s=" q ) (hh qq : map (hh . prefixNumberToTT) itts) + +-- | similar to 'Data.List.groupBy' +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [1,3,4,5,1,5,5] +-- Val [[1],[3],[4],[5],[1],[5,5]] +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [1,1,1,3,4,5,1,5,5] +-- Val [[1,1,1],[3],[4],[5],[1],[5,5]] +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [5,5] +-- Val [[5,5]] +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [1,2] +-- Val [[1],[2]] +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [1] +-- Val [[1]] +-- +-- >>> pz @(GroupBy (Fst == Snd) Id) [] +-- Val [] +-- +-- >>> pz @(GroupBy (Fst < Snd) Id) [1,2,3,4,4,1,2] +-- Val [[1,2,3,4],[4],[1,2]] +-- +-- >>> pz @(GroupBy (Fst /= Snd) Id) [1,2,3,4,4,4,1] +-- Val [[1,2,3,4],[4],[4,1]] +-- +-- >>> pan @(GroupBy (Fst == Snd) 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' +-- Val ["h","e","ll","o"," ","g","oo","d","b","y","e"] +-- +data GroupBy p q deriving Show + +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 NoInline opts msg0 qq [] of + Left e -> pure e + Right q -> + case chkSize opts msg0 q [hh qq] of + Left e -> pure e + Right _ -> + case q of + [] -> pure $ mkNode opts (Val []) (show3' opts msg0 q "s=" q) [hh qq] + [_] -> let ret = [q] + in pure $ mkNode opts (Val ret) (show3' opts msg0 ret "s=" q) [hh qq] + x:xs -> do + ts <- zipWithM (\i (a,b) -> ((i, b),) <$> evalBoolHide @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 (Val ret) (show3' opts msg0 ret "s=" q ) (hh qq : map (hh . prefixNumberToTT) itts) + +-- | version of 'GroupCnt' that retains the original ordering +-- +-- >>> pz @GroupCntStable "bababab" +-- Val [('b',4),('a',3)] +-- +-- >>> pz @GroupCntStable "fedbfefa" +-- Val [('f',3),('e',2),('d',1),('b',1),('a',1)] +-- +-- >>> pz @GroupCntStable "fedc" +-- Val [('f',1),('e',1),('d',1),('c',1)] +-- +-- >>> pz @GroupCntStable "ffff" +-- Val [('f',4)] +-- +-- >>> pz @GroupCntStable "" +-- Val [] +-- +data GroupCntStable deriving Show + +instance ( a ~ [x] + , Ord x + ) => P GroupCntStable a where + type PP GroupCntStable a = [(ExtractAFromList a, Int)] + eval _ opts zs = + let msg0 = "GroupCntStable" + xs = map (NE.head &&& length) $ NE.group $ sortOn (ys M.!) zs + ys = M.fromListWith (flip const) $ zip zs [0::Int ..] + in pure $ mkNode opts (Val xs) msg0 [] + + +-- | similar to 'Data.List.group' +-- +-- >>> pz @Group [1,3,4,5,1,5,5] +-- Val [[1],[3],[4],[5],[1],[5,5]] +-- +-- >>> pz @(Sort >> Group) [1,3,4,5,1,5,5] +-- Val [[1,1],[3],[4],[5,5,5]] +-- +data Group deriving Show +type GroupT = GroupBy (Fst == Snd) Id + +instance P GroupT x => P Group x where + type PP Group x = PP GroupT x + eval _ = eval (Proxy @GroupT) + + +-- | similar to 'Group' but returns the value and count +-- +-- >>> pz @GroupCnt [1,3,4,5,1,5,5] +-- Val [(1,1),(3,1),(4,1),(5,1),(1,1),(5,2)] +-- +-- >>> pz @(Sort >> GroupCnt) [1,3,4,5,1,5,5] +-- Val [(1,2),(3,1),(4,1),(5,3)] +-- +-- >>> pz @(Sort >> GroupCnt) "xyabxaaaz" +-- Val [('a',4),('b',1),('x',2),('y',1),('z',1)] +-- +data GroupCnt deriving Show +type GroupCntT = Group >> Map '(Head,Len) + +instance P GroupCntT x => P GroupCnt x where + type PP GroupCnt x = PP GroupCntT x + eval _ = eval (Proxy @GroupCntT) + +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 + +-- | similar to 'Data.List.filter' +-- +-- >>> pz @(Filter (Gt 4) Id) [10,1,3,5,-10,12,1] +-- Val [10,5,12] +-- +data Filter p q deriving Show +type FilterT p q = Partition p q >> Fst + +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 'Data.List.break' +-- +-- >>> pz @(Break (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- Val ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pz @(Break (Lt 3) Id) [10,4,1,7,3,1,3,5] +-- Val ([10,4],[1,7,3,1,3,5]) +-- +-- >>> pl @(Break (Gt 2) Id) [1..11] +-- Present ([1,2],[3,4,5,6,7,8,9,10,11]) (Break cnt=(2,9)) +-- Val ([1,2],[3,4,5,6,7,8,9,10,11]) +-- +-- >>> pl @(Break (If (Gt 2) 'True (If (Gt 4) (FailT _ "ASfd") 'False)) Id) [1..8] +-- Present ([1,2],[3,4,5,6,7,8]) (Break cnt=(2,6)) +-- Val ([1,2],[3,4,5,6,7,8]) +-- +-- >>> pl @(Break (Case 'False '[Gt 2,Gt 4] '[W 'True, FailT _ "ASfd"] Id) Id) [1..8] -- case version +-- Present ([1,2],[3,4,5,6,7,8]) (Break cnt=(2,6)) +-- Val ([1,2],[3,4,5,6,7,8]) +-- +-- >>> pl @(Break (If (Gt 2) (FailT _ "ASfd") 'False) Id) [1..8] +-- Error ASfd (If True | Break predicate failed) +-- Fail "ASfd" +-- +-- >>> pl @(Break Snd Id) (zip [1..] [False,False,False,True,True,False]) +-- Present ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)]) (Break cnt=(3,3)) +-- Val ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)]) +-- +-- >>> pl @(Break Snd Id) (zip [1..] [False,False,False,False]) +-- Present ([(1,False),(2,False),(3,False),(4,False)],[]) (Break cnt=(4,0)) +-- Val ([(1,False),(2,False),(3,False),(4,False)],[]) +-- +-- >>> pl @(Break Snd Id) (zip [1..] [True,True,True,True]) +-- Present ([],[(1,True),(2,True),(3,True),(4,True)]) (Break cnt=(0,4)) +-- Val ([],[(1,True),(2,True),(3,True),(4,True)]) +-- +data Break p q deriving Show + +-- only process up to the pivot! only process while Right False +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 NoInline 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 @p opts a + let v = ((i,a), pp) + case getValueLR NoInline 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 (Val (map (snd . fst) (toList ialls), rhs)) + (msg0 <> " cnt=" <> show (length ialls, length rhs)) + (map (hh . prefixNumberToTT) (toList ialls)) + Just iatt@(ia, tt) -> + case getValueLR NoInline opts (msg0 <> " predicate failed") tt (hh qq : map (hh . prefixNumberToTT) (toList (ialls Seq.|> iatt))) of + Right True -> + mkNode opts (Val (map (snd . fst) (toList ialls), snd ia : rhs)) + (msg0 <> " cnt=" <> show (length ialls, 1+length rhs)) + (hh qq : hh tt : map (hh . prefixNumberToTT) (toList (ialls Seq.|> iatt))) + + Right False -> errorInProgram "Break" + Left e -> e + +-- | similar to 'Data.List.span' +-- +-- >>> pl @(Span (Lt 4) Id) [1..11] +-- Present ([1,2,3],[4,5,6,7,8,9,10,11]) (Break cnt=(3,8)) +-- Val ([1,2,3],[4,5,6,7,8,9,10,11]) +-- +data Span p q deriving Show +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)) + +-- | intercalate two lists +-- +-- >>> pz @(Intercalate '["aB"] '["xxxx","yz","z","www","xyz"]) () +-- Val ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] +-- +-- >>> pz @(Intercalate '[W 99,Negate 98] Id) [1..5] +-- Val [1,99,-98,2,99,-98,3,99,-98,4,99,-98,5] +-- +-- >>> pz @(Intercalate '[99,100] Id) [1..5] +-- Val [1,99,100,2,99,100,3,99,100,4,99,100,5] +-- +-- >>> pl @(Intercalate Fst Snd) ([0,1], [12,13,14,15,16]) +-- Present [12,0,1,13,0,1,14,0,1,15,0,1,16] (Intercalate [12,0,1,13,0,1,14,0,1,15,0,1,16] | [0,1] | [12,13,14,15,16]) +-- Val [12,0,1,13,0,1,14,0,1,15,0,1,16] +-- +-- >>> pl @((Pure [] (Negate Len) &&& Id) >> Intercalate Fst Snd) [12,13,14,15,16] +-- Present [12,-5,13,-5,14,-5,15,-5,16] ((>>) [12,-5,13,-5,14,-5,15,-5,16] | {Intercalate [12,-5,13,-5,14,-5,15,-5,16] | [-5] | [12,13,14,15,16]}) +-- Val [12,-5,13,-5,14,-5,15,-5,16] +-- +data Intercalate p q deriving Show + +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 NoInline 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 chkSize2 opts msg0 p q hhs of + Left e -> e + Right _ -> + let d = intercalate p (map pure q) + in mkNode opts (Val d) (show3 opts msg0 d p <> showVerbose opts " | " q) hhs + +-- | 'elem' function +-- +-- >>> pz @(Elem Fst Snd) ('x',"abcdxy") +-- Val True +-- +-- >>> pz @(Elem Fst Snd) ('z',"abcdxy") +-- Val False +-- +-- >>> pl @(Elem Id '[2,3,4]) 2 +-- True (2 `elem` [2,3,4]) +-- Val True +-- +-- >>> pl @(Elem Id '[2,3,4]) 6 +-- False (6 `elem` [2,3,4]) +-- Val False +-- +-- >>> pl @(Elem Id '[13 % 2]) 6.5 +-- True (13 % 2 `elem` [13 % 2]) +-- Val True +-- +-- >>> pl @(Elem Id '[13 % 2, 12 % 1]) 6.5 +-- True (13 % 2 `elem` [13 % 2,12 % 1]) +-- Val True +-- +-- >>> pl @(Elem Id '[13 % 2, 12 % 1]) 6 +-- False (6 % 1 `elem` [13 % 2,12 % 1]) +-- Val False +-- +data Elem p q deriving Show + +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 NoInline 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] + +-- | similar to 'Data.List.inits' +-- +-- >>> pz @Inits [4,8,3,9] +-- Val [[],[4],[4,8],[4,8,3],[4,8,3,9]] +-- +-- >>> pz @Inits [] +-- Val [[]] +-- +data Inits deriving Show + +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 (Val xs) (show3 opts msg0 xs as) [] + +-- | similar to 'Data.List.tails' +-- +-- >>> pz @Tails [4,8,3,9] +-- Val [[4,8,3,9],[8,3,9],[3,9],[9],[]] +-- +-- >>> pz @Tails [] +-- Val [[]] +-- +-- >>> pl @Tails "abcd" +-- Present ["abcd","bcd","cd","d",""] (Tails ["abcd","bcd","cd","d",""] | "abcd") +-- Val ["abcd","bcd","cd","d",""] +-- +data Tails deriving Show + +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 (Val xs) (show3 opts msg0 xs as) [] + +-- | split a list into single values +-- +-- >>> pz @Ones [4,8,3,9] +-- Val [[4],[8],[3],[9]] +-- +-- >>> pz @Ones [] +-- Val [] +-- +data Ones deriving Show + +instance x ~ [a] => P Ones x where + type PP Ones x = [x] + eval _ opts x = + let msg0 = "Ones" + in pure $ case chkSize opts msg0 x [] of + Left e -> e + Right _ -> + let d = map pure x + in mkNode opts (Val d) msg0 [] + +data PadImpl (left :: Bool) n p q deriving Show + +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 NoInline 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=" <> showL opts p + hhs = [hh nn, hh pp] + qq <- eval (Proxy @q) opts a + pure $ case getValueLR NoInline 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 (Val bs) (show3 opts msg1 bs q) (hhs <> [hh qq]) + +-- | left pad @q@ with @n@ values from @p@ +-- +-- >>> pl @(PadL 5 0 Id) [1..3] +-- Present [0,0,1,2,3] (PadL 5 pad=0 [0,0,1,2,3] | [1,2,3]) +-- Val [0,0,1,2,3] +-- +-- >>> pz @(PadL 5 999 Id) [12,13] +-- Val [999,999,999,12,13] +-- +-- >>> pz @(PadR 5 Fst '[12,13]) (999,'x') +-- Val [12,13,999,999,999] +-- +-- >>> pz @(PadR 2 Fst '[12,13,14]) (999,'x') +-- Val [12,13,14] +-- +-- >>> pl @(PadL 10 0 Id) [1..3] +-- Present [0,0,0,0,0,0,0,1,2,3] (PadL 10 pad=0 [0,0,0,0,0,0,0,1,2,3] | [1,2,3]) +-- Val [0,0,0,0,0,0,0,1,2,3] +-- +data PadL n p q deriving Show +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)) + +-- | right pad @q@ with @n@ values from @p@ +-- +-- >>> pl @(PadR 5 8 Id) [1..3] +-- Present [1,2,3,8,8] (PadR 5 pad=8 [1,2,3,8,8] | [1,2,3]) +-- Val [1,2,3,8,8] +-- +-- >>> pl @(PadR 5 0 Id) [1..5] +-- Present [1,2,3,4,5] (PadR 5 pad=0 [1,2,3,4,5] | [1,2,3,4,5]) +-- Val [1,2,3,4,5] +-- +-- >>> pl @(PadR 5 0 Id) [1..6] +-- Present [1,2,3,4,5,6] (PadR 5 pad=0 [1,2,3,4,5,6] | [1,2,3,4,5,6]) +-- Val [1,2,3,4,5,6] +-- +data PadR n p q deriving Show +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" +-- Val ["he","llo"," ","w","orld"] +-- +-- >>> pz @(SplitAts '[2] Id) "hello world" +-- Val ["he","llo world"] +-- +-- >>> pz @(SplitAts '[10,1,1,5] Id) "hello world" +-- Val ["hello worl","d","",""] +-- +-- >>> pl @(SplitAts '[1,3,4] Id) [1..12] +-- Present [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] (SplitAts [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] | ns=[1,3,4] | [1,2,3,4,5,6,7,8,9,10,11,12]) +-- Val [[1],[2,3,4],[5,6,7,8],[9,10,11,12]] +-- +-- >>> pl @(SplitAts '[3,1,1,1] Id >> Filter (Not Null) Id) [1..4] +-- Present [[1,2,3],[4]] ((>>) [[1,2,3],[4]] | {Fst [[1,2,3],[4]] | ([[1,2,3],[4]],[[],[]])}) +-- Val [[1,2,3],[4]] +-- +data SplitAts ns p deriving Show + +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 NoInline 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 -> [as | not (null as)]) ns p + in mkNode opts (Val zs) (show3' opts msg0 zs "ns=" ns <> showVerbose opts " | " p) [hh nn, hh pp] + +-- | similar to 'Data.List.splitAt' +-- +-- >>> pz @(SplitAt 4 Id) "hello world" +-- Val ("hell","o world") +-- +-- >>> pz @(SplitAt 20 Id) "hello world" +-- Val ("hello world","") +-- +-- >>> pz @(SplitAt 0 Id) "hello world" +-- Val ("","hello world") +-- +-- >>> pz @(SplitAt Snd Fst) ("hello world",4) +-- Val ("hell","o world") +-- +-- >>> pz @(SplitAt (Negate 2) Id) "hello world" +-- Val ("hello wor","ld") +-- +-- >>> pl @(Snd >> SplitAt 2 Id >> Len *** Len >> Fst > Snd) ('x',[1..5]) +-- False ((>>) False | {2 > 3}) +-- Val False +-- +data SplitAt n p deriving Show + +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 NoInline 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 (Val ret) (show3' 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 + +-- | take @n@ values from a list @p@: similar to 'Prelude.take' +-- +-- >>> pz @(Take 3 Id) "abcdef" +-- Val "abc" +-- +-- >>> pz @(Take 3 Id) "ab" +-- Val "ab" +-- +-- >>> pz @(Take 10 Id) "abcdef" +-- Val "abcdef" +-- +-- >>> pz @(Take 0 Id) "abcdef" +-- Val "" +-- +-- >>> pz @(Take 10 Id) "" +-- Val "" +-- +data Take n p deriving Show +type TakeT n p = SplitAt n p >> Fst + +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)) + +-- | drop @n@ values from a list @p@: similar to 'Prelude.drop' +data Drop n p deriving Show +type DropT n p = SplitAt n p >> Snd + +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)) + +-- | splits a list pointed to by @p@ into lists of size @n@ +-- +-- >>> pz @(ChunksOf 2) "abcdef" +-- Val ["ab","cd","ef"] +-- +-- >>> pz @(ChunksOf 2) "abcdefg" +-- Val ["ab","cd","ef","g"] +-- +-- >>> pz @(ChunksOf 2) "" +-- Val [] +-- +-- >>> pz @(ChunksOf 2) "a" +-- Val ["a"] +-- +-- >>> pz @(PadR (Len + RoundUp 5 Len) 999 Id >> ChunksOf 5) [1..17] +-- Val [[1,2,3,4,5],[6,7,8,9,10],[11,12,13,14,15],[16,17,999,999,999]] +-- +-- >>> pz @(PadR (Len + RoundUp 5 Len) 999 Id >> ChunksOf 5) [1..15] +-- Val [[1,2,3,4,5],[6,7,8,9,10],[11,12,13,14,15]] +-- +data ChunksOf n deriving Show +type ChunksOfT n = ChunksOf' n n Id + +instance P (ChunksOfT n) x => P (ChunksOf n) x where + type PP (ChunksOf n) x = PP (ChunksOfT n) x + eval _ = eval (Proxy @(ChunksOfT n)) + +-- | splits a list pointed to by @p@ into lists of size @n@ with a gap of @i@ +-- +-- >>> pz @(Unfoldr (If Null (MkNothing _) (MkJust '(Take 3 Id,Drop 2 Id))) Id) [1..10] +-- Val [[1,2,3],[3,4,5],[5,6,7],[7,8,9],[9,10]] +-- +-- >>> pz @(ChunksOf' 3 2 Id) [1..10] +-- Val [[1,2,3],[3,4,5],[5,6,7],[7,8,9],[9,10]] +-- +data ChunksOf' n i p deriving Show + +instance ( PP p a ~ [b] + , P n a + , P i a + , P p a + , Show b + , Integral (PP i a) + , Integral (PP n a) + ) => P (ChunksOf' n i p) a where + type PP (ChunksOf' n i p) a = [PP p a] + eval _ opts a = do + let msg0 = "ChunksOf" + lr <- runPQ NoInline msg0 (Proxy @n) (Proxy @i) opts a [] + case lr of + Left e -> pure e + Right (fromIntegral -> n,fromIntegral -> i,nn,ii) -> do + let hhs = [hh nn, hh ii] + msg1 = msg0 <> " " <> showL opts (n,i) + pp <- eval (Proxy @p) opts a + pure $ case getValueLR NoInline opts (msg1 <> " p failed") pp hhs of + Left e -> e + Right p -> + let hhs1 = hhs ++ [hh pp] + in if n <= 0 then mkNode opts (Fail (msg0 <> " n<=0")) "" hhs1 + else if i < 1 then mkNode opts (Fail (msg0 <> " i<1")) "" hhs1 + else let ret = unfoldr (\s -> if null s then Nothing else Just (take n s,drop i s)) p + in mkNode opts (Val ret) (show3' opts msg1 ret "n,i=" (n,i) <> showVerbose opts " | " p) hhs1 + +-- empty lists at the type level wont work here + +data KeepImpl (keep :: Bool) p q deriving Show + +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 NoInline 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 (Val ret) (show3' opts msg0 ret "p=" p <> showVerbose opts " | q=" q) [hh pp, hh qq] + +-- | filters a list @q@ keeping those elements in @p@ +-- +-- >>> pz @(Keep '[5] '[1,5,5,2,5,2]) () +-- Val [5,5,5] +-- +-- >>> pz @(Keep '[0,1,1,5] '[1,5,5,2,5,2]) () +-- Val [1,5,5,5] +-- +data Keep p q deriving Show +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)) + +-- | filters a list @q@ removing those elements in @p@ +-- +-- >>> pz @(Remove '[5] '[1,5,5,2,5,2]) () +-- Val [1,2,2] +-- +-- >>> pz @(Remove '[0,1,1,5] '[1,5,5,2,5,2]) () +-- Val [2,2] +-- +-- >>> pz @(Remove '[99] '[1,5,5,2,5,2]) () +-- Val [1,5,5,2,5,2] +-- +-- >>> pz @(Remove '[99,91] '[1,5,5,2,5,2]) () +-- Val [1,5,5,2,5,2] +-- +-- >>> pz @(Remove Id '[1,5,5,2,5,2]) [] +-- Val [1,5,5,2,5,2] +-- +-- >>> pz @(Remove '[] '[1,5,5,2,5,2]) 44 -- works if you make this a number! +-- Val [1,5,5,2,5,2] +-- +data Remove p q deriving Show +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)) + +-- | takes the head of a list-like container: similar to 'Data.List.head' +-- +-- >>> pz @Head "abcd" +-- Val 'a' +-- +-- >>> pl @Head [] +-- Error Head(empty) +-- Fail "Head(empty)" +-- +-- >>> pl @(Fst >> Head >> Le 6) ([], True) +-- Error Head(empty) +-- Fail "Head(empty)" +-- +-- >>> pl @Head [1,2,3] +-- Present 1 (Head 1 | [1,2,3]) +-- Val 1 +-- +data Head deriving Show + +instance ( Cons x x (ConsT x) (ConsT x) + , Show (ConsT x) + , Show x + ) => P Head x where + type PP Head x = ConsT x + eval _ opts x = + let msg0 = "Head" + in pure $ case x ^? _Cons of + Nothing -> mkNode opts (Fail (msg0 <> "(empty)")) "" [] + Just (a,_) -> mkNode opts (Val a) (show3 opts msg0 a x) [] + +-- | takes the tail of a list-like container: similar to 'Data.List.tail' +-- +-- >>> pz @Tail "abcd" +-- Val "bcd" +-- +-- >>> pl @Tail [1..5] +-- Present [2,3,4,5] (Tail [2,3,4,5] | [1,2,3,4,5]) +-- Val [2,3,4,5] +-- +-- >>> pl @Tail [] +-- Error Tail(empty) +-- Fail "Tail(empty)" +-- +data Tail deriving Show + +instance ( Cons x x (ConsT x) (ConsT x) + , Show x + ) => P Tail x where + type PP Tail x = x + eval _ opts x = do + let msg0 = "Tail" + pure $ case x ^? _Cons of + Nothing -> mkNode opts (Fail (msg0 <> "(empty)")) "" [] + Just (_,as) -> mkNode opts (Val as) (show3 opts msg0 as x) [] + + +-- | takes the last of a list-like container: similar to 'Data.List.last' +-- +-- >>> pz @Last "abcd" +-- Val 'd' +-- +-- >>> pz @Last [] +-- Fail "Last(empty)" +-- +-- >>> pl @Last [1,2,3] +-- Present 3 (Last 3 | [1,2,3]) +-- Val 3 +-- +data Last deriving Show + +instance ( Snoc x x (ConsT x) (ConsT x) + , Show (ConsT x) + , Show x + ) => P Last x where + type PP Last x = ConsT x + eval _ opts x = + let msg0 = "Last" + in pure $ case x ^? _Snoc of + Nothing -> mkNode opts (Fail (msg0 <> "(empty)")) "" [] + Just (_,a) -> mkNode opts (Val a) (show3 opts msg0 a x) [] + +-- | takes the init of a list-like container: similar to 'Data.List.init' +-- +-- >>> pz @Init "abcd" +-- Val "abc" +-- +-- >>> pz @Init (T.pack "abcd") +-- Val "abc" +-- +-- >>> pz @Init [] +-- Fail "Init(empty)" +-- +-- >>> pl @Init [1..5] +-- Present [1,2,3,4] (Init [1,2,3,4] | [1,2,3,4,5]) +-- Val [1,2,3,4] +-- +-- >>> pl @Init [] +-- Error Init(empty) +-- Fail "Init(empty)" +-- +data Init deriving Show + +instance ( Snoc s s (ConsT s) (ConsT s) + , x ~ s + , Show s + ) => P Init x where + type PP Init x = x + eval _ opts x = do + let msg0 = "Init" + pure $ case x ^? _Snoc of + Nothing -> mkNode opts (Fail (msg0 <> "(empty)")) "" [] + Just (as,_) -> mkNode opts (Val as) (show3 opts msg0 as x) [] + + +-- | 'unzip' equivalent +-- +-- >>> pz @Unzip (zip [1..5] "abcd") +-- Val ([1,2,3,4],"abcd") +-- +data Unzip deriving Show +type UnzipT = '(Map Fst, Map Snd) + +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])) +-- Val ([1,2,3,4],"abcd",[True,False,True,False]) +-- +data Unzip3 deriving Show +type Unzip3T = '(Map Fst, Map Snd, Map Thd) + +instance P Unzip3T x => P Unzip3 x where + type PP Unzip3 x = PP Unzip3T x + eval _ = eval (Proxy @Unzip3T) + +-- | sort a list (stable) +-- +-- >>> pz @(SortBy (Snd ==! Fst) Id) [(10,"ab"),(4,"x"),(20,"bbb")] +-- Val [(20,"bbb"),(10,"ab"),(4,"x")] +-- +-- >>> pz @(SortBy 'LT Id) [1,5,2,4,7,0] +-- Val [1,5,2,4,7,0] +-- +-- >>> pz @(SortBy 'GT Id) [1,5,2,4,7,0] +-- Val [0,7,4,2,5,1] +-- +-- >>> pz @(SortBy ((L11 ==! L21) <> (L12 ==! L22)) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- Val [(4,"a"),(4,"x"),(4,"y"),(10,"ab"),(20,"bbb")] +-- +-- >>> pz @(SortBy ((L11 ==! L21) <> (L22 ==! L12)) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- Val [(4,"y"),(4,"x"),(4,"a"),(10,"ab"),(20,"bbb")] +-- +-- >>> pl @(SortBy (Swap >> OrdA' Fst Fst) Snd) ((),[('z',1),('a',10),('m',22)]) +-- Present [('z',1),('m',22),('a',10)] (SortBy [('z',1),('m',22),('a',10)]) +-- Val [('z',1),('m',22),('a',10)] +-- +-- >>> pl @(SortBy (OrdA' Reverse Reverse) Id) ["az","by","cx","aa"] +-- Present ["aa","cx","by","az"] (SortBy ["aa","cx","by","az"]) +-- Val ["aa","cx","by","az"] +-- +-- >>> pl @(SortBy (If (Fst==5 && Snd==3) (FailT _ (PrintT "pivot=%d value=%d" Id)) 'GT) Snd) ((), [5,7,3,1,6,2,1,3]) +-- Error pivot=5 value=3(2) (Partition(i=1, a=(5,3)) excnt=2 | SortBy) +-- Fail "pivot=5 value=3(2)" +-- +-- >>> pl @(SortBy (If (Fst==50 && Snd==3) (FailT _ (PrintT "pivot=%d value=%d" Id)) OrdA) Snd) ((), [5,7,3,1,6,2,1,3]) +-- Present [1,1,2,3,3,5,6,7] (SortBy [1,1,2,3,3,5,6,7]) +-- Val [1,1,2,3,3,5,6,7] +-- +data SortBy p q deriving Show + +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 NoInline 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 (Val mempty) (msg0 <> " empty") [hh qq] + [w] -> pure $ mkNode opts (Val [w]) (msg0 <> " one element " <> showL opts w) [hh qq] + w:ys@(_:_) -> do + pp <- evalHide @(SortByHelperT p) opts (map (w,) ys) + case getValueLR NoInline opts msg0 pp [hh qq] of + Left e -> pure e + Right (ll', rr') -> do + lhs <- ff (map snd ll') + case getValueLR NoInline opts msg0 lhs [hh qq, hh pp] of + Left _ -> pure lhs -- dont rewrap or rewrite + Right ll -> do + rhs <- ff (map snd rr') + case getValueLR NoInline opts msg0 rhs [hh qq, hh pp, hh lhs] of + Left _ -> pure rhs + Right rr -> + pure $ mkNode opts (Val (ll ++ w : rr)) + (msg0 <> " lhs=" <> showL opts ll <> " pivot " <> showL opts w <> " rhs=" <> showL opts rr) + (hh pp : [hh lhs | length ll > 1] ++ [hh rhs | length rr > 1]) + ret <- ff as + pure $ case getValueLR NoInline opts msg0 ret [hh qq] of + Left _e -> ret -- dont rewrap else will double up messages: already handled + Right xs -> mkNodeCopy opts ret (msg0 <> " " <> showL opts xs) [hh qq, hh ret] + +-- | similar to 'Data.List.sortOn' +-- +-- >>> pz @(SortOn Fst Id) [(10,"abc"), (3,"def"), (4,"gg"), (10,"xyz"), (1,"z")] +-- Val [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] +-- +-- >>> pl @(SortOn Id Id) [10,4,2,12,14] +-- Present [2,4,10,12,14] (SortBy [2,4,10,12,14]) +-- Val [2,4,10,12,14] +-- +-- >>> pl @(SortOn (Negate Id) Id) [10,4,2,12,14] +-- Present [14,12,10,4,2] (SortBy [14,12,10,4,2]) +-- Val [14,12,10,4,2] +-- +-- >>> pl @(SortOn Fst Id) (zip "cabdaz" [10,4,2,12,14,1]) +-- Present [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)] (SortBy [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)]) +-- Val [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)] +-- +-- >>> pl @(SortOn (FailS "asdf") Id) [10,4,2,12,14] +-- Error asdf(4) (Partition(i=0, a=(10,4)) excnt=4 | SortBy) +-- Fail "asdf(4)" +-- +-- >>> pl @(SortOn Snd Snd) ((),[('z',14),('a',10),('m',22),('a',1)]) +-- Present [('a',1),('a',10),('z',14),('m',22)] (SortBy [('a',1),('a',10),('z',14),('m',22)]) +-- Val [('a',1),('a',10),('z',14),('m',22)] +-- +-- >>> pl @(SortOn Fst Snd) ((),[('z',1),('a',10),('m',22)]) +-- Present [('a',10),('m',22),('z',1)] (SortBy [('a',10),('m',22),('z',1)]) +-- Val [('a',10),('m',22),('z',1)] +-- +-- >>> pl @(SortOn Fst Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] +-- Present [('a',10),('a',9),('m',22),('m',10),('z',1)] (SortBy [('a',10),('a',9),('m',22),('m',10),('z',1)]) +-- Val [('a',10),('a',9),('m',22),('m',10),('z',1)] +-- +-- >>> pl @(SortOn Id Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] +-- Present [('a',9),('a',10),('m',10),('m',22),('z',1)] (SortBy [('a',9),('a',10),('m',10),('m',22),('z',1)]) +-- Val [('a',9),('a',10),('m',10),('m',22),('z',1)] +-- +data SortOn p q deriving Show +type SortOnT p q = SortBy (OrdA' p 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)) + +-- | like SortOn but descending order +-- +-- >>> pl @(SortOnDesc Id Id) [10,4,2,12,14] +-- Present [14,12,10,4,2] (SortBy [14,12,10,4,2]) +-- Val [14,12,10,4,2] +-- +-- >>> pl @(SortOnDesc Fst Snd) ((),[('z',1),('a',10),('m',22)]) +-- Present [('z',1),('m',22),('a',10)] (SortBy [('z',1),('m',22),('a',10)]) +-- Val [('z',1),('m',22),('a',10)] +-- +data SortOnDesc p q deriving Show +type SortOnDescT p q = SortBy (Swap >> OrdA' p 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)) + +-- | simple sort: similar to 'Prelude.sort' +data Sort deriving Show +type SortT = SortOn Id Id + +instance P SortT x => P Sort x where + type PP Sort x = PP SortT x + eval _ = eval (Proxy @SortT) + +-- | similar to 'Data.List.reverse' +-- +-- >>> pz @Reverse [1,2,4] +-- Val [4,2,1] +-- +-- >>> pz @Reverse "AbcDeF" +-- Val "FeDcbA" +-- +data Reverse deriving Show + +instance ( x ~ [a] + , Show a + ) => P Reverse x where + type PP Reverse x = x + eval _ opts as = + let msg0 = "Reverse" + d = reverse as + in pure $ mkNode opts (Val d) (show3 opts msg0 d as) [] + +-- | reverses using 'reversing' +-- +-- >>> pz @ReverseL (T.pack "AbcDeF") +-- Val "FeDcbA" +-- +-- >>> pz @ReverseL "AbcDeF" +-- Val "FeDcbA" +-- +-- >>> pl @ReverseL ("asfd" :: T.Text) +-- Present "dfsa" (ReverseL "dfsa" | "asfd") +-- Val "dfsa" +-- +data ReverseL deriving Show + +instance ( Reversing t + , Show t + ) => P ReverseL t where + type PP ReverseL t = t + eval _ opts as = + let msg0 = "ReverseL" + d = as ^. reversed + in pure $ mkNode opts (Val d) (show3 opts msg0 d as) [] + +-- | creates a singleton from a value +-- +-- >>> pz @(Singleton (C "aBc")) () +-- Val "a" +-- +-- >>> pz @(Singleton Id) False +-- Val [False] +-- +-- >>> pz @(Singleton Snd) (False,"hello") +-- Val ["hello"] +-- +data Singleton p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> mkNode opts (Val [p]) msg0 [hh pp] + +data EmptyList' t deriving Show + +instance P (EmptyList' t) x where + type PP (EmptyList' t) x = [PP t x] + eval _ opts _ = + pure $ mkNode opts (Val []) "EmptyList" [] + +-- | creates an empty list for the given type +-- +-- >>> pz @(Id :+ EmptyList _) 99 +-- Val [99] +-- +data EmptyList (t :: Type) deriving Show +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)) + + +-- | like 'zipWith' +-- +-- >>> pz @(ZipWith Id (1...5) (C "a" ... C "e")) () +-- Val [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e')] +-- +-- >>> pz @(ZipWith (ShowP Fst <> ShowP Snd) (1...5) (C "a" ... C "e")) () +-- Val ["1'a'","2'b'","3'c'","4'd'","5'e'"] +-- +-- >>> pz @(ZipWith (MkThese Fst Snd) (1...6) (C "a" ... C "f")) () +-- Val [These 1 'a',These 2 'b',These 3 'c',These 4 'd',These 5 'e',These 6 'f'] +-- +-- >>> pz @(ZipWith (MkThese Fst Snd) '[] (C "a" ... C "f")) () +-- Fail "ZipWith(0,6) length mismatch" +-- +-- >>> pz @(ZipWith (MkThese Fst Snd) (1...3) (C "a" ... C "f")) () +-- Fail "ZipWith(3,6) length mismatch" +-- +data ZipWith p q r deriving Show + +instance ( PP q a ~ [x] + , PP r a ~ [y] + , P q a + , P r a + , P p (x,y) + , Show x + , Show y + , Show (PP p (x,y)) + ) => P (ZipWith p q r) a where + type PP (ZipWith p q r) a = [PP p (ExtractAFromList (PP q a), ExtractAFromList (PP r a))] + eval _ opts a = do + let msg0 = "ZipWith" + lr <- runPQ NoInline msg0 (Proxy @q) (Proxy @r) opts a [] + case lr of + Left e -> pure e + Right (q,r,qq,rr) -> + let hhs = [hh qq, hh rr] + in case chkSize2 opts msg0 q r hhs of + Left e -> pure e + Right _ -> do + let lls = (length q, length r) + if uncurry (==) lls then do + ts <- zipWithM (\i (x,y) -> ((i, (x,y)),) <$> evalHide @p opts (x,y)) [0::Int ..] (zip q r) + 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 = map fst kvs + in mkNode opts (Val ret) (show3' opts msg0 ret "s=" q ) (hh qq : map (hh . prefixNumberToTT) itts) + + else do + let msg1 = msg0 ++ show lls + pure $ mkNode opts (Fail (msg1 <> " length mismatch")) (showVerbose opts "q=" q <> showVerbose opts " | r=" r) hhs + +-- | Zip two lists to their maximum length using optional padding +-- +-- >>> pz @(ZipPad (C "Z") 99 Fst Snd) ("abc", [1..5]) +-- Val [('a',1),('b',2),('c',3),('Z',4),('Z',5)] +-- +-- >>> pz @(ZipPad (C "Z") 99 Fst Snd) ("abcdefg", [1..5]) +-- Val [('a',1),('b',2),('c',3),('d',4),('e',5),('f',99),('g',99)] +-- +-- >>> pz @(ZipPad (C "Z") 99 Fst Snd) ("abcde", [1..5]) +-- Val [('a',1),('b',2),('c',3),('d',4),('e',5)] +-- +-- >>> pz @(ZipPad (C "Z") 99 Fst Snd) ("", [1..5]) +-- Val [('Z',1),('Z',2),('Z',3),('Z',4),('Z',5)] +-- +-- >>> pz @(ZipPad (C "Z") 99 Fst Snd) ("abcde", []) +-- Val [('a',99),('b',99),('c',99),('d',99),('e',99)] +-- +data ZipPad l r p q deriving Show + +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 NoInline 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 chkSize2 opts msg0 p q hhs of + Left e -> pure e + Right _ -> + case compare (length p) (length q) of + LT -> do + ll <- eval (Proxy @l) opts a + pure $ case getValueLR NoInline opts (msg0 <> " l failed") ll hhs of + Left e -> e + Right l -> + let d = zip (p ++ repeat l) q + in mkNode opts (Val d) (show3' 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 NoInline opts (msg0 <> " r failed") rr hhs of + Left e -> e + Right r -> + let d =zip p (q ++ repeat r) + in mkNode opts (Val d) (show3' opts (msg0 <> " Right pad") d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh rr]) + EQ -> + let d = zip p q + in pure $ mkNode opts (Val d) (show3' opts (msg0 <> " No pad") d "p=" p <> showVerbose opts " | q=" q) hhs + + +-- | zip two lists optionally padding the left hand side +-- +-- >>> 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") +-- Val [(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") +-- Val [(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") +-- Val [(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") +-- Fail "ZipL(3,2) rhs would be truncated" +-- +-- >>> pl @(ZipL 99 Id "abcdefg") [1..4] +-- Present [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] (ZipL [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] | p=[1,2,3,4] | q="abcdefg") +-- Val [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(99,'e'),(99,'f'),(99,'g')] +-- +-- >>> pl @(ZipL (99 % 4) '[1 % 1 , 2 % 1 , 3 % 1] Id) "abcde" +-- Present [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] (ZipL [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] | p=[1 % 1,2 % 1,3 % 1] | q="abcde") +-- Val [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(99 % 4,'d'),(99 % 4,'e')] +-- +-- >>> pl @(ZipL "X" (EmptyT _) Id) "abcd" +-- Present [("X",'a'),("X",'b'),("X",'c'),("X",'d')] (ZipL [("X",'a'),("X",'b'),("X",'c'),("X",'d')] | p=[] | q="abcd") +-- Val [("X",'a'),("X",'b'),("X",'c'),("X",'d')] +-- + +data ZipL l p q deriving Show +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 NoInline 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 chkSize2 opts msg0 p 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 (Fail (msg1 ++ " rhs would be truncated")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + _ -> do + ll <- eval (Proxy @l) opts a + pure $ case getValueLR NoInline opts (msg0 <> " l failed") ll hhs of + Left e -> e + Right l -> + let d = zip (p ++ repeat l) q + in mkNode opts (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) (hhs ++ [hh ll]) + +-- | zip two lists optionally padding the right hand side +-- +-- >>> pl @(ZipR (C "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") +-- Val [(1,'a'),(2,'b'),(3,'c')] +-- +-- >>> pl @(ZipR (C "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") +-- Val [(1,'a'),(2,'b'),(3,'Z')] +-- +-- >>> pl @(ZipR (C "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") +-- Val [(1,'a'),(2,'Z'),(3,'Z')] +-- +-- >>> pl @(ZipR (C "Z") '[1,2] "abc") () +-- Error ZipR(2,3) rhs would be truncated (p=[1,2] | q="abc") +-- Fail "ZipR(2,3) rhs would be truncated" +-- +-- >>> pl @(ZipR (C "Y") (EmptyT _) Id) "abcd" +-- Error ZipR(0,4) rhs would be truncated (p=[] | q="abcd") +-- Fail "ZipR(0,4) rhs would be truncated" +-- +data ZipR r p q deriving Show +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 NoInline 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 chkSize2 opts msg0 p 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 (Fail (msg1 ++ " rhs would be truncated")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + _ -> do + rr <- eval (Proxy @r) opts a + pure $ case getValueLR NoInline opts (msg0 <> " l failed") rr hhs of + Left e -> e + Right r -> + let d = zip p (q ++ repeat r) + in mkNode opts (Val d) (show3' 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") +-- Val [(1,'a'),(2,'b'),(3,'c')] +-- +-- >>> pl @(Zip '[1,2,3] "ab") () +-- Error Zip(3,2) length mismatch (p=[1,2,3] | q="ab") +-- Fail "Zip(3,2) length mismatch" +-- +-- >>> pl @(Zip '[1,2] "abc") () +-- Error Zip(2,3) length mismatch (p=[1,2] | q="abc") +-- Fail "Zip(2,3) length mismatch" +-- +-- >>> pl @(Zip "abc" Id) [1..7] +-- Error Zip(3,7) length mismatch (p="abc" | q=[1,2,3,4,5,6,7]) +-- Fail "Zip(3,7) length mismatch" +-- +data Zip p q deriving Show +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 NoInline 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 chkSize2 opts msg0 p 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 (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs + _ -> let msg1 = msg0 ++ show lls + in mkNode opts (Fail (msg1 <> " length mismatch")) (showVerbose opts "p=" p <> showVerbose opts " | q=" q) hhs + +-- | similar to 'Data.List.empty' +-- +-- >>> pz @(EmptyT Maybe) () +-- Val Nothing +-- +-- >>> pz @(EmptyT []) () +-- Val [] +-- +-- >>> pz @(C "x" >> EmptyT []) (13,True) +-- Val "" +-- +-- >>> pz @(Fst >> EmptyT (Either String)) (13,True) +-- Val (Left "") +-- +data EmptyT (t :: Type -> Type) deriving Show + +instance Alternative t => P (EmptyT t) x where + type PP (EmptyT t) x = t x + eval _ opts _ = + let msg0 = "EmptyT" + b = empty @t + in pure $ mkNode opts (Val b) msg0 [] + + +-- | similar to 'Data.List.sum' +-- +-- >>> pz @Sum [10,4,5,12,3,4] +-- Val 38 +-- +-- >>> pz @Sum [] +-- Val 0 +-- +-- >>> pz @(1 ... 10 >> Sum) () +-- Val 55 +-- +data Sum deriving Show + +instance ( x ~ [a] + , Num a + , Show a + ) => P Sum x where + type PP Sum x = ExtractAFromTA x + eval _ opts as = + let msg0 = "Sum" + v = sum as + in pure $ mkNode opts (Val v) (show3 opts msg0 v as) [] + +-- | similar to 'Data.List.product' +-- +-- >>> pz @Product [10,4,5,12,3,4] +-- Val 28800 +-- +-- >>> pz @Product [] +-- Val 1 +-- +data Product deriving Show + +instance ( x ~ [a] + , Num a + , Show a + ) => P Product x where + type PP Product x = ExtractAFromTA x + eval _ opts as = + let msg0 = "Product" + v = product as + in pure $ mkNode opts (Val v) (show3 opts msg0 v as) [] + +-- | similar to 'Data.List.minimum' +-- +-- >>> pz @Min [10,4,5,12,3,4] +-- Val 3 +-- +-- >>> pz @Min [] +-- Fail "empty list" +-- +data Min deriving Show + +instance ( x ~ [a] + , Ord a + , Show a + ) => P Min x where + type PP Min x = ExtractAFromTA x + eval _ opts as' = do + let msg0 = "Min" + pure $ case as' of + [] -> mkNode opts (Fail "empty list") msg0 [] + as@(_:_) -> + let v = minimum as + in mkNode opts (Val v) (show3 opts msg0 v as) [] + +-- | similar to 'Data.List.maximum' +-- +-- >>> pz @Max [10,4,5,12,3,4] +-- Val 12 +-- +-- >>> pz @Max [] +-- Fail "empty list" +-- +data Max deriving Show + +instance ( x ~ [a] + , Ord a + , Show a + ) => P Max x where + type PP Max x = ExtractAFromTA x + eval _ opts as' = do + let msg0 = "Max" + pure $ case as' of + [] -> mkNode opts (Fail "empty list") msg0 [] + as@(_:_) -> + let v = maximum as + in mkNode opts (Val v) (show3 opts msg0 v as) [] + +data IsFixImpl (cmp :: Ordering) p q deriving Show + +instance ( P p x + , P q x + , Show a + , Eq a + , PP p x ~ [a] + , PP q x ~ [a] + , GetOrdering cmp + ) => P (IsFixImpl cmp p q) x where + type PP (IsFixImpl cmp p q) x = Bool + eval _ opts x = do + let cmp = getOrdering @cmp + (ff,msg0) = case cmp of + LT -> (isPrefixOf, "IsPrefix") + EQ -> (isInfixOf, "IsInfix") + GT -> (isSuffixOf, "IsSuffix") + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " | " <> showL opts p + in mkNodeB opts (ff p q) (msg1 <> " " <> showL opts q) [hh pp, hh qq] + +-- | similar to 'Data.List.isPrefixOf' +-- +-- >>> pl @(IsPrefix '[2,3] Id) [2,3,4] +-- True (IsPrefix | [2,3] [2,3,4]) +-- Val True +-- +-- >>> pl @(IsPrefix '[2,3] Id) [1,2,3] +-- False (IsPrefix | [2,3] [1,2,3]) +-- Val False +-- +data IsPrefix p q deriving Show +type IsPrefixT p q = IsFixImpl 'LT 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)) + +-- | similar to 'Data.List.isInfixOf' +-- +-- >>> pl @(IsInfix '[2,3] Id) [1,2,3] +-- True (IsInfix | [2,3] [1,2,3]) +-- Val True +-- +-- >>> pl @(IsInfix '[2,3] Id) [1,2,1,3] +-- False (IsInfix | [2,3] [1,2,1,3]) +-- Val False +-- +data IsInfix p q deriving Show +type IsInfixT p q = IsFixImpl 'EQ 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)) + +-- | similar to 'Data.List.isSuffixOf' +-- +-- >>> pl @(IsSuffix '[2,3] Id) [1,2,3] +-- True (IsSuffix | [2,3] [1,2,3]) +-- Val True +-- +-- >>> pl @(IsSuffix '[2,3] Id) [2,3,4] +-- False (IsSuffix | [2,3] [2,3,4]) +-- Val False +-- +data IsSuffix p q deriving Show +type IsSuffixT p q = IsFixImpl 'GT 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)) + +-- | similar to 'Data.List.nub' +-- +-- >>> pz @Nub "abcdbc" +-- Val "abcd" +-- +-- >>> pz @Nub [] +-- Val [] +-- +-- >>> pz @Nub [1,4,1,1,1,1,1] +-- Val [1,4] +-- +data Nub deriving Show + +instance ( x ~ [a] + , Show a + , Ord a + ) => P Nub x where + type PP Nub x = x + eval _ opts x = + let msg0 = "Nub" + ret = nubOrd x + in pure $ mkNode opts (Val ret) (show3 opts msg0 ret x) [] + +-- | zip cartesian product for lists: see 'Predicate.Data.Extra.LiftA2' for Applicative version +-- +-- >>> pz @(ZipCartesian (EnumFromTo Fst Snd) ('LT ... 'GT) ) (10,11) +-- Val [(10,LT),(10,EQ),(10,GT),(11,LT),(11,EQ),(11,GT)] +-- +-- >>> pz @(ZipCartesian '[ '() ] (1 ... 5)) True +-- Val [((),1),((),2),((),3),((),4),((),5)] +-- +data ZipCartesian p q deriving Show + +instance ( PP p x ~ [a] + , PP q x ~ [b] + , P p x + , P q x + , Show a + , Show b + ) => P (ZipCartesian p q) x where + type PP (ZipCartesian p q) x = [(ExtractAFromTA (PP p x), ExtractAFromTA (PP q x))] + eval _ opts x = do + let msg0 = "ZipCartesian" + lr <- runPQ NoInline 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 chkSize2 opts msg0 p q hhs of + Left e -> e + Right _ -> + let d = liftA2 (,) p q + in mkNode opts (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs
src/Predicate/Data/Maybe.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,11 +12,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted 'Maybe' functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted 'Maybe' functions module Predicate.Data.Maybe ( -- ** boolean predicates @@ -42,55 +34,58 @@ , CatMaybes , MaybeIn , MaybeBool + , EmptyBool ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.Foldable (ConcatMap) import Predicate.Data.Monoid (MEmptyP) -import Data.Proxy +import Data.Proxy (Proxy(..)) import Data.Kind (Type) +import Data.Maybe (isJust, isNothing) +import Control.Applicative (Alternative(empty)) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Map.Strict as M -- >>> import Predicate.Prelude -- >>> import qualified Data.Semigroup as SG -- | similar to 'Data.Maybe.fromJust' -- --- >>> pz @(Just' >> Succ Id) (Just 20) --- PresentT 21 +-- >>> pz @(Just' >> Succ) (Just 20) +-- Val 21 -- --- >>> pz @(Just' >> Succ Id) Nothing --- FailT "Just' found Nothing" +-- >>> pz @(Just' >> Succ) Nothing +-- Fail "Just' found Nothing" -- -data Just' -instance (Show a - ) => P Just' (Maybe a) where +data Just' deriving Show +instance Show a => P Just' (Maybe a) where type PP Just' (Maybe a) = a eval _ opts lr = let msg0 = "Just'" in pure $ case lr of - Nothing -> mkNode opts (FailT (msg0 <> " found Nothing")) "" [] - Just a -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + Nothing -> mkNode opts (Fail (msg0 <> " found Nothing")) "" [] + Just a -> mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -- | constructs a Nothing for a given type -data MkNothing' t -- works always! MaybeBool is a good alternative and then dont need the extra 't' +data MkNothing' t deriving Show +-- 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 [] + in pure $ mkNode opts (Val Nothing) msg0 [] -- | constructs a Nothing for a given type -data MkNothing (t :: Type) +data MkNothing (t :: Type) deriving Show type MkNothingT (t :: Type) = MkNothing' (Hole t) instance P (MkNothing t) x where @@ -100,9 +95,9 @@ -- | 'GHC.Maybe.Just' constructor -- -- >>> pz @(MkJust Id) 44 --- PresentT (Just 44) +-- Val (Just 44) -- -data MkJust p +data MkJust p deriving Show instance ( PP p x ~ a , P p x , Show a @@ -111,147 +106,147 @@ eval _ opts x = do let msg0 = "MkJust" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " Just " <> showL opts p) [hh pp] -- | similar to 'Data.Maybe.maybe' -- --- provides a Proxy to the result of \'q\' but does not provide the surrounding context +-- 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 "foundnothing" (ShowP Pred)) (Just 20) +-- Val "19" -- --- >>> pz @(MaybeIn "found nothing" (ShowP (Pred Id))) Nothing --- PresentT "found nothing" +-- >>> pz @(MaybeIn "found nothing" (ShowP Pred)) Nothing +-- Val "found nothing" -- -- >>> pl @(MaybeIn 'True Id) (Nothing @Bool) -- need @() else breaks -- True (MaybeIn(Nothing) True | Proxy) --- TrueT +-- Val True -- --- >>> pl @(MaybeIn (Failt _ "failed4") Id) (Just 10) +-- >>> pl @(MaybeIn (FailT _ "failed4") Id) (Just 10) -- Present 10 (MaybeIn(Just) 10 | 10) --- PresentT 10 +-- Val 10 -- -- >>> pl @(MaybeIn 'False Id) (Nothing @Bool) -- breaks otherwise -- False (MaybeIn(Nothing) False | Proxy) --- FalseT +-- Val False -- -- >>> pl @(MaybeIn MEmptyP Id) (Just [1,2,3]) -- Present [1,2,3] (MaybeIn(Just) [1,2,3] | [1,2,3]) --- PresentT [1,2,3] +-- Val [1,2,3] -- -- >>> pl @(MaybeIn MEmptyP Id) (Nothing @[Int]) -- Present [] (MaybeIn(Nothing) [] | Proxy) --- PresentT [] +-- Val [] -- --- >>> pl @(MaybeIn (Failp "err") (Succ Id)) (Just 116) +-- >>> pl @(MaybeIn (FailP "err") Succ) (Just 116) -- Present 117 (MaybeIn(Just) 117 | 116) --- PresentT 117 +-- Val 117 -- --- >>> pl @(MaybeIn 99 (Succ Id)) (Nothing @Int) +-- >>> pl @(MaybeIn 99 Succ) (Nothing @Int) -- Present 99 (MaybeIn(Nothing) 99 | Proxy) --- PresentT 99 +-- Val 99 -- --- >>> pl @(MaybeIn (Failp "someval") (Succ Id)) (Nothing @()) +-- >>> pl @(MaybeIn (FailP "someval") Succ) (Nothing @()) -- Error someval (MaybeIn(Nothing)) --- FailT "someval" +-- Fail "someval" -- -- >>> pl @(MaybeIn 'True 'False) (Nothing @()) -- True (MaybeIn(Nothing) True | Proxy) --- TrueT +-- Val True -- -- >>> pl @(MaybeIn 'True 'False) (Just "aa") -- False (MaybeIn(Just) False | "aa") --- FalseT +-- Val False -- --- >>> pl @(MaybeIn MEmptyP (Fst Id ==! Snd Id)) (Just ('x','z')) +-- >>> pl @(MaybeIn MEmptyP (Fst ==! Snd)) (Just ('x','z')) -- Present LT (MaybeIn(Just) LT | ('x','z')) --- PresentT LT +-- Val LT -- --- >>> pl @(MaybeIn MEmptyP (Fst Id ==! Snd Id)) (Nothing @(Char,Char)) +-- >>> pl @(MaybeIn MEmptyP (Fst ==! Snd)) (Nothing @(Char,Char)) -- Present EQ (MaybeIn(Nothing) EQ | Proxy) --- PresentT EQ +-- Val EQ -- --- >>> pl @(MaybeIn (Failp "failed20") 'False) (Nothing @Int) +-- >>> pl @(MaybeIn (FailP "failed20") 'False) (Nothing @Int) -- Error failed20 (MaybeIn(Nothing)) --- FailT "failed20" +-- Fail "failed20" -- -- >>> pl @(MaybeIn ('False >> FailS "failed21") 'False) (Nothing @Double) --- Error failed21 (MaybeIn(Nothing)) --- FailT "failed21" +-- Error failed21 (False | MaybeIn(Nothing)) +-- Fail "failed21" -- --- >>> pl @(MaybeIn (Failp "err") Id) (Nothing @Int) +-- >>> pl @(MaybeIn (FailP "err") Id) (Nothing @Int) -- Error err (MaybeIn(Nothing)) --- FailT "err" +-- Fail "err" -- --- >>> pl @(MaybeIn (Failp "err") Id) (Nothing @()) +-- >>> pl @(MaybeIn (FailP "err") Id) (Nothing @()) -- Error err (MaybeIn(Nothing)) --- FailT "err" +-- Fail "err" -- -- >>> pl @(MaybeIn MEmptyP Id) (Just (M.fromList [(1,'a')])) -- Present fromList [(1,'a')] (MaybeIn(Just) fromList [(1,'a')] | fromList [(1,'a')]) --- PresentT (fromList [(1,'a')]) +-- Val (fromList [(1,'a')]) -- -- >>> pl @(MaybeIn MEmptyP Id) (Nothing @(M.Map () ())) -- Present fromList [] (MaybeIn(Nothing) fromList [] | Proxy) --- PresentT (fromList []) +-- Val (fromList []) -- --- >>> pl @(MaybeIn MEmptyP (Ones Id)) (Just @String "abc") +-- >>> pl @(MaybeIn MEmptyP Ones) (Just @String "abc") -- Present ["a","b","c"] (MaybeIn(Just) ["a","b","c"] | "abc") --- PresentT ["a","b","c"] +-- Val ["a","b","c"] -- -- >>> pl @(MaybeIn 99 Id) (Just 12) -- Present 12 (MaybeIn(Just) 12 | 12) --- PresentT 12 +-- Val 12 -- -- >>> pl @(MaybeIn 99 Id) Nothing -- Present 99 (MaybeIn(Nothing) 99 | Proxy) --- PresentT 99 +-- Val 99 -- -- >>> pl @(MaybeIn (99 -% 1) Id) Nothing -- Present (-99) % 1 (MaybeIn(Nothing) (-99) % 1 | Proxy) --- PresentT ((-99) % 1) +-- Val ((-99) % 1) -- -- >>> pl @(MaybeIn 123 Id) (Nothing @Int) -- Present 123 (MaybeIn(Nothing) 123 | Proxy) --- PresentT 123 +-- Val 123 -- -- >>> pl @(MaybeIn 123 Id) (Just 9) -- Present 9 (MaybeIn(Just) 9 | 9) --- PresentT 9 +-- Val 9 -- -- >>> pl @(Uncons >> MaybeIn '(1,MEmptyT _) Id) [] -- Present (1,[]) ((>>) (1,[]) | {MaybeIn(Nothing) (1,[]) | Proxy}) --- PresentT (1,[]) +-- Val (1,[]) -- --- >>> pl @(MaybeIn MEmptyP (Ones (ShowP Id))) (Just 123) +-- >>> pl @(MaybeIn MEmptyP (ShowP Id >> Ones)) (Just 123) -- Present ["1","2","3"] (MaybeIn(Just) ["1","2","3"] | 123) --- PresentT ["1","2","3"] +-- Val ["1","2","3"] -- --- >>> pl @(MaybeIn MEmptyP (Ones (ShowP Id))) (Nothing @String) +-- >>> pl @(MaybeIn MEmptyP (ShowP Id >> Ones)) (Nothing @String) -- Present [] (MaybeIn(Nothing) [] | Proxy) --- PresentT [] +-- Val [] -- --- >>> pl @(MaybeIn MEmptyP (Ones Id)) (Just @String "ab") +-- >>> pl @(MaybeIn MEmptyP Ones) (Just @String "ab") -- Present ["a","b"] (MaybeIn(Just) ["a","b"] | "ab") --- PresentT ["a","b"] +-- Val ["a","b"] -- --- >>> pl @(MaybeIn MEmptyP (Ones Id)) (Nothing @String) +-- >>> pl @(MaybeIn MEmptyP Ones) (Nothing @String) -- Present [] (MaybeIn(Nothing) [] | Proxy) --- PresentT [] +-- Val [] -- -data MaybeIn p q +data MaybeIn p q deriving Show -- 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 +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" @@ -259,81 +254,65 @@ Nothing -> do let msg1 = msg0 <> "(Nothing)" pp <- eval (Proxy @p) opts (Proxy @(PP q a)) - pure $ case getValueLR opts msg1 pp [] of + pure $ case getValueLR NoInline opts msg1 pp [] of Left e -> e - Right b -> mkNode opts (_tBool pp) (msg1 <> " " <> showL opts b <> " | Proxy") [hh pp] + Right b -> mkNodeCopy opts 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 + pure $ case getValueLR NoInline opts msg1 qq [] of Left e -> e - Right b -> mkNode opts (_tBool qq) (show01 opts msg1 b a) [hh qq] + Right b -> mkNodeCopy opts qq (show3 opts msg1 b a) [hh qq] -- | similar to 'Data.Maybe.isJust' -- --- >>> pz @(IsJust Id) Nothing --- FalseT +-- >>> pz @IsJust Nothing +-- Val False -- --- >>> pz @(IsJust Id) (Just 'a') --- TrueT +-- >>> pz @IsJust (Just 'a') +-- Val True -- -data IsJust p +data IsJust deriving Show -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 +instance x ~ Maybe a + => P IsJust x where + type PP IsJust x = Bool + eval _ opts x = pure $ mkNodeB opts (isJust x) "IsJust" [] -- | similar to 'Data.Maybe.isNothing' -- --- >>> pz @(IsNothing Id) (Just 123) --- FalseT +-- >>> pz @IsNothing (Just 123) +-- Val False -- --- >>> pz @(IsNothing Id) Nothing --- TrueT +-- >>> pz @IsNothing Nothing +-- Val True -- --- >>> pl @(Not (IsNothing Id) &&& ('Just Id >> Id + 12)) (Just 1) --- Present (True,13) (W '(True,13)) --- PresentT (True,13) +-- >>> pl @(Not IsNothing &&& ('Just Id >> Id + 12)) (Just 1) +-- Present (True,13) ('(True,13)) +-- Val (True,13) -- --- >>> pl @(Not (IsNothing Id) &&& ('Just Id >> Id + 12)) Nothing --- Error 'Just(empty) (W '(,)) --- FailT "'Just(empty)" +-- >>> pl @(Not IsNothing &&& ('Just Id >> Id + 12)) Nothing +-- Error 'Just(empty) ('(,)) +-- Fail "'Just(empty)" -- -data IsNothing p +data IsNothing deriving Show -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 +instance x ~ Maybe a + => P IsNothing x where + type PP IsNothing x = Bool + eval _ opts x = pure $ mkNodeB opts (isNothing x) "IsNothing" [] -- | like 'Data.Maybe.mapMaybe' -- -- >>> pl @(MapMaybe (MaybeBool (Le 3) Id) Id) [1..5] --- Present [1,2,3] (Concat [1,2,3] | [[1],[2],[3],[],[]]) --- PresentT [1,2,3] +-- Present [1,2,3] ((>>) [1,2,3] | {Concat [1,2,3] | [[1],[2],[3],[],[]]}) +-- Val [1,2,3] -- -- >>> pl @(MapMaybe (MaybeBool (Gt 3) Id) Id) [1..5] --- Present [4,5] (Concat [4,5] | [[],[],[],[4],[5]]) --- PresentT [4,5] +-- Present [4,5] ((>>) [4,5] | {Concat [4,5] | [[],[],[],[4],[5]]}) +-- Val [4,5] -- -data MapMaybe p q +data MapMaybe p q deriving Show type MapMaybeT p q = ConcatMap (p >> MaybeIn MEmptyP '[Id]) q instance P (MapMaybeT p q) x => P (MapMaybe p q) x where @@ -342,146 +321,175 @@ -- | similar to 'Data.Maybe.catMaybes' -- --- >>> pl @(CatMaybes Id) [Just 'a',Nothing,Just 'c',Just 'd',Nothing] --- Present "acd" (Concat "acd" | ["a","","c","d",""]) --- PresentT "acd" +-- >>> pl @CatMaybes [Just 'a',Nothing,Just 'c',Just 'd',Nothing] +-- Present "acd" ((>>) "acd" | {Concat "acd" | ["a","","c","d",""]}) +-- Val "acd" -- -data CatMaybes q -type CatMaybesT q = MapMaybe Id q +data CatMaybes deriving Show +type CatMaybesT = MapMaybe Id Id -instance P (CatMaybesT q) x => P (CatMaybes q) x where - type PP (CatMaybes q) x = PP (CatMaybesT q) x - eval _ = eval (Proxy @(CatMaybesT q)) +instance P CatMaybesT x => P CatMaybes x where + type PP CatMaybes x = PP CatMaybesT x + eval _ = eval (Proxy @CatMaybesT) --- | Convenient method to convert a value \'p\' to a 'Maybe' based on a predicate \'b\' --- if \'b\' then Just \'p\' else Nothing +-- | 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) +-- Val (Just 24) -- -- >>> pz @(MaybeBool (Id > 4) Id) (-5) --- PresentT Nothing +-- Val Nothing -- -data MaybeBool b p +-- >>> pz @(MaybeBool 'True 10) () +-- Val (Just 10) +-- -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) +-- pu @(If 'True (MkJust 10) (EmptyT Maybe)) () -- doesnt work +-- <interactive>:211:1: error: +-- * Couldn't match type 'Int' with '()' arising from a use of 'pu' + +data MaybeBool b p deriving Show + +type MaybeBoolT b p = EmptyBool Maybe b p + +instance P (MaybeBoolT b p) x => P (MaybeBool b p) x where + type PP (MaybeBool b p) x = PP (MaybeBoolT b p) x + eval _ = eval (Proxy @(MaybeBoolT b p)) + +-- | Convenient method to convert a value @p@ to an Alternative based on a predicate @b@ +-- +-- if @b@ is True then pure @p@ else empty +-- +-- >>> pz @(EmptyBool [] (Id > 4) 'True) 24 +-- Val [True] +-- +-- >>> pz @(EmptyBool [] (Id > 4) 'True) 1 +-- Val [] +-- +data EmptyBool t b p deriving Show + +instance ( Show (PP p a) + , P b a + , P p a + , PP b a ~ Bool + , Alternative t + ) => P (EmptyBool t b p) a where + type PP (EmptyBool t b p) a = t (PP p a) eval _ opts z = do - let msg0 = "MaybeBool" + let msg0 = "EmptyBool" bb <- evalBool (Proxy @b) opts z - case getValueLR opts (msg0 <> " b failed") bb [] of + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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] + Right p -> mkNode opts (Val (pure p)) (msg0 <> "(False) Just " <> showL opts p) [hh bb, hh pp] + Right False -> pure $ mkNode opts (Val empty) (msg0 <> "(True)") [hh bb] -- | extract the value from a 'Maybe' otherwise use the default value: similar to 'Data.Maybe.fromMaybe' -- -- >>> pz @(JustDef (1 % 4) Id) (Just 20.4) --- PresentT (102 % 5) +-- Val (102 % 5) -- -- >>> pz @(JustDef (1 % 4) Id) Nothing --- PresentT (1 % 4) +-- Val (1 % 4) -- -- >>> pz @(JustDef (MEmptyT _) Id) (Just "xy") --- PresentT "xy" +-- Val "xy" -- -- >>> pz @(JustDef (MEmptyT _) Id) Nothing --- PresentT () +-- Val () -- -- >>> pz @(JustDef (MEmptyT (SG.Sum _)) Id) Nothing --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -- >>> pl @(JustDef 0 Id) (Just 123) -- Present 123 (JustDef Just) --- PresentT 123 +-- Val 123 -- -- >>> pl @(JustDef 0 Id) Nothing -- Present 0 (JustDef Nothing) --- PresentT 0 +-- Val 0 -- -- >>> pl @(JustDef 99 Id) (Just 12) -- Present 12 (JustDef Just) --- PresentT 12 +-- Val 12 -- -- >>> pl @(JustDef 99 Id) Nothing -- Present 99 (JustDef Nothing) --- PresentT 99 +-- Val 99 -- -- >>> pl @(JustDef (99 -% 1) Id) Nothing -- Present (-99) % 1 (JustDef Nothing) --- PresentT ((-99) % 1) +-- Val ((-99) % 1) -- -- >>> pl @(JustDef (MEmptyT _) Id) (Just (SG.Sum 123)) -- Present Sum {getSum = 123} (JustDef Just) --- PresentT (Sum {getSum = 123}) +-- Val (Sum {getSum = 123}) -- -- >>> pl @(JustDef (MEmptyT _) Id) (Nothing @(SG.Sum _)) -- Present Sum {getSum = 0} (JustDef Nothing) --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -data JustDef p q +data JustDef p q deriving Show instance ( PP p x ~ a , PP q x ~ Maybe a , P p x - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] + Just b -> pure $ mkNode opts (Val b) (msg0 <> " Just") [hh qq] Nothing -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right b -> mkNode opts (PresentT b) (msg0 <> " Nothing") [hh qq, hh pp] + Right b -> mkNode opts (Val b) (msg0 <> " Nothing") [hh qq, hh pp] -- | extract the value from a 'Maybe' or fail with the given message -- -- >>> pz @(JustFail "nope" Id) (Just 99) --- PresentT 99 +-- Val 99 -- -- >>> pz @(JustFail "nope" Id) Nothing --- FailT "nope" +-- Fail "nope" -- --- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Nothing, 123) --- FailT "oops=123" +-- >>> pz @(JustFail (PrintF "oops=%d" Snd) Fst) (Nothing, 123) +-- Fail "oops=123" -- --- >>> pz @(JustFail (PrintF "oops=%d" (Snd Id)) (Fst Id)) (Just 'x', 123) --- PresentT 'x' +-- >>> pz @(JustFail (PrintF "oops=%d" Snd) Fst) (Just 'x', 123) +-- Val 'x' -- -data JustFail p q +data JustFail p q deriving Show instance ( PP p x ~ String , PP q x ~ Maybe a , P p x - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - Just b -> pure $ mkNode opts (PresentT b) (msg0 <> " Just") [hh qq] + Just b -> pure $ mkNode opts (Val b) (msg0 <> " Just") [hh qq] Nothing -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " Nothing") [hh qq, hh pp] + Right p -> mkNode opts (Fail p) (msg0 <> " Nothing") [hh qq, hh pp]
src/Predicate/Data/Monoid.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -19,30 +13,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted 'Semigroup' and 'Monoid' functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted 'Semigroup' and 'Monoid' functions module Predicate.Data.Monoid ( - - -- ** semigroup / monoid expressions type (<>) , MConcat , SConcat , STimes - , SapA - , SapA' + , Sap + , type S , MEmptyT , MEmptyT' , MEmptyP - , MEmpty2 - , MEmpty2' - ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import Data.Kind (Type) import qualified Data.Semigroup as SG import Data.List.NonEmpty (NonEmpty(..)) @@ -59,171 +47,136 @@ -- | similar to 'SG.<>' -- --- >>> pz @(Fst Id <> Snd Id) ("abc","def") --- PresentT "abcdef" +-- >>> pz @(Fst <> Snd) ("abc","def") +-- Val "abcdef" -- -- >>> pz @("abcd" <> "ef" <> Id) "ghi" --- PresentT "abcdefghi" +-- Val "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") +-- Val "abcdefghi" -- --- >>> pz @(SapA' (SG.Max _)) (10,12) --- PresentT (Max {getMax = 12}) +-- >>> pz @(Wrap (SG.Sum _) Id <> (10 >> FromInteger _)) 13 +-- Val (Sum {getSum = 23}) -- --- >>> pz @(SapA' (SG.Sum _)) (10,12) --- PresentT (Sum {getSum = 22}) +-- >>> pz @(Wrap (SG.Product _) Id <> Lift (FromInteger _) 10) 13 +-- Val (Product {getProduct = 130}) -- --- >>> pl @((Id <> Id) >> Unwrap Id) (SG.Sum 12) --- Present 24 ((>>) 24 | {getSum = 24}) --- PresentT 24 +-- >>> pz @('(10 >> FromInteger _,"def") <> Id) (SG.Sum 12, "_XYZ") +-- Val (Sum {getSum = 22},"def_XYZ") -- -data p <> q +data p <> q deriving Show 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 +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 [] + lr <- runPQ NoInline 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] + in mkNode opts (Val d) (showL opts p <> " <> " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] --- | semigroup append both sides of a tuple (ie uncurry (<>)) using 'Wrap' +-- | synonym for wrapping a monoid +type S a = SG.WrappedMonoid a + +-- | semigroup append both sides of a tuple (ie uncurry (<>)) using 'Wrap' and then unwraps the final result -- --- >>> pl @(SapA' (SG.Sum _) >> Unwrap Id) (4,5) --- Present 9 ((>>) 9 | {getSum = 9}) --- PresentT 9 +-- >>> pz @(Sap (SG.Sum _)) (4,5) +-- Val 9 -- -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)) - --- | semigroup append both sides of a tuple (ie uncurry (<>)) +-- >>> pz @(Sap (SG.Sum _)) (13,44) +-- Val 57 -- --- >>> pz @(Snd Id >> SapA) (4,("abc","def")) --- PresentT "abcdef" +-- >>> pz @(Sap SG.Any) (True,False) +-- Val True -- -data SapA -type SapAT = Fst Id <> Snd Id +-- >>> pz @(Sap SG.All) (True,False) +-- Val False +-- +-- >>> pz @(Sap (SG.Max _)) (10,12) +-- Val 12 +-- +-- >>> pz @(Sap (SG.Sum _)) (10,12) +-- Val 22 +-- +-- >>> pz @(Sap (S _)) ("abc","def") +-- Val "abcdef" +-- +-- >>> pz @(Fst <> Snd) ("abc","def") -- same as above but more direct +-- Val "abcdef" +-- +data Sap (t :: Type) deriving Show +type SapT (t :: Type) = Wrap t Fst <> Wrap t Snd >> Unwrap -instance P SapAT x => P SapA x where - type PP SapA x = PP SapAT x - eval _ = eval (Proxy @SapAT) +instance P (SapT t) x => P (Sap t) x where + type PP (Sap t) x = PP (SapT t) x + eval _ = eval (Proxy @(SapT t)) -- | similar to 'mconcat' -- -- >>> pz @(MConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] --- PresentT (Sum {getSum = 59}) +-- Val (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}) +-- >>> pz @(Map '(Pure SG.Sum Id, Pure SG.Max Id) >> MConcat Id) [7 :: Int,6,1,3,5] -- monoid so need eg Int +-- Val (Sum {getSum = 22},Max {getMax = 7}) -- -data MConcat p +data MConcat p deriving Show -instance (PP p x ~ [a] - , P p x - , Show a - , Monoid a - ) => P (MConcat p) x where +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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val b) (show3 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}) +-- Val (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}) +-- >>> pz @(Map '(Pure SG.Sum Id, Pure SG.Max Id) >> ToNEList >> SConcat Id) [7,6,1,3,5] +-- Val (Sum {getSum = 22},Max {getMax = 7}) -- -data SConcat p +data SConcat p deriving Show -instance (PP p x ~ NonEmpty a - , P p x - , Show a - , Semigroup a - ) => P (SConcat p) x where +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 + pure $ case getValueLR NoInline 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] - --- | lift mempty over a Functor -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) [] - --- | 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}] --- --- >>> pl @(MEmpty2 (SG.Sum _)) (Just ()) --- Present Just (Sum {getSum = 0}) (MEmpty2 Just (Sum {getSum = 0}) | Just ()) --- PresentT (Just (Sum {getSum = 0})) --- -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)) + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] -- | similar to 'mempty' -- -- >>> pl @(MEmptyT' Id) (Just (SG.Sum 12)) -- Present Nothing (MEmptyT Nothing) --- PresentT Nothing --- --- >>> pl @(MEmptyT (SG.Sum _) >> Unwrap Id >> Id + 4) () --- Present 4 ((>>) 4 | {0 + 4 = 4}) --- PresentT 4 +-- Val Nothing -- - --- no Monoid for Maybe a unless a is also a monoid but can use empty! -data MEmptyT' t +data MEmptyT' t deriving Show -- no Monoid for Maybe a unless a is also a monoid but can use empty! instance ( Show (PP t a) , Monoid (PP t a) ) => P (MEmptyT' t) a where @@ -231,26 +184,37 @@ eval _ opts _ = let msg0 = "MEmptyT" b = mempty @(PP t a) - in pure $ mkNode opts (PresentT b) (msg0 <> " " <> showL opts b) [] + in pure $ mkNode opts (Val b) (msg0 <> " " <> showL opts b) [] -- | similar to 'mempty' -- -- >>> pz @(MEmptyT (SG.Sum Int)) () --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- --- >>> pl @(MEmptyT _ ||| Ones Id) (Right "abc") +-- >>> pl @(MEmptyT _ ||| Ones) (Right "abc") -- Present ["a","b","c"] ((|||) Right ["a","b","c"] | "abc") --- PresentT ["a","b","c"] +-- Val ["a","b","c"] -- --- >>> pl @(MEmptyT _ ||| Ones Id) (Left ["ab"]) +-- >>> pl @(MEmptyT _ ||| Ones) (Left ["ab"]) -- Present [] ((|||) Left [] | ["ab"]) --- PresentT [] +-- Val [] -- -- >>> pl @(MEmptyT (Maybe ())) 'x' -- Present Nothing (MEmptyT Nothing) --- PresentT Nothing +-- Val Nothing -- -data MEmptyT (t :: Type) +-- >>> pl @(MEmptyT (SG.Sum _) >> Unwrap >> Id + 4) () +-- Present 4 ((>>) 4 | {0 + 4 = 4}) +-- Val 4 +-- +-- >>> pz @(FMap (MEmptyT (SG.Product Int))) [Identity (-13), Identity 4, Identity 99] +-- Val [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] +-- +-- >>> pl @(FMap (MEmptyT (SG.Sum _))) (Just ()) +-- Present Just (Sum {getSum = 0}) (FMap MEmptyT Sum {getSum = 0}) +-- Val (Just (Sum {getSum = 0})) +-- +data MEmptyT (t :: Type) deriving Show type MEmptyTT (t :: Type) = MEmptyT' (Hole t) instance P (MEmptyTT t) x => P (MEmptyT t) x where @@ -261,10 +225,10 @@ -- -- >>> pl @('Proxy >> MEmptyP) "abc" -- Present "" ((>>) "" | {MEmptyT ""}) --- PresentT "" +-- Val "" -- -data MEmptyP -type MEmptyPT = MEmptyT' Unproxy -- expects a proxy: so only some things work with this: eg MaybeIn +data MEmptyP deriving Show +type MEmptyPT = MEmptyT' UnproxyT -- 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 @@ -273,42 +237,41 @@ -- | similar to 'SG.stimes' -- -- >>> pz @(STimes 4 Id) (SG.Sum 3) --- PresentT (Sum {getSum = 12}) +-- Val (Sum {getSum = 12}) -- -- >>> pz @(STimes 4 Id) "ab" --- PresentT "abababab" +-- Val "abababab" -- -- >>> pl @(STimes 4 Id) (SG.Sum 13) -- Present Sum {getSum = 52} (STimes 4 p=Sum {getSum = 13} Sum {getSum = 52} | n=4 | Sum {getSum = 13}) --- PresentT (Sum {getSum = 52}) +-- Val (Sum {getSum = 52}) -- --- >>> pl @(STimes (Fst Id) (Snd Id)) (4,['x','y']) +-- >>> pl @(STimes Fst Snd) (4,['x','y']) -- Present "xyxyxyxy" (STimes 4 p="xy" "xyxyxyxy" | n=4 | "xy") --- PresentT "xyxyxyxy" +-- Val "xyxyxyxy" -- --- >>> pl @(STimes (Fst Id) (Snd Id)) (4,"abc") +-- >>> pl @(STimes Fst Snd) (4,"abc") -- Present "abcabcabcabc" (STimes 4 p="abc" "abcabcabcabc" | n=4 | "abc") --- PresentT "abcabcabcabc" +-- Val "abcabcabcabc" -- -- >>> pl @(STimes 4 Id) "abc" -- Present "abcabcabcabc" (STimes 4 p="abc" "abcabcabcabc" | n=4 | "abc") --- PresentT "abcabcabcabc" +-- Val "abcabcabcabc" -- - -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 +data STimes n p deriving Show +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 [] + lr <- runPQ NoInline 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 + Right (fromIntegral -> n::Int,p,pp,qq) -> + let msg1 = msg0 <> " " <> showL opts n <> " p=" <> showL opts p b = SG.stimes n p - in mkNode opts (PresentT b) (show01' opts msg1 b "n=" n <> showVerbose opts " | " p) [hh pp, hh qq] + in mkNode opts (Val b) (show3' opts msg1 b "n=" n <> showVerbose opts " | " p) [hh pp, hh qq]
src/Predicate/Data/Numeric.hs view
@@ -1,1068 +1,1213 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} -{-# LANGUAGE NoStarIsType #-} -{- | - promoted numeric functions --} -module Predicate.Data.Numeric ( - - -- ** 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' - - -- ** read / show expressions - , ReadBase - , ReadBase' - , ShowBase - - ) where -import Predicate.Core -import Predicate.Util -import Predicate.Data.Ordering (type (==)) -import GHC.TypeLits (Nat,KnownNat) -import qualified GHC.TypeLits as GL -import Data.List -import Data.Proxy -import Data.Typeable -import Data.Kind (Type) -import Data.Maybe -import qualified Numeric -import Data.Char -import Data.Ratio -import GHC.Real (Ratio((:%))) --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists --- >>> import Predicate.Prelude --- >>> import qualified Data.Semigroup as SG --- >>> import Data.Time - -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] - --- | '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) --- --- >>> pl @((FromInteger _ 12 &&& Id) >> Fst Id + Snd Id) (SG.Min 7) --- Present Min {getMin = 19} ((>>) Min {getMin = 19} | {getMin = 19}) --- PresentT (Min {getMin = 19}) --- --- >>> pl @((FromInteger _ 12 &&& Id) >> SapA) (SG.Product 7) --- Present Product {getProduct = 84} ((>>) Product {getProduct = 84} | {getProduct = 84}) --- PresentT (Product {getProduct = 84}) --- --- >>> pl @(FromInteger (SG.Sum _) (Fst Id)) (3,"A") --- Present Sum {getSum = 3} (FromInteger Sum {getSum = 3}) --- PresentT (Sum {getSum = 3}) --- --- >>> pl @(FromInteger DiffTime 123) 'x' --- Present 123s (FromInteger 123s) --- PresentT 123s --- -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) --- --- >>> pl @((ToRational 123 &&& Id) >> Fst Id + Snd Id) 4.2 --- Present 636 % 5 ((>>) 636 % 5 | {123 % 1 + 21 % 5 = 636 % 5}) --- PresentT (636 % 5) --- --- >>> pl @(Fst Id >= Snd Id || Snd Id > 23 || 12 -% 5 <= ToRational (Fst Id)) (12,13) --- True (False || True) --- TrueT --- --- >>> pl @(ToRational 14) () --- Present 14 % 1 (ToRational 14 % 1 | 14) --- PresentT (14 % 1) --- --- >>> pl @(ToRational 5 / ToRational 3) 'x' --- Present 5 % 3 (5 % 1 / 3 % 1 = 5 % 3) --- PresentT (5 % 3) --- - -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 --- --- >>> pl @(FromRational' (Fst Id) (Snd Id)) (1::Float,2 % 5) --- Present 0.4 (FromRational 0.4 | 2 % 5) --- PresentT 0.4 --- -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] - --- | 'fromRational' function where you need to provide the type \'t\' of the result --- --- >>> pz @(FromRational Rational Id) 23.5 --- PresentT (47 % 2) --- --- >>> pl @(FromRational Float (4 % 5)) () --- Present 0.8 (FromRational 0.8 | 4 % 5) --- PresentT 0.8 --- -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 --- --- >>> pl @(Truncate' (Fst Id >> Unproxy) (Snd Id)) (Proxy @Integer,2.3) --- Present 2 (Truncate 2 | 2.3) --- PresentT 2 --- --- >>> pl @(Truncate' (Fst Id) (Snd Id)) (1::Int,2.3) --- Present 2 (Truncate 2 | 2.3) --- PresentT 2 --- -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)) - -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 - -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 z@(p1,q1) = (fromIntegral p, fromIntegral q) - d@(dn :% dd) = uncurry (%) z - zz = if dn == p1 && dd == q1 then "" - else litVerbose opts " | " (show p <> " % " <> show q) - in mkNode opts (PresentT d) (showL opts d <> zz) [hh pp, hh qq] - --- | negate a ratio --- --- >>> pl @'[1 % 1 ,3 -% 2,3 -% 1] () --- Present [1 % 1,(-3) % 2,(-3) % 1] ('[1 % 1,(-3) % 2,(-3) % 1] (1 % 1) | ()) --- PresentT [1 % 1,(-3) % 2,(-3) % 1] --- --- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Floor _ Id) Id) () --- Present [1,-5,5,-1] ((>>) [1,-5,5,-1] | {Map [1,-5,5,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) --- PresentT [1,-5,5,-1] --- --- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Ceiling _ Id) Id) () --- Present [1,-4,6,-1] ((>>) [1,-4,6,-1] | {Map [1,-4,6,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) --- PresentT [1,-4,6,-1] --- --- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Truncate _ Id) Id) () --- Present [1,-4,5,-1] ((>>) [1,-4,5,-1] | {Map [1,-4,5,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) --- PresentT [1,-4,5,-1] --- --- >>> pl @(5 % 1 / 3 -% 1) 'x' --- Present (-5) % 3 (5 % 1 / (-3) % 1 = (-5) % 3) --- PresentT ((-5) % 3) --- --- >>> pl @(5 -% 1 / Fst Id) (3,'x') --- Present (-5) % 3 ((-5) % 1 / 3 % 1 = (-5) % 3) --- PresentT ((-5) % 3) --- -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 '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 'GHC.Real.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" --- --- >>> pl @(DivMod (Negate Id) 7) 23 --- Present (-4,5) (-23 `divMod` 7 = (-4,5)) --- PresentT (-4,5) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,-3) --- Present (-4,-2) (10 `divMod` -3 = (-4,-2)) --- PresentT (-4,-2) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,0) --- Error DivMod zero denominator --- FailT "DivMod zero denominator" --- --- >>> pl @(DivMod (9 - Fst Id) (Last (Snd Id))) (10,[12,13]) --- Present (-1,12) (-1 `divMod` 13 = (-1,12)) --- PresentT (-1,12) --- - -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" --- --- >>> pl @(QuotRem (Negate Id) 7) 23 --- Present (-3,-2) (-23 `quotRem` 7 = (-3,-2)) --- PresentT (-3,-2) --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,-3) --- Present (-3,1) (10 `quotRem` -3 = (-3,1)) --- PresentT (-3,1) --- - -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)) - --- | 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) - --- | 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] - --- 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] - --- | 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)" --- --- >>> pl @(ReadBase Int 16 Id) "fFe0" --- Present 65504 (ReadBase(Int,16) 65504 | "fFe0") --- PresentT 65504 --- --- >>> pl @(ReadBase Int 16 Id) "-ff" --- Present -255 (ReadBase(Int,16) -255 | "-ff") --- PresentT (-255) --- --- >>> pl @(ReadBase Int 16 Id) "ff" --- Present 255 (ReadBase(Int,16) 255 | "ff") --- PresentT 255 --- --- >>> pl @(ReadBase Int 22 Id) "zzz" --- Error invalid base 22 (ReadBase(Int,22) as=zzz err=[]) --- FailT "invalid base 22" --- --- >>> pl @((ReadBase Int 16 Id &&& Id) >> First (ShowBase 16 Id)) "fFe0" --- Present ("ffe0","fFe0") ((>>) ("ffe0","fFe0") | {(***) ("ffe0","fFe0") | (65504,"fFe0")}) --- PresentT ("ffe0","fFe0") --- --- >>> pl @(ReadBase Int 2 Id) "101111" --- Present 47 (ReadBase(Int,2) 47 | "101111") --- PresentT 47 --- -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 'Numeric.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" --- --- >>> pl @(ShowBase 16 Id) (-123) --- Present "-7b" (ShowBase(16) -7b | -123) --- PresentT "-7b" --- --- >>> pl @(ShowBase 16 Id) 123 --- Present "7b" (ShowBase(16) 7b | 123) --- PresentT "7b" --- --- >>> pl @(ShowBase 16 Id) 65504 --- Present "ffe0" (ShowBase(16) ffe0 | 65504) --- PresentT "ffe0" --- - -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] +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +-- | promoted numeric functions +module Predicate.Data.Numeric ( + + -- ** numeric + 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 (**) + , DivI + , RoundUp + + -- ** rational numbers + , type (%) + , type (-%) + , ToRational + , FromRational + , FromRational' + + -- ** read-show + , ReadBase + , ReadBase' + , ShowBase + , ShowBaseN + , UnShowBaseN + , ToBits + ) where +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import Predicate.Data.Ordering (type (==)) +import GHC.TypeLits (Nat,KnownNat) +import qualified GHC.TypeLits as GL +import Data.List (elemIndex, unfoldr) +import Data.Typeable (Typeable, Proxy(Proxy)) +import Data.Kind (Type) +import qualified Numeric +import Data.Char (toLower) +import Data.Ratio ((%)) +import GHC.Real (Ratio((:%))) +import qualified Safe (fromJustNote) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XOverloadedStrings +-- >>> :set -XNoOverloadedLists +-- >>> import Predicate.Prelude +-- >>> import qualified Data.Semigroup as SG +-- >>> import Data.Time + +data FromInteger' t n deriving Show + +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 NoInline opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromInteger (fromIntegral n) + in mkNode opts (Val b) (msg0 <> " " <> showL opts b) [hh nn] + +-- | 'fromInteger' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(FromInteger (SG.Sum _)) 23 +-- Val (Sum {getSum = 23}) +-- +-- >>> pz @(44 >> FromInteger Rational) 12 +-- Val (44 % 1) +-- +-- >>> pz @(FromInteger Rational) 12 +-- Val (12 % 1) +-- +-- >>> pl @((Lift (FromInteger _) 12 &&& Id) >> Fst + Snd) (SG.Min 7) +-- Present Min {getMin = 19} ((>>) Min {getMin = 19} | {getMin = 19}) +-- Val (Min {getMin = 19}) +-- +-- >>> pl @(Lift (FromInteger _) 12 <> Id) (SG.Product 7) +-- Present Product {getProduct = 84} (Product {getProduct = 12} <> Product {getProduct = 7} = Product {getProduct = 84}) +-- Val (Product {getProduct = 84}) +-- +-- >>> pl @(Fst >> FromInteger (SG.Sum _)) (3,"A") +-- Present Sum {getSum = 3} ((>>) Sum {getSum = 3} | {getSum = 3}) +-- Val (Sum {getSum = 3}) +-- +-- >>> pl @(Lift (FromInteger DiffTime) 123) 'x' +-- Present 123s ((>>) 123s | {FromInteger 123s}) +-- Val 123s +-- +data FromInteger (t :: Type) deriving Show +type FromIntegerT (t :: Type) = FromInteger' (Hole t) Id +--type FromIntegerP n = FromInteger' UnproxyT n + +instance P (FromIntegerT t) x => P (FromInteger t) x where + type PP (FromInteger t) x = PP (FromIntegerT t) x + eval _ = eval (Proxy @(FromIntegerT t)) + +data FromIntegral' t n deriving Show + +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 NoInline opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromIntegral n + in mkNode opts (Val b) (show3 opts msg0 b n) [hh nn] + +-- | 'fromIntegral' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(FromIntegral (SG.Sum _)) 23 +-- Val (Sum {getSum = 23}) +-- +-- >>> pz @(Pop1' (Proxy FromIntegral) 'Proxy 44) (1 % 0) +-- Val (44 % 1) +-- +data FromIntegral (t :: Type) deriving Show +type FromIntegralT (t :: Type) = FromIntegral' (Hole t) Id + +instance P (FromIntegralT t) x => P (FromIntegral t) x where + type PP (FromIntegral t) x = PP (FromIntegralT t) x + eval _ = eval (Proxy @(FromIntegralT t)) + +-- | 'toRational' function +-- +-- >>> pz @(ToRational Id) 23.5 +-- Val (47 % 2) +-- +-- >>> pl @((ToRational 123 &&& Id) >> Fst + Snd) 4.2 +-- Present 636 % 5 ((>>) 636 % 5 | {123 % 1 + 21 % 5 = 636 % 5}) +-- Val (636 % 5) +-- +-- >>> pl @(Fst >= Snd || Snd > 23 || 12 -% 5 <= ToRational Fst) (12,13) +-- True (False || True) +-- Val True +-- +-- >>> pl @(ToRational 14) () +-- Present 14 % 1 (ToRational 14 % 1 | 14) +-- Val (14 % 1) +-- +-- >>> pl @(ToRational 5 / ToRational 3) 'x' +-- Present 5 % 3 (5 % 1 / 3 % 1 = 5 % 3) +-- Val (5 % 3) +-- +data ToRational p deriving Show + +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 NoInline opts msg0 pp [] of + Left e -> e + Right a -> + let r = toRational a + in mkNode opts (Val r) (show3 opts msg0 r a) [hh pp] + +-- | 'fromRational' function where you need to provide the type @t@ of the result +-- +-- >>> pl @(FromRational' Fst Snd) (1,2 % 5) +-- Present 0.4 (FromRational 0.4 | 2 % 5) +-- Val 0.4 +-- +data FromRational' t p deriving Show + +instance ( P p a + , PP p a ~ Rational + , Show (PP t a) + , Fractional (PP t a) + ) => P (FromRational' t p) a where + type PP (FromRational' t p) a = PP t a + eval _ opts a = do + let msg0 = "FromRational" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = fromRational @(PP t a) p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | 'fromRational' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(FromRational Rational) 23.5 +-- Val (47 % 2) +-- +-- >>> pl @(FromRational Float) (4 % 5) +-- Present 0.8 (FromRational 0.8 | 4 % 5) +-- Val 0.8 +-- +data FromRational (t :: Type) deriving Show +type FromRationalT (t :: Type) = FromRational' (Hole t) Id + +instance P (FromRationalT t) x => P (FromRational t) x where + type PP (FromRational t) x = PP (FromRationalT t) x + eval _ = eval (Proxy @(FromRationalT t)) + +-- | 'truncate' function where you need to provide the type @t@ of the result +-- +-- >>> pl @(Truncate' (Fst >> UnproxyT) Snd) (Proxy @Integer,2.3) +-- Present 2 (Truncate 2 | 2.3) +-- Val 2 +-- +-- >>> pl @(Truncate' Fst Snd) (1::Int,2.3) +-- Present 2 (Truncate 2 | 2.3) +-- Val 2 +-- +data Truncate' t p deriving Show + +instance ( P p x + , RealFrac (PP p x) + , Integral (PP t x) + , Show (PP t x) + , Show (PP p 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = truncate p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | 'truncate' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(Truncate Int) (23 % 5) +-- Val 4 +-- +data Truncate (t :: Type) deriving Show +type TruncateT (t :: Type) = Truncate' (Hole t) Id + +instance P (TruncateT t) x => P (Truncate t) x where + type PP (Truncate t) x = PP (TruncateT t) x + eval _ = eval (Proxy @(TruncateT t)) + +-- | 'ceiling' function where you need to provide the type @t@ of the result +data Ceiling' t p deriving Show + +instance ( P p x + , RealFrac (PP p x) + , Integral (PP t x) + , Show (PP t x) + , Show (PP p 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = ceiling p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | 'ceiling' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(Ceiling Int) (23 % 5) +-- Val 5 +-- +data Ceiling (t :: Type) deriving Show +type CeilingT (t :: Type) = Ceiling' (Hole t) Id + +instance P (CeilingT t) x => P (Ceiling t) x where + type PP (Ceiling t) x = PP (CeilingT t) x + eval _ = eval (Proxy @(CeilingT t)) + +-- | 'floor' function where you need to provide the type @t@ of the result +data Floor' t p deriving Show + +instance ( P p x + , RealFrac (PP p x) + , Integral (PP t x) + , Show (PP t x) + , Show (PP p 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let b = floor p + in mkNode opts (Val b) (show3 opts msg0 b p) [hh pp] + +-- | 'floor' function where you need to provide the type @t@ of the result +-- +-- >>> pz @(Floor Int) (23 % 5) +-- Val 4 +-- +data Floor (t :: Type) deriving Show +type FloorT (t :: Type) = Floor' (Hole t) Id + +instance P (FloorT t) x => P (Floor t) x where + type PP (Floor t) x = PP (FloorT t) x + eval _ = eval (Proxy @(FloorT t)) + +data BinOp = BMult | BSub | BAdd + deriving stock (Read, Show, Eq) + +-- | adds two values together pointed to by @p@ and @q@ +data p + q deriving Show +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)) + +-- | subtracts two values together pointed to by @p@ and @q@ +data p - q deriving Show +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)) + +-- | multiply two values together pointed to by @p@ and @q@ +data p * q deriving Show +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 ^ Snd) (10,4) +-- Val 10000 +-- +data p ^ q deriving Show +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" + lr <- runPQ NoInline 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 (Fail (msg0 <> " negative exponent")) "" hhs + else let d = p ^ q + in mkNode opts (Val d) (showL opts p <> " ^ " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'GHC.Float.(**)' +-- +-- >>> pz @(Fst ** Snd) (10,4) +-- Val 10000.0 +-- +-- >>> pz @'(IsPrime,Id ^ 3,(FromIntegral _) ** (Lift (FromRational _) (1 % 2))) 4 +-- Val (False,64,2.0) +-- +data p ** q deriving Show +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 NoInline 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 (Fail (msg0 <> " negative exponent")) "" hhs + else if p == 0 && q == 0 then mkNode opts (Fail (msg0 <> " zero/zero")) "" hhs + else let d = p ** q + in mkNode opts (Val d) (showL opts p <> " ** " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'logBase' +-- +-- >>> pz @(Fst `LogBase` Snd >> Truncate Int) (10,12345) +-- Val 4 +-- +data LogBase p q deriving Show +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 NoInline 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 (Fail (msg0 <> " non-positive base")) "" hhs + else let d = logBase p q + in mkNode opts (Val d) (msg0 <> " " <> showL opts p <> " " <> showL opts q <> " = " <> showL opts d) hhs + +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 * Snd) (13,5) +-- Val 65 +-- +-- >>> pz @(Fst + 4 * Length Snd - 4) (3,"hello") +-- Val 19 +-- +data Bin (op :: BinOp) p q deriving Show + +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 NoInline 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 (Val d) (showL opts p <> " " <> s <> " " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- | fractional division +-- +-- >>> pz @(Fst / Snd) (13,2) +-- Val 6.5 +-- +-- >>> pz @(ToRational 13 / Id) 0 +-- Fail "(/) zero denominator" +-- +-- >>> pz @(12 % 7 / 14 % 5 + Id) 12.4 +-- Val (3188 % 245) +-- +data p / q deriving Show +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 NoInline 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 (Fail msg1) "" [hh pp, hh qq] + | otherwise -> + let d = p / q + in mkNode opts (Val d) (showL opts p <> " / " <> showL opts q <> " = " <> showL opts d) [hh pp, hh qq] + +-- | divide for integrals +-- +-- >>> pz @(On (+) (Id * Id) >> (Id ** (DivI Double 1 2))) (3,4) +-- Val 5.0 +-- +data DivI t p q deriving Show + +type DivIT t p q = (p >> FromIntegral t) / (q >> FromIntegral t) + +instance P (DivIT t p q) x => P (DivI t p q) x where + type PP (DivI t p q) x = PP (DivIT t p q) x + eval _ = eval (Proxy @(DivIT t p q)) + + +-- | creates a 'Rational' value +-- +-- >>> pz @(Id < 21 % 5) (-3.1) +-- Val True +-- +-- >>> pz @(Id < 21 % 5) 4.5 +-- Val False +-- +-- >>> pz @(Fst % Snd) (13,2) +-- Val (13 % 2) +-- +-- >>> pz @(13 % Id) 0 +-- Fail "(%) zero denominator" +-- +-- >>> pz @(4 % 3 + 5 % 7) "asfd" +-- Val (43 % 21) +-- +-- >>> pz @(4 -% 7 * 5 -% 3) "asfd" +-- Val (20 % 21) +-- +-- >>> pz @(Negate (14 % 3)) () +-- Val ((-14) % 3) +-- +-- >>> pz @(14 % 3) () +-- Val (14 % 3) +-- +-- >>> pz @(Negate (14 % 3) ==! Lift (FromIntegral _) (Negate 5)) () +-- Val GT +-- +-- >>> pz @(14 -% 3 ==! 5 -% 1) "aa" +-- Val GT +-- +-- >>> pz @(Negate (14 % 3) ==! Negate 5 % 2) () +-- Val LT +-- +-- >>> pz @(14 -% 3 * 5 -% 1) () +-- Val (70 % 3) +-- +-- >>> pz @(14 % 3 ==! 5 % 1) () +-- Val LT +-- +-- >>> pz @(15 % 3 / 4 % 2) () +-- Val (5 % 2) +-- +data p % q deriving Show +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 NoInline 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 (Fail msg1) "" [hh pp, hh qq] + | otherwise -> + let z@(p1,q1) = (fromIntegral p, fromIntegral q) + d@(dn :% dd) = uncurry (%) z + zz = if dn == p1 && dd == q1 then "" + else litVerbose opts " | " (show p <> " % " <> show q) + in mkNode opts (Val d) (showL opts d <> zz) [hh pp, hh qq] + +-- | negate a ratio +-- +-- >>> pl @'[1 % 1 ,3 -% 2,3 -% 1] () +-- Present [1 % 1,(-3) % 2,(-3) % 1] ('[1 % 1,(-3) % 2,(-3) % 1] (1 % 1) | ()) +-- Val [1 % 1,(-3) % 2,(-3) % 1] +-- +-- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Floor _)) () +-- Present [1,-5,5,-1] ((>>) [1,-5,5,-1] | {Map [1,-5,5,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) +-- Val [1,-5,5,-1] +-- +-- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Ceiling _)) () +-- Present [1,-4,6,-1] ((>>) [1,-4,6,-1] | {Map [1,-4,6,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) +-- Val [1,-4,6,-1] +-- +-- >>> pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 -% 5)] >> Map (Truncate _)) () +-- Present [1,-4,5,-1] ((>>) [1,-4,5,-1] | {Map [1,-4,5,-1] | [1 % 1,(-33) % 7,21 % 4,(-1) % 1]}) +-- Val [1,-4,5,-1] +-- +-- >>> pl @(5 % 1 / 3 -% 1) 'x' +-- Present (-5) % 3 (5 % 1 / (-3) % 1 = (-5) % 3) +-- Val ((-5) % 3) +-- +-- >>> pl @(5 -% 1 / Fst) (3,'x') +-- Present (-5) % 3 ((-5) % 1 / 3 % 1 = (-5) % 3) +-- Val ((-5) % 3) +-- +data p -% q deriving Show +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 +-- Val (-14) +-- +-- >>> pz @(Negate (Fst * Snd)) (14,3) +-- Val (-42) +-- +-- >>> pz @(Negate (15 -% 4)) "abc" +-- Val (15 % 4) +-- +-- >>> pz @(Negate (15 % 3)) () +-- Val ((-5) % 1) +-- +-- >>> pz @(Negate (Fst % Snd)) (14,3) +-- Val ((-14) % 3) +-- +data Negate p deriving Show + +instance ( Num (PP p x) + , P p x + , Show (PP 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = negate p + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + + +-- | similar to 'abs' +-- +-- >>> pz @(Abs Id) (-14) +-- Val 14 +-- +-- >>> pz @(Abs Snd) ("xx",14) +-- Val 14 +-- +-- >>> pz @(Abs Id) 0 +-- Val 0 +-- +-- >>> pz @(Abs (Negate 44)) "aaa" +-- Val 44 +-- +data Abs p deriving Show + +instance ( Num (PP p x) + , P p x + , Show (PP 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = abs p + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + +-- | similar to 'div' +-- +-- >>> pz @(Div Fst Snd) (10,4) +-- Val 2 +-- +-- >>> pz @(Div Fst Snd) (10,0) +-- Fail "Div zero denominator" +-- +data Div p q deriving Show +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 NoInline 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 (Fail (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `div` q + in mkNode opts (Val d) (showL opts p <> " `div` " <> showL opts q <> " = " <> showL opts d) hhs + + +-- | similar to 'GHC.Real.mod' +-- +-- >>> pz @(Mod Fst Snd) (10,3) +-- Val 1 +-- +-- >>> pz @(Mod Fst Snd) (10,0) +-- Fail "Mod zero denominator" +-- +data Mod p q deriving Show +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 NoInline 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 (Fail (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `mod` q + in mkNode opts (Val d) (showL opts p <> " `mod` " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'divMod' +-- +-- >>> pz @(DivMod Fst Snd) (10,3) +-- Val (3,1) +-- +-- >>> pz @(DivMod Fst Snd) (10,-3) +-- Val (-4,-2) +-- +-- >>> pz @(DivMod Fst Snd) (-10,3) +-- Val (-4,2) +-- +-- >>> pz @(DivMod Fst Snd) (-10,-3) +-- Val (3,-1) +-- +-- >>> pz @(DivMod Fst Snd) (10,0) +-- Fail "DivMod zero denominator" +-- +-- >>> pl @(DivMod (Negate Id) 7) 23 +-- Present (-4,5) (-23 `divMod` 7 = (-4,5)) +-- Val (-4,5) +-- +-- >>> pl @(DivMod Fst Snd) (10,-3) +-- Present (-4,-2) (10 `divMod` -3 = (-4,-2)) +-- Val (-4,-2) +-- +-- >>> pl @(DivMod Fst Snd) (10,0) +-- Error DivMod zero denominator +-- Fail "DivMod zero denominator" +-- +-- >>> pl @(DivMod (9 - Fst) (Snd >> Last)) (10,[12,13]) +-- Present (-1,12) (-1 `divMod` 13 = (-1,12)) +-- Val (-1,12) +-- +data DivMod p q deriving Show + +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 NoInline 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 (Fail (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `divMod` q + in mkNode opts (Val d) (showL opts p <> " `divMod` " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'quotRem' +-- +-- >>> pz @(QuotRem Fst Snd) (10,3) +-- Val (3,1) +-- +-- >>> pz @(QuotRem Fst Snd) (10,-3) +-- Val (-3,1) +-- +-- >>> pz @(QuotRem Fst Snd) (-10,-3) +-- Val (3,-1) +-- +-- >>> pz @(QuotRem Fst Snd) (-10,3) +-- Val (-3,-1) +-- +-- >>> pz @(QuotRem Fst Snd) (10,0) +-- Fail "QuotRem zero denominator" +-- +-- >>> pl @(QuotRem (Negate Id) 7) 23 +-- Present (-3,-2) (-23 `quotRem` 7 = (-3,-2)) +-- Val (-3,-2) +-- +-- >>> pl @(QuotRem Fst Snd) (10,-3) +-- Present (-3,1) (10 `quotRem` -3 = (-3,1)) +-- Val (-3,1) +-- +data QuotRem p q deriving Show + +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 NoInline 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 (Fail (msg0 <> " zero denominator")) "" hhs + _ -> let d = p `quotRem` q + in mkNode opts (Val d) (showL opts p <> " `quotRem` " <> showL opts q <> " = " <> showL opts d) hhs + +-- | similar to 'quot' +data Quot p q deriving Show +type QuotT p q = QuotRem p q >> Fst + +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)) + +-- | similar to 'rem' +data Rem p q deriving Show +type RemT p q = QuotRem p q >> Snd + +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)) + +-- | similar to 'even' +-- +-- >>> pz @(Map Even) [9,-4,12,1,2,3] +-- Val [False,True,True,False,True,False] +-- +-- >>> pz @(Map '(Even,Odd)) [9,-4,12,1,2,3] +-- Val [(False,True),(True,False),(True,False),(False,True),(True,False),(False,True)] +-- +data Even deriving Show +type EvenT = Mod Id 2 == 0 + +instance P EvenT x => P Even x where + type PP Even x = Bool + eval _ = evalBool (Proxy @EvenT) + +-- | similar to 'odd' +data Odd deriving Show +type OddT = Mod Id 2 == 1 + +instance P OddT x => P Odd x where + type PP Odd x = Bool + eval _ = evalBool (Proxy @OddT) + +-- | similar to 'signum' +-- +-- >>> pz @(Signum Id) (-14) +-- Val (-1) +-- +-- >>> pz @(Signum Id) 14 +-- Val 1 +-- +-- >>> pz @(Signum Id) 0 +-- Val 0 +-- +data Signum p deriving Show + +instance ( Num (PP p x) + , P p x + , Show (PP 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 NoInline opts msg0 pp [] of + Left e -> e + Right p -> + let d = signum p + in mkNode opts (Val d) (show3 opts msg0 d p) [hh pp] + +-- supports negative numbers unlike readInt +data ReadBase' t (n :: Nat) p deriving Show + +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 NoInline 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) + (Safe.fromJustNote "ReadBase" . (`elemIndex` xs) . toLower) + p1 of + [(b,"")] -> mkNode opts (Val (ff b)) (msg0 <> " " <> showL opts (ff b) <> showVerbose opts " | " p) [hh pp] + o -> mkNode opts (Fail ("invalid base " <> show n)) (msg0 <> " as=" <> p <> " err=" <> showL opts o) [hh pp] + +-- | Read a number using base 2 through a maximum of 36 +-- +-- >>> pz @(ReadBase Int 16) "00feD" +-- Val 4077 +-- +-- >>> pz @(ReadBase Int 16) "-ff" +-- Val (-255) +-- +-- >>> pz @(ReadBase Int 2) "10010011" +-- Val 147 +-- +-- >>> pz @(ReadBase Int 8) "Abff" +-- Fail "invalid base 8" +-- +-- >>> pl @(ReadBase Int 16 >> GuardSimple (Id > 0xffff) >> ShowBase 16) "12344" +-- Present "12344" ((>>) "12344" | {ShowBase(16) 12344 | 74564}) +-- Val "12344" +-- +-- >>> :set -XBinaryLiterals +-- >>> pz @(ReadBase Int 16 >> GuardSimple (Id > 0b10011111) >> ShowBase 16) "7f" +-- Fail "(127 > 159)" +-- +-- >>> pl @(ReadBase Int 16) "fFe0" +-- Present 65504 (ReadBase(Int,16) 65504 | "fFe0") +-- Val 65504 +-- +-- >>> pl @(ReadBase Int 16) "-ff" +-- Present -255 (ReadBase(Int,16) -255 | "-ff") +-- Val (-255) +-- +-- >>> pl @(ReadBase Int 16) "ff" +-- Present 255 (ReadBase(Int,16) 255 | "ff") +-- Val 255 +-- +-- >>> pl @(ReadBase Int 22) "zzz" +-- Error invalid base 22 (ReadBase(Int,22) as=zzz err=[]) +-- Fail "invalid base 22" +-- +-- >>> pl @((ReadBase Int 16 &&& Id) >> First (ShowBase 16)) "fFe0" +-- Present ("ffe0","fFe0") ((>>) ("ffe0","fFe0") | {(***) ("ffe0","fFe0") | (65504,"fFe0")}) +-- Val ("ffe0","fFe0") +-- +-- >>> pl @(ReadBase Int 2) "101111" +-- Present 47 (ReadBase(Int,2) 47 | "101111") +-- Val 47 +-- +data ReadBase (t :: Type) (n :: Nat) deriving Show +type ReadBaseT (t :: Type) (n :: Nat) = ReadBase' (Hole t) n Id + +instance P (ReadBaseT t n) x => P (ReadBase t n) x where + type PP (ReadBase t n) x = PP (ReadBaseT t n) x + eval _ = eval (Proxy @(ReadBaseT t n)) + +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 'Numeric.showIntAtBase' but passes the sign through +-- +-- >>> pz @(ShowBase 16) 4077 +-- Val "fed" +-- +-- >>> pz @(ShowBase 16) (-255) +-- Val "-ff" +-- +-- >>> pz @(ShowBase 2) 147 +-- Val "10010011" +-- +-- >>> pz @(Lift (ShowBase 2) (Negate 147)) "whatever" +-- Val "-10010011" +-- +-- >>> pl @(ShowBase 16) (-123) +-- Present "-7b" (ShowBase(16) -7b | -123) +-- Val "-7b" +-- +-- >>> pl @(ShowBase 16) 123 +-- Present "7b" (ShowBase(16) 7b | 123) +-- Val "7b" +-- +-- >>> pl @(ShowBase 16) 65504 +-- Present "ffe0" (ShowBase(16) ffe0 | 65504) +-- Val "ffe0" +-- +data ShowBase (n :: Nat) deriving Show + +instance ( 2 GL.<= n + , n GL.<= 36 + , KnownNat n + , Integral x + ) => P (ShowBase n) x where + type PP (ShowBase n) x = String + eval _ opts x = + let n = nat @n + xs = getValidBase n + msg0 = "ShowBase(" <> show n <> ")" + p :: Integer + p = fromIntegral x + (ff,a') = if p < 0 then (('-':), abs p) else (id,p) + b = Numeric.showIntAtBase (fromIntegral n) (xs !!) a' "" + in pure $ mkNode opts (Val (ff b)) (msg0 <> " " <> litL opts (ff b) <> showVerbose opts " | " p) [] + +-- | Display a number at base >= 2 but just show as a list of ints: ignores the sign +-- +-- >>> pl @(ShowBaseN 16 Id) (256*256*2+256*14+16*7+11) +-- Present [2,0,14,7,11] (ShowBaseN | 16 | 134779) +-- Val [2,0,14,7,11] +-- +data ShowBaseN n p deriving Show + +instance ( PP p x ~ a + , P p x + , PP n x ~ b + , P n x + , Integral a + , Integral b + ) => P (ShowBaseN n p) x where + type PP (ShowBaseN n p) x = [Int] + eval _ opts x = do + let msg0 = "ShowBaseN" + lr <- runPQ NoInline msg0 (Proxy @n) (Proxy @p) opts x [] + pure $ case lr of + Left e -> e + Right (fromIntegral -> n,fromIntegral -> p,nn,pp) -> + let hhs = [hh nn, hh pp] + in if n < 2 then mkNode opts (Fail (msg0 <> " base must be greater than 1")) "" hhs + else let xs = reverse $ unfoldr (\s -> if s<1 then Nothing else Just (swapC (divMod s n))) (abs p) + in mkNode opts (Val xs) (msg0 <> showVerbose opts " | " n <> showVerbose opts " | " p) hhs + +-- | convert to bits +-- +-- >>> pl @(ToBits 123 >> UnShowBaseN 2) () +-- Present 123 ((>>) 123 | {UnShowBaseN | 2 | [1,1,1,1,0,1,1]}) +-- Val 123 +-- +data ToBits p deriving Show +type ToBitsT p = ShowBaseN 2 p + +instance P (ToBitsT p) x => P (ToBits p) x where + type PP (ToBits p) x = PP (ToBitsT p) x + eval _ = eval (Proxy @(ToBitsT p)) + +-- | reverse 'ShowBaseN' +-- +-- >>> pz @(UnShowBaseN 2) [1,0,0,1,0] +-- Val 18 +-- +-- >>> pz @(UnShowBaseN 2) [1,1,1] +-- Val 7 +-- +-- >>> pz @(UnShowBaseN 16) [7,0,3,1] +-- Val 28721 +-- +-- >>> pz @(UnShowBaseN 16) [0] +-- Val 0 +-- +-- >>> pz @(UnShowBaseN 16) [] +-- Val 0 +-- +data UnShowBaseN n deriving Show + +instance ( x ~ [a] + , PP n x ~ b + , P n x + , Integral a + , Integral b + ) => P (UnShowBaseN n) x where + type PP (UnShowBaseN n) x = Integer + eval _ opts x = do + let msg0 = "UnShowBaseN" + nn <- eval (Proxy @n) opts x + pure $ case getValueLR NoInline opts msg0 nn [] of + Left e -> e + Right (fromIntegral -> n) -> + let xs = map fromIntegral x + hhs = [hh nn] + in if n < 2 then mkNode opts (Fail (msg0 <> " base must be greater than 1")) "" hhs + else let b = snd $ foldr (\a (m,tot) -> (m*n, a*m+tot)) (1,0) xs + in mkNode opts (Val b) (msg0 <> showVerbose opts " | " n <> showVerbose opts " | " xs) hhs + + +-- | calculate the amount to roundup to the next @n@ +-- +-- >>> pl @(RoundUp Fst Snd) (3,9) +-- Present 0 (RoundUp 3 9 = 0) +-- Val 0 +-- +-- >>> pl @(RoundUp Fst Snd) (3,10) +-- Present 2 (RoundUp 3 10 = 2) +-- Val 2 +-- +-- >>> pl @(RoundUp Fst Snd) (3,11) +-- Present 1 (RoundUp 3 11 = 1) +-- Val 1 +-- +-- >>> pl @(RoundUp Fst Snd) (3,12) +-- Present 0 (RoundUp 3 12 = 0) +-- Val 0 +-- +-- >>> pl @(RoundUp 3 0) () +-- Present 0 (RoundUp 3 0 = 0) +-- Val 0 +-- +-- >>> pl @(RoundUp 0 10) () +-- Error RoundUp 'n' cannot be zero +-- Fail "RoundUp 'n' cannot be zero" +-- +data RoundUp n p deriving Show + +instance ( Integral (PP n x) + , Show (PP n x) + , PP n x ~ PP p x + , P n x + , P p x + ) => P (RoundUp n p) x where + type PP (RoundUp n p) x = PP n x + eval _ opts x = do + let msg0 = "RoundUp" + lr <- runPQ NoInline msg0 (Proxy @n) (Proxy @p) opts x [] + pure $ case lr of + Left e -> e + Right (n,p,nn,pp) -> + let hhs = [hh nn, hh pp] + d = (n-p) `mod` n + in if n == 0 then mkNode opts (Fail (msg0 <> " 'n' cannot be zero")) "" hhs + else mkNode opts (Val d) (msg0 <> " " <> show n <> " " <> show p <> " = " <> show d) hhs +
src/Predicate/Data/Ordering.hs view
@@ -1,13 +1,7 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} @@ -18,14 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted 'Ordering' functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted 'Ordering' functions module Predicate.Data.Ordering ( - - -- ** compare expressions type (>) , type (>=) , type (==) @@ -45,14 +35,11 @@ , Lt , Ne , type (==!) - , OrdP , OrdA' , OrdA - , OrdI , type (===~) , Cmp , CmpI - , Asc , Asc' , Desc @@ -61,18 +48,14 @@ , Positive , AllNegative , Negative - - , Ands - , Ors ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import Predicate.Data.Tuple (Pairs) -import Data.Proxy -import Data.Char -import Data.Function -import Data.Foldable (toList) -import Data.List (findIndex) +import Data.Proxy (Proxy(Proxy)) +import Data.Char (toLower) +import Data.Function (on) -- $setup -- >>> :set -XDataKinds @@ -82,169 +65,209 @@ -- >>> :set -XNoOverloadedLists -- >>> import Predicate.Prelude --- | compare if expression \'p\' is greater than \'q\' +-- | compare if expression @p@ is greater than @q@ -- -- >>> pl @(Gt 4) 5 -- True (5 > 4) --- TrueT +-- Val True -- -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 +data Gt n deriving Show +type GtT n = Id > n --- | compare if expression \'p\' is greater than \'q\' +instance P (GtT n) x => P (Gt n) x where + type PP (Gt n) x = PP (GtT n) x + eval _ = eval (Proxy @(GtT n)) + +-- | compare if expression @p@ is greater than or equal to @q@ +data Ge n deriving Show +type GeT n = Id >= n + +instance P (GeT n) x => P (Ge n) x where + type PP (Ge n) x = PP (GeT n) x + eval _ = eval (Proxy @(GeT n)) + +-- | compare if expression @p@ is equal to @q@ +data Same n deriving Show +type SameT n = Id == n + +instance P (SameT n) x => P (Same n) x where + type PP (Same n) x = PP (SameT n) x + eval _ = eval (Proxy @(SameT n)) + +-- | compare if expression @p@ is less than or equal to @q@ +data Le n deriving Show +type LeT n = Id <= n + +instance P (LeT n) x => P (Le n) x where + type PP (Le n) x = PP (LeT n) x + eval _ = eval (Proxy @(LeT n)) + +-- | compare if expression @p@ is less than to @q@ +data Lt n deriving Show +type LtT n = Id < n + +instance P (LtT n) x => P (Lt n) x where + type PP (Lt n) x = PP (LtT n) x + eval _ = eval (Proxy @(LtT n)) + +-- | compare if expression @p@ is not equal to @q@ +data Ne n deriving Show +type NeT n = Id /= n + +instance P (NeT n) x => P (Ne n) x where + type PP (Ne n) x = PP (NeT n) x + eval _ = eval (Proxy @(NeT n)) + +-- | compare if expression @p@ is greater than @q@ -- -- >>> pl @(Id > "xx") "abc" -- False ("abc" > "xx") --- FalseT +-- Val False -- -- >>> pl @(Id > "aa") "abc" -- True ("abc" > "aa") --- TrueT +-- Val True -- --- >>> pl @(Fst Id > Snd Id) (True,False) +-- >>> pl @(Fst > Snd) (True,False) -- True (True > False) --- TrueT +-- Val True -- -data p > q +data p > q deriving Show 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)) --- | compare if expression \'p\' is greater than or equal to \'q\' -data p >= q +-- | compare if expression @p@ is greater than or equal to @q@ +data p >= q deriving Show 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)) --- | compare if expression \'p\' is equal to \'q\' +-- | compare if expression @p@ is equal to @q@ -- --- >>> pl @(Fst Id == Snd Id) ("ab","xyzabw") +-- >>> pl @(Fst == Snd) ("ab","xyzabw") -- False ("ab" == "xyzabw") --- FalseT +-- Val False -- --- >>> pl @(Fst Id == Snd Id) ("aBc","AbC") +-- >>> pl @(Fst == Snd) ("aBc","AbC") -- False ("aBc" == "AbC") --- FalseT +-- Val False -- --- >>> pz @(Fst Id == Snd Id) ("aBc","aBc") --- TrueT +-- >>> pz @(Fst == Snd) ("aBc","aBc") +-- Val True -- -- >>> pl @(Id == "Abc") "abc" -- False ("abc" == "Abc") --- FalseT +-- Val False -- --- >>> pl @(Fst Id == Snd Id) (True,False) +-- >>> pl @(Fst == Snd) (True,False) -- False (True == False) --- FalseT +-- Val False -- --- >>> pl @(Not Id *** Id >> Fst Id == Snd Id) (True,False) +-- >>> pl @(Not Id *** Id >> Fst == Snd) (True,False) -- True ((>>) True | {False == False}) --- TrueT +-- Val True -- -data p == q +data p == q deriving Show 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)) --- | compare if expression \'p\' is less than or equal to \'q\' +-- | compare if expression @p@ is less than or equal to @q@ -- --- >>> pl @(Not (Fst Id >> Len <= 6)) ([2..7],True) +-- >>> pl @(Not (Fst >> Len <= 6)) ([2..7],True) -- False (Not ((>>) True | {6 <= 6})) --- FalseT +-- Val False -- --- >>> pl @(Fst Id >> Len <= 6) ([2..7],True) +-- >>> pl @(Fst >> Len <= 6) ([2..7],True) -- True ((>>) True | {6 <= 6}) --- TrueT +-- Val True -- --- >>> pl @(Length (Fst Id) <= 6) ([2..7],True) +-- >>> pl @(Length Fst <= 6) ([2..7],True) -- True (6 <= 6) --- TrueT +-- Val True -- --- >>> pl @(Fst Id >> (Len <= 6)) ([2..7],True) +-- >>> pl @(Fst >> (Len <= 6)) ([2..7],True) -- True ((>>) True | {6 <= 6}) --- TrueT +-- Val True -- -data p <= q +data p <= q deriving Show 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)) --- | compare if expression \'p\' is less than \'q\' -data p < q +-- | compare if expression @p@ is less than @q@ +data p < q deriving Show 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)) --- | compare if expression \'p\' is not equal to \'q\' +-- | compare if expression @p@ is not equal to @q@ -- --- >>> pl @(Fst Id /= Snd Id) ("ab","xyzabw") +-- >>> pl @(Fst /= Snd) ("ab","xyzabw") -- True ("ab" /= "xyzabw") --- TrueT +-- Val True -- -data p /= q +data p /= q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is greater than \'q\' +-- | case-insensitive compare if string expression @p@ is greater than @q@ -- -data p >~ q +data p >~ q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is greater than or equal to \'q\' -data p >=~ q +-- | case-insensitive compare if string expression @p@ is greater than or equal to @q@ +data p >=~ q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is equal to \'q\' -data p ==~ q +-- | case-insensitive compare if string expression @p@ is equal to @q@ +data p ==~ q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is less than or equal to \'q\' -data p <=~ q +-- | case-insensitive compare if string expression @p@ is less than or equal to @q@ +data p <=~ q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is less than \'q\' -data p <~ q +-- | case-insensitive compare if string expression @p@ is less than @q@ +data p <~ q deriving Show 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)) --- | case-insensitive compare if string expression \'p\' is not equal to \'q\' -data p /=~ q +-- | case-insensitive compare if string expression @p@ is not equal to @q@ +data p /=~ q deriving Show infix 4 /=~ instance P (CmpI 'CNe p q) x => P (p /=~ q) x where @@ -254,80 +277,74 @@ -- | 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 ==! Snd) (10,9) +-- Val GT -- --- >>> pz @(Fst Id ==! Snd Id) (10,11) --- PresentT LT +-- >>> pz @(14 % 3 ==! Fst -% Snd) (-10,7) +-- Val GT -- --- >>> pz @(Snd Id ==! (Fst Id >> Snd Id >> Head Id)) (('x',[10,12,13]),10) --- PresentT EQ +-- >>> pz @(Fst ==! Snd) (10,11) +-- Val LT -- --- >>> pz @(Snd Id ==! Head (Snd (Fst Id))) (('x',[10,12,13]),10) --- PresentT EQ +-- >>> pz @(Snd ==! (L12 >> Head)) (('x',[10,12,13]),10) +-- Val EQ -- -- >>> pl @("aa" ==! Id) "aaaa" -- Present LT ((==!) "aa" < "aaaa") --- PresentT LT +-- Val LT -- --- >>> pl @(Pairs >> Map (First (Succ Id >> Succ Id) >> Fst Id ==! Snd Id) Id) [1,2,3,6,8] +-- >>> pl @(Pairs >> Map (First (Succ >> Succ) >> Fst ==! Snd)) [1,2,3,6,8] -- Present [GT,GT,LT,EQ] ((>>) [GT,GT,LT,EQ] | {Map [GT,GT,LT,EQ] | [(1,2),(2,3),(3,6),(6,8)]}) --- PresentT [GT,GT,LT,EQ] +-- Val [GT,GT,LT,EQ] -- --- >>> pl @((Ones Id << ShowP Id) >> Map (Fst Id ==! Snd Id) Pairs) 1234223 +-- >>> pl @((Ones << ShowP Id) >> Map' (Fst ==! Snd) Pairs) 1234223 -- Present [LT,LT,LT,GT,EQ,LT] ((>>) [LT,LT,LT,GT,EQ,LT] | {Map [LT,LT,LT,GT,EQ,LT] | [("1","2"),("2","3"),("3","4"),("4","2"),("2","2"),("2","3")]}) --- PresentT [LT,LT,LT,GT,EQ,LT] +-- Val [LT,LT,LT,GT,EQ,LT] -- -- >>> pl @("Abc" ==! Id) "abc" -- Present LT ((==!) "Abc" < "abc") --- PresentT LT +-- Val LT -- --- >>> pl @(Fst Id ==! Snd Id) (3,12) +-- >>> pl @(Fst ==! Snd) (3,12) -- Present LT ((==!) 3 < 12) --- PresentT LT +-- Val LT -- --- >>> pl @(Fst Id ==! Snd Id) ("aBc","AbC") +-- >>> pl @(Fst ==! Snd) ("aBc","AbC") -- Present GT ((==!) "aBc" > "AbC") --- PresentT GT +-- Val GT -- --- >>> pl @(Snd Id ==! Fst Id) ("aBc","AbC") +-- >>> pl @(Snd ==! Fst) ("aBc","AbC") -- Present LT ((==!) "AbC" < "aBc") --- PresentT LT +-- Val LT -- - -data p ==! q +data p ==! q deriving Show 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 +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 [] + lr <- runPQ NoInline 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] + in mkNode opts (Val d) (msg0 <> " " <> showL opts p <> " " <> prettyOrd d <> " " <> showL opts q) [hh pp, hh qq] -- | similar to 'compare' but using a tuple as input -data OrdA p +data OrdA deriving Show -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)) +instance P (OrdA' Id Id) x => P OrdA x where + type PP OrdA x = PP (OrdA' Id Id) x + eval _ = eval (Proxy @(OrdA' Id Id)) -data OrdA' p q -type OrdAT' p q = (Fst Id >> p) ==! (Snd Id >> q) +data OrdA' p q deriving Show +type OrdAT' p q = (Fst >> p) ==! (Snd >> q) instance P (OrdAT' p q) x => P (OrdA' p q) x where type PP (OrdA' p q) x = PP (OrdAT' p q) x @@ -335,108 +352,106 @@ -- | compare two strings ignoring case and return an ordering -- --- >>> pz @(Fst Id ===~ Snd Id) ("abC","aBc") --- PresentT EQ +-- >>> pz @(Fst ===~ Snd) ("abC","aBc") +-- Val EQ -- --- >>> pz @(Fst Id ===~ Snd Id) ("abC","DaBc") --- PresentT LT +-- >>> pz @(Fst ===~ Snd) ("abC","DaBc") +-- Val LT -- --- >>> pl @(Fst Id ===~ Snd Id &&& Fst Id ==! Snd Id) ("abc","abc") --- Present (EQ,EQ) (W '(EQ,EQ)) --- PresentT (EQ,EQ) +-- >>> pl @(Fst ===~ Snd &&& Fst ==! Snd) ("abc","abc") +-- Present (EQ,EQ) ('(EQ,EQ)) +-- Val (EQ,EQ) -- -- --- >>> pl @(Fst Id ===~ Snd Id) ("aBc","AbC") +-- >>> pl @(Fst ===~ Snd) ("aBc","AbC") -- Present EQ ((===~) aBc = AbC) --- PresentT EQ +-- Val EQ -- -- >>> pl @("Abc" ===~ Id) "abc" -- Present EQ ((===~) Abc = abc) --- PresentT EQ +-- Val EQ -- -- -- >>> pl @("Abc" ==~ Id) "abc" -- True (Abc ==~ abc) --- TrueT +-- Val True -- --- >>> pl @(Fst Id ==~ Snd Id) ("aBc","AbC") +-- >>> pl @(Fst ==~ Snd) ("aBc","AbC") -- True (aBc ==~ AbC) --- TrueT +-- Val True -- --- >>> pl @(Fst Id ==~ Snd Id && Fst Id == Snd Id) ("Abc","Abc") +-- >>> pl @(Fst ==~ Snd && Fst == Snd) ("Abc","Abc") -- True (True && True) --- TrueT +-- Val True -- - -type OrdI p q = p ===~ q -data p ===~ q +data p ===~ q deriving Show infix 4 ===~ -instance (PP p a ~ String - , PP p a ~ PP q a - , P p a - , P q a - ) => P (p ===~ q) a where +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 [] + lr <- runPQ NoInline 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] + in mkNode opts (Val d) (msg0 <> " " <> p <> " " <> prettyOrd d <> " " <> q) [hh pp, hh qq] --- | compare two values using the given ordering \'o\' +-- | compare two values using the given ordering @o@ -- -- >>> pl @(Lt 4) 123 -- False (123 < 4) --- FalseT +-- Val False -- -- >>> pl @(Lt 4) 1 -- True (1 < 4) --- TrueT +-- Val True -- -- >>> pl @(Negate 7 <..> 20) (-4) -- True (-7 <= -4 <= 20) --- TrueT +-- Val True -- -- >>> pl @(Negate 7 <..> 20) 21 -- False (21 <= 20) --- FalseT +-- Val False -- -data Cmp (o :: OrderingP) p q +data Cmp (o :: OrderingP) p q deriving Show -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 +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 [] + lr <- runPQ NoInline 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 +-- | compare two strings ignoring case using the given ordering @o@ +data CmpI (o :: OrderingP) p q deriving Show -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 +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 [] + lr <- runPQ NoInline sfn (Proxy @p) (Proxy @q) opts a [] pure $ case lr of Left e -> e Right (p,q,pp,qq) -> @@ -447,17 +462,17 @@ -- | a type level predicate for a monotonic increasing list -- -- >>> pl @Asc "aaacdef" --- True (All(6)) --- TrueT +-- True ((>>) True | {All(6)}) +-- Val True -- -- >>> pz @Asc [1,2,3,4,5,5,7] --- TrueT +-- Val True -- -- >>> pz @Asc "axacdef" --- FalseT +-- Val False -- -data Asc -type AscT = All (Fst Id <= Snd Id) Pairs +data Asc deriving Show +type AscT = Pairs >> All (Fst <= Snd) instance P AscT x => P Asc x where type PP Asc x = PP AscT x @@ -466,25 +481,31 @@ -- | a type level predicate for a strictly increasing list -- -- >>> pz @Asc' [1,2,3,4,5,5,7] --- FalseT +-- Val False -- -data Asc' -type AscT' = All (Fst Id < Snd Id) Pairs +-- >>> pz @Asc' [] +-- Val True +-- +-- >>> pz @Asc' [-10] +-- Val True +-- +data Asc' deriving Show +type AscT' = Pairs >> All (Fst < Snd) 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 +data Desc deriving Show +type DescT = Pairs >> All (Fst >= Snd) 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 +data Desc' deriving Show +type DescT' = Pairs >> All (Fst > Snd) instance P DescT' x => P Desc' x where type PP Desc' x = PP DescT' x @@ -497,16 +518,16 @@ -- | a type level predicate for all positive elements in a list -- -- >>> pz @AllPositive [1,5,10,2,3] --- TrueT +-- Val True -- -- >>> pz @AllPositive [0,1,5,10,2,3] --- FalseT +-- Val False -- -- >>> pz @AllPositive [3,1,-5,10,2,3] --- FalseT +-- Val False -- -data AllPositive -type AllPositiveT = All Positive Id +data AllPositive deriving Show +type AllPositiveT = All Positive instance P AllPositiveT x => P AllPositive x where type PP AllPositive x = PP AllPositiveT x @@ -515,84 +536,28 @@ -- | a type level predicate for all negative elements in a list -- -- >>> pz @AllNegative [-1,-5,-10,-2,-3] --- TrueT +-- Val True -- -data AllNegative -type AllNegativeT = All Negative Id +data AllNegative deriving Show +type AllNegativeT = All Negative 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 - --- | similar to 'Data.Foldable.and' --- --- >>> 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 +-- | a type level predicate for a positive number +data Positive deriving Show +type PositiveT = Gt 0 -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] +instance P PositiveT x => P Positive x where + type PP Positive x = PP PositiveT x + eval _ = evalBool (Proxy @PositiveT) --- | similar to 'Data.Foldable.or' --- --- >>> 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 +-- | a type level predicate for a negative number +data Negative deriving Show +type NegativeT = Lt 0 -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] +instance P NegativeT x => P Negative x where + type PP Negative x = PP NegativeT x + eval _ = evalBool (Proxy @NegativeT)
+ src/Predicate/Data/Proxy.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted functions for proxies +module Predicate.Data.Proxy ( + -- ** create a proxy from a type + ProxyT + , Proxy1T + , Proxy2T + , Proxify + -- ** simple proxy application + , Pop0 + -- ** needs kind signatures on @p@ + , Pop1 + , Pop2 + , Pop1' + , Pop2' + , PApp + , PApp2 + + ) where +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import qualified GHC.TypeLits as GL +import Data.Kind (Type) +import Data.Typeable +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> import Predicate.Prelude +-- >>> import Control.Lens +-- >>> import Control.Lens.Action +-- >>> import qualified Data.Semigroup as SG +-- >>> :m + Text.Show.Functions +-- >>> :m + Data.Ratio + + +-- | makes a proxy from a simple type: similar to the P instance for 'Proxy but requires a show instance +-- +-- >>> pz @(Pop1' (Proxy FromInteger) ProxyT 123) (4 % 0) +-- Val (123 % 1) +-- +-- >>> pz @(Pop1' (Proxy MEmptyT) ProxyT ()) (SG.Product 4) +-- Val (Product {getProduct = 1}) +-- +-- >>> pz @((Id $$ 44) >> Pop1' (Proxy MEmptyT) ProxyT ()) SG.Product +-- Val (Product {getProduct = 1}) +-- +-- >>> pz @((ProxyT << Fst) >> FMap Head) ([True],13) ^!? acts . _Val . to typeRep -- Proxify is easier +-- Just Bool +-- +data ProxyT deriving Show +instance Show x => P ProxyT x where + type PP ProxyT x = Proxy x + eval _ opts x = + let b = Proxy @x + in pure $ mkNode opts (Val b) ("ProxyT" <> showVerbose opts " | " x) [] + +-- | makes a proxy from a one parameter container +-- +-- >>> pz @(Pop1' (Proxy EmptyT) Proxy1T 123) Nothing +-- Val Nothing +-- +-- >>> pz @(Pop1' (Proxy EmptyT) Proxy1T 123) (Just 10) +-- Val Nothing +-- +-- >>> pz @((Id $$ ()) >> Pop1' (Proxy EmptyT) Proxy1T 123) Just +-- Val Nothing +-- +data Proxy1T deriving Show +instance P Proxy1T x where + type PP Proxy1T x = Proxy (ExtractTFromTA x) + eval _ opts _ = + let b = Proxy @(ExtractTFromTA x) + in pure $ mkNode opts (Val b) "Proxy1T" [] + +-- | makes a proxy from a two parameter container +-- +-- >>> pz @(Pop1' (Proxy EmptyT) Proxy2T 123) (Left "ASf") +-- Val (Left "") +-- +-- >>> pz @(Pop1' (Proxy EmptyT) Proxy2T 123) (Right 1) +-- Val (Left "") +-- +-- >>> pz @((Id $$ "asdf") >> Pop1' (Proxy EmptyT) Proxy2T 123) Left +-- Val (Left "") +-- +-- >>> pz @((Id $$ "asdf") >> Pop1' (Proxy EmptyT) Proxy2T 123) Right +-- Val (Left "") +-- +-- >>> pz @(Pop1' (Proxy EmptyT) ((Id $$ "ss") >> Proxy2T) 123) Right +-- Val (Left "") +-- +-- >>> pz @(Pop1' (Proxy EmptyT) ((Id $$ "ss") >> Proxy2T) 123) Left +-- Val (Left "") +-- +data Proxy2T deriving Show +instance P Proxy2T x where + type PP Proxy2T x = Proxy (Proxy2TT x) + eval _ opts _ = + let b = Proxy @(Proxy2TT x) + in pure $ mkNode opts (Val b) "Proxy2T" [] + +type family Proxy2TT (x :: Type) :: (Type -> Type) where + Proxy2TT (t a _) = t a + +-- | run the proxy @p@ in the environment pointed to by @q@ +-- +-- >>> pl @(Pop0 (Proxy '(Head,Len)) "abcdef") () +-- Present ('a',6) (Pop0 | '('a',6)) +-- Val ('a',6) +-- +-- >>> pz @(Pop0 Id "abcdef") (Proxy @'(Head,Len)) +-- Val ('a',6) +-- +-- >>> pl @(Pop0 Fst Snd) (Proxy @Snd,("dd","ee")) +-- Present "ee" (Pop0 | Snd "ee" | ("dd","ee")) +-- Val "ee" +-- +-- >>> pz @(Pop0 Fst L22) (Proxy @(Fst <> Snd),(True,("dd","ee"))) +-- Val "ddee" +-- +-- >>> pz @(Pop0 Id () <> "def") (Proxy @"abc") -- Proxy works for any kind! +-- Val "abcdef" +-- +-- >>> pz @(Pop0 Id () <> "def") (Nothing @(W "abc")) -- Proxy works for any kind! +-- Val "abcdef" +-- +-- >>> pz @(Pop0 Id (C "A")) (Proxy @Succ) +-- Val 'B' +-- +-- >>> pz @(Pop0 Fst Snd) (Proxy @(All1 Even),[1,5,2,3,4]) +-- Val False +-- +-- >>> pz @(Pop0 Fst Snd) (Proxy @(Partition Even Snd),(True,[8,1,5,2,3,4,6])) +-- Val ([8,2,4,6],[1,5,3]) +-- +-- >>> pl @(Proxy Snd >> Pop0 Id '( 'True,2)) () +-- Present 2 ((>>) 2 | {Pop0 | Snd 2 | (True,2)}) +-- Val 2 +-- +-- >>> pl @(Proxy (Fst <> Snd) >> Pop0 Id '("aa","bb")) () +-- Present "aabb" ((>>) "aabb" | {Pop0 | "aa" <> "bb" = "aabb"}) +-- Val "aabb" +-- +-- >>> pz @(Pop0 Fst Snd) (Proxy @Succ,EQ) +-- Val GT +-- +-- >>> pz @(Pop0 Fst Snd) (Proxy @(FMap Succ),Just 23) +-- Val (Just 24) +-- +-- >>> pz @(Pop0 Id (1 ... 12)) (Proxy @(FMap Succ)) +-- Val [2,3,4,5,6,7,8,9,10,11,12,13] +-- +-- >>> pz @(Pop0 Id '( 'True, MkJust 12)) (Proxy @(FMap $ FMap Succ)) +-- Val (True,Just 13) +-- +-- >>> pz @('(Id, PApp (Proxy '(,)) (Proxy 4)) >> Second (PApp Id (Proxy Fst)) >> Pop0 Snd Fst) ("abc",True) +-- Val (4,"abc") +-- +-- >>> pz @(Pop1 (Proxy Proxy) "abc" () >> Pop0 Id ()) () +-- Val "abc" +-- +-- >>> pz @(Proxy (Proxy (Proxy "asdff")) >> Pop0 Id () >> Pop0 Id () >> Pop0 Id ()) () +-- Val "asdff" +-- +data Pop0 p q deriving Show + +instance ( P q x + , PP p x ~ proxy z + , P z (PP q x) + ) => P (Pop0 p q) x where + type PP (Pop0 p q) x = Pop0T (PP p x) (PP q x) + eval _ opts x = do + let msg0 = "Pop0" + qq <- eval (Proxy @q) opts x + case getValueLR NoInline opts msg0 qq [] of + Left e -> pure e + Right q -> do + zz <- eval (Proxy @z) opts q + pure $ case getValueLR NoInline opts msg0 zz [hh qq] of + Left e -> e + Right _z -> mkNodeCopy opts zz (msg0 <> nullIf " | " (_ttString zz)) [hh qq,hh zz] + +-- the key is to pass all the vars into the type family so ghc can figure stuff out +type family Pop0T (p :: Type) (q :: Type) :: Type where + Pop0T (Proxy z) q = PP z q + Pop0T (_proxy z) q = PP z q + Pop0T p q = GL.TypeError ( + 'GL.Text "Pop0T: requires 'Proxy z' and 'q' get applied to each other" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + ) + +-- | applies Proxy @p@ to @q@ in the environment pointed to by @r@ : needs kind signatures on @p@ +-- +-- >>> pz @(Pop1 Fst L22 Snd) (Proxy @Length,(False,('x',"abcdef"))) +-- Val 6 +-- +-- >>> pz @(Proxy Length >> Pop1 IdT Snd '(1,'[1,2,3,4])) () +-- Val 4 +-- +-- >>> pz @(LiftA2 (Pop1 Fst Snd Id) (MkJust (Proxy (Lift Succ))) (MkJust 1)) () +-- Val (Just 2) +-- +-- >>> pz @(LiftA2 (Pop1 Fst Snd Id) (MkJust (Proxy ((*) 4))) (MkJust 3)) () +-- Val (Just 12) +-- +-- >>> pz @(Pop1 Fst Snd Id <$> MkJust (Proxy ((*) 4)) <:> MkJust 3) () +-- Val (Just 12) +-- +-- >>> pz @(Pop1 Fst Snd Id <$> Fst <:> Snd) (Just (Proxy @((*) 4)), Just 3) +-- Val (Just 12) +-- +-- >>> pz @(Proxy (Lift "asdf") >> Pop1 Id 123 Id) () +-- Val "asdf" +-- +-- >>> pz @(Pop1 Id "abc" ()) (Proxy @(K 99)) +-- Val 99 +-- +-- >>> pz @(Pop1 Id "abc" ()) (Proxy @(Flip K 99)) +-- Val "abc" +-- +-- >>> pz @(Pop1 (Proxy ('(,) 'True)) Len "abc") () +-- Val (True,3) +data Pop1 p q r deriving Show + +instance ( P r x + , PP p x ~ Proxy (z :: k -> k1) + , P (z q) (PP r x) + ) => P (Pop1 p q r) x where + type PP (Pop1 p q r) x = Pop1T (PP p x) q (PP r x) + eval _ opts x = do + let msg0 = "Pop1" + rr <- eval (Proxy @r) opts x + case getValueLR NoInline opts msg0 rr [] of + Left e -> pure e + Right r -> do +-- zz <- eval (Proxy @(Pop1T (PP p x) q)) opts r + zz <- eval (Proxy @(z q)) opts r + pure $ case getValueLR NoInline opts msg0 zz [hh rr] of + Left e -> e + Right _z -> mkNodeCopy opts zz (msg0 <> nullIf " | " (_ttString zz)) [hh rr,hh zz] + +type family Pop1T (p :: Type) (q :: k) (r :: Type) :: Type where + Pop1T (Proxy z) q r = PP (z q) r +-- Pop1T (Proxy (z :: k -> k1)) (q :: k) r = PP (z q :: k1) r + Pop1T p q r = + GL.TypeError ( + 'GL.Text "Pop1T: requires 'Proxy z' and z must be a function requiring one parameter!!" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + 'GL.:$$: 'GL.Text " r = " 'GL.:<>: 'GL.ShowType r + ) + +-- | apply Proxy @p@ to Proxy @q@ and run in the environment pointed to by @r@ : needs kind signatures on @p@ +-- +-- >>> pz @(Pop1' (Proxy ((<>) Snd)) (Proxy Fst) Id) ("abc","def") +-- Val "defabc" +-- +-- >>> pz @(Pop1' (Proxy ((>>) Snd)) (Proxy (Resplit "\\." >> Map (ReadP Int Id))) Id) (1,"123.33.5") +-- Val [123,33,5] +-- +-- >>> pz @(Pop1' (Proxy (Lift Snd)) (Proxy Fst) Id) ((True,2),("abc",1 % 4)) +-- Val 2 +-- +-- >>> pz @(Pop1' Fst Snd Thd) (Proxy @(Lift Snd), Proxy @Fst,((True,2),("abc",1 % 4))) +-- Val 2 +-- +-- >>> pz @(Pop1' Fst Snd '( '( 'True,2),'("abc",1 % 4))) (Proxy @(Lift Snd), Proxy @Fst) +-- Val 2 +-- +-- >>> pz @(Pop1' (Proxy MEmptyT) (Proxy (SG.Sum _)) ()) () +-- Val (Sum {getSum = 0}) +-- +-- >>> pz @(Pop1' (Proxy MEmptyT) (PApp (Proxy SG.Sum) (Proxy Float)) ()) () +-- Val (Sum {getSum = 0.0}) +-- +-- >>> pz @(Pop1' (Proxy Proxy) (Proxy Fst) () >> Pop0 Id '("abc",1234)) () +-- Val "abc" +-- +-- >>> pz @(Pop1' (Proxy ToEnum) 'Proxy 100) 'a' +-- Val 'd' +-- +-- >>> pz @(Pop1' (Proxy ToEnum) 'Proxy 120) (undefined :: Char) +-- Val 'x' +-- +data Pop1' p q r deriving Show + +instance ( P r x + , PP p x ~ Proxy (z :: k -> k1) + , PP q x ~ Proxy (w :: k) + , P (z w) (PP r x) + ) => P (Pop1' p q r) x where + type PP (Pop1' p q r) x = Pop1'T (PP p x) (PP q x) (PP r x) + eval _ opts x = do + let msg0 = "Pop1'" + rr <- eval (Proxy @r) opts x + case getValueLR NoInline opts msg0 rr [] of + Left e -> pure e + Right r -> do + zz <- eval (Proxy @(z w)) opts r + pure $ case getValueLR NoInline opts msg0 zz [hh rr] of + Left e -> e + Right _z -> mkNodeCopy opts zz (msg0 <> nullIf " | " (_ttString zz)) [hh rr,hh zz] + +type family Pop1'T (p :: Type) (q :: Type) (r :: Type) :: Type where + Pop1'T (Proxy z) (Proxy w) r = PP (z w) r +-- Pop1'T (Proxy (z :: k -> k1)) (Proxy (w :: k)) r = PP (z w :: k1) r + Pop1'T p q r = + GL.TypeError ( + 'GL.Text "Pop1'T: requires 'Proxy z' and z must be a function requiring one parameter!!" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + 'GL.:$$: 'GL.Text " r = " 'GL.:<>: 'GL.ShowType r + ) + +-- | apply Proxy @p@ to @q@ and @r@ then run in the environment pointed to by @s@ : needs kind signatures on @p@ +-- +-- >>> pz @(Pop2 (Proxy '(,)) Fst 14 Id) ([1..4],'True) +-- Val ([1,2,3,4],14) +-- +-- >>> pz @(Pop2' (Proxy Pure) (Proxy SG.Sum) (Proxy Id) Id) 123 +-- Val (Sum {getSum = 123}) +-- +data Pop2 p q r s deriving Show + +instance ( P s x + , PP p x ~ Proxy (z :: k -> k1 -> k2) + , P (z q r) (PP s x) + ) => P (Pop2 p q r s) x where + type PP (Pop2 p q r s) x = Pop2T (PP p x) q r (PP s x) + eval _ opts x = do + let msg0 = "Pop2" + ss <- eval (Proxy @s) opts x + case getValueLR NoInline opts msg0 ss [] of + Left e -> pure e + Right s -> do + zz <- eval (Proxy @(z q r)) opts s + pure $ case getValueLR NoInline opts msg0 zz [hh ss] of + Left e -> e + Right _z -> mkNodeCopy opts zz (msg0 <> nullIf " | " (_ttString zz)) [hh ss,hh zz] + +-- pass all the arguments in!!! else ghc gets confused +type family Pop2T (p :: Type) (q :: k) (r :: k1) (s :: Type) :: Type where + Pop2T (Proxy z) q r s = PP (z q r) s +-- Pop2T (Proxy (z :: k -> k1 -> k2)) (q :: k) (r :: k1) s = PP (z q r :: k2) s + Pop2T p q r s = + GL.TypeError ( + 'GL.Text "Pop2T: requires 'Proxy z' and z must be a function requiring one parameter!!" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + 'GL.:$$: 'GL.Text " r = " 'GL.:<>: 'GL.ShowType r + 'GL.:$$: 'GL.Text " s = " 'GL.:<>: 'GL.ShowType s + ) + +-- | Applies Proxy @p@ to Proxy @q@ and Proxy @r@ and runs in the environment pointed to by @s@ : needs kind signatures on @p@ +-- +-- >>> pz @(Pop2' (Proxy '(,)) (Proxy 1) (Proxy "sss") ()) () +-- Val (1,"sss") +-- +-- >>> pz @(Pop2' (Proxy '(,)) (Proxy L31) (Proxy (Fst % Snd)) '(11,99,'("ss",3))) () +-- Val ("ss",1 % 9) +-- +-- >>> pz @(Pop2' Fst Snd Thd (L4 Id)) (Proxy @'(,), Proxy @L31, Proxy @(Fst % Snd), (11,99,("ss",3))) +-- Val ("ss",1 % 9) +-- +data Pop2' p q r s deriving Show + +instance ( P s x + , PP p x ~ Proxy (z :: k -> k1 -> k2) + , PP q x ~ Proxy (w :: k) + , PP r x ~ Proxy (v :: k1) + , P (z w v) (PP s x) + ) => P (Pop2' p q r s) x where + type PP (Pop2' p q r s) x = Pop2'T (PP p x) (PP q x) (PP r x) (PP s x) + eval _ opts x = do + let msg0 = "Pop2'" + ss <- eval (Proxy @s) opts x + case getValueLR NoInline opts msg0 ss [] of + Left e -> pure e + Right s -> do + zz <- eval (Proxy @(z w v)) opts s + pure $ case getValueLR NoInline opts msg0 zz [hh ss] of + Left e -> e + Right _z -> mkNodeCopy opts zz (msg0 <> nullIf " | " (_ttString zz)) [hh ss,hh zz] + +-- pass in all the arguments otherwise ghc gets confused +type family Pop2'T (p :: Type) (q :: Type) (r :: Type) (s :: Type) :: Type where + Pop2'T (Proxy z) (Proxy w) (Proxy v) s = PP (z w v) s +-- Pop2'T (Proxy (z :: k -> k1 -> k2)) (Proxy (w :: k)) (Proxy (v :: k1)) s = PP (z w v :: k2) s + Pop2'T p q r s = + GL.TypeError ( + 'GL.Text "Pop2'T: requires 'Proxy z' and z must be a function requiring one parameter!!" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + 'GL.:$$: 'GL.Text " r = " 'GL.:<>: 'GL.ShowType r + 'GL.:$$: 'GL.Text " s = " 'GL.:<>: 'GL.ShowType s + ) + +-- | applies Proxy @p@ to Proxy @q@ and returns a Proxy: needs kind signatures on @p@ +-- +-- >>> pz @(PApp Fst Snd >> Pop0 Id '("abcdef",99)) (Proxy @('(,) (Fst >> Len)), Proxy @16) +-- Val (6,16) +-- +-- >>> pz @('(Id,PApp (Proxy ('(,) (Fst >> Len))) (Proxy 16)) >> Pop0 Snd Fst) ("abcdefg",101) +-- Val (7,16) +-- +-- >>> pz @('(Id,PApp (Proxy '(,)) (Proxy (Fst >> Len))) >> Second (PApp Id (Proxy 16)) >> Pop0 Snd Fst) ("abcdefg",101) -- or can call PApp2 +-- Val (7,16) +-- +-- >>> pz @(PApp (PApp (Proxy ('(,) :: GL.Nat -> GL.Symbol -> (GL.Nat,GL.Symbol))) (Proxy 1)) (Proxy "abc")) () ^!? acts . _Val . to typeRep +-- Just ('(,) Nat Symbol 1 "abc") +-- +-- >>> pz @(PApp (Proxy '(,)) (Proxy 4) >> PApp Id (Proxy Fst) >> Pop0 Id (W '(1,2))) () +-- Val (4,1) +-- +-- >>> pz @(PApp (Proxy '(,)) (Proxy 4) >> PApp Id (Proxy Fst) >> Pop0 Id '( 'True,"hello")) () +-- Val (4,True) +-- +-- >>> pan @(PApp (Proxy (MsgI "hello ")) Fst >> Pop0 Id '(1,2,3)) (Proxy @"there",()) +-- P (>>) "there" +-- | +-- +- P PApp +-- | +-- `- P Pop0 | hello '"there" +-- | +-- +- P '(,,) +-- | | +-- | +- P '1 +-- | | +-- | +- P '2 +-- | | +-- | `- P '3 +-- | +-- `- P hello '"there" +-- Val "there" +-- +-- >>> pz @(PApp (Proxy Proxy) (Proxy "abc") >> Pop0 Id () >> Pop0 Id () ) () +-- Val "abc" +-- +-- >>> pz @(PApp (Proxy '(,,)) (Proxy 10) >> PApp Id (Proxy "ss") >> PApp Id (Proxy Fst) >> Pop0 Id '(13 % 44,C "x")) () +-- Val (10,"ss",13 % 44) +-- +-- >>> pz @('(Id,PApp (Proxy '(,,)) (Proxy 10) >> PApp Id (Proxy "ss") >> PApp Id (Proxy Fst)) >> Pop0 Snd Fst) (13 % 44,'x') +-- Val (10,"ss",13 % 44) +-- +data PApp p q deriving Show + +instance ( PP p x ~ Proxy (z :: k -> k1) + , PP q x ~ Proxy (w :: k) + ) => P (PApp p q) x where + type PP (PApp p q) x = PAppT (PP p x) (PP q x) + eval _ opts _ = + pure $ mkNode opts (Val Proxy) "PApp" [] + +type family PAppT (p :: Type) (q :: Type) :: Type where + PAppT (Proxy z) (Proxy w) = Proxy (z w) +-- PAppT (Proxy (z :: k -> k1)) (Proxy (w :: k)) = Proxy (z w :: k1) + PAppT p q = + GL.TypeError ( + 'GL.Text "PAppT: requires 'Proxy z' and 'Proxy w' get applied to each other" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + ) + +-- | applies Proxy @p@ to Proxy @q@ and Proxy @r@ and returns a Proxy: needs kind signatures on @p@ +-- +-- >>> pz @(PApp2 (Proxy '(,)) (Proxy 2) (Proxy 'True) >> Pop0 Id ()) () +-- Val (2,True) +-- +-- >>> pz @('(Snd, PApp2 (Proxy (+)) L11 L12) >> Pop0 Snd Fst) ((Proxy @Fst,Proxy @(Length Snd)),(5,"abcdef")) +-- Val 11 +-- +-- >>> pz @(PApp2 (Proxy (+)) Fst Snd >> Pop0 Id ()) (Proxy @(W 3),Proxy @(W 7)) +-- Val 10 +-- +-- >>> pz @(PApp2 Fst Snd Thd >> Pop0 Id ()) (Proxy @(&&&), Proxy @(W "abc"), Proxy @(W 13)) +-- Val ("abc",13) +-- +data PApp2 p q r deriving Show + +instance ( PP p x ~ Proxy (z :: k -> k1 -> k2) + , PP q x ~ Proxy (w :: k) + , PP r x ~ Proxy (v :: k1) + ) => P (PApp2 p q r) x where + type PP (PApp2 p q r) x = PApp2T (PP p x) (PP q x) (PP r x) + eval _ opts _ = + pure $ mkNode opts (Val Proxy) "PApp2" [] + +type family PApp2T (p :: Type) (q :: Type) (r :: Type) :: Type where + PApp2T (Proxy z) (Proxy w) (Proxy v) = Proxy (z w v) + --PApp2T (Proxy (z :: k -> k1 -> k2)) (Proxy (w :: k)) (Proxy (v :: k1)) = Proxy (z w v :: k2) + PApp2T p q r = + GL.TypeError ( + 'GL.Text "PApp2T: requires 'Proxy z', 'Proxy w' and 'Proxy v': z is applied to w and v" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + 'GL.:$$: 'GL.Text " q = " 'GL.:<>: 'GL.ShowType q + 'GL.:$$: 'GL.Text " r = " 'GL.:<>: 'GL.ShowType r + ) + +-- | create a Proxy z from proxy z where z is the expression pointed to by @p@ : Proxify alway returns Val (Proxy @z) +-- +-- >>> pz @(Proxify Fst) ([True],13) ^!? acts . _Val . only (Proxy @Bool) +-- Just () +-- +-- >>> pz @(Proxify (MkJust 1)) () ^!? acts . _Val . to typeRep +-- Just Int +-- +-- >>> pz @(Proxify (FailT [Double] "abc")) () ^!? acts . _Val . to typeRep +-- Just Double +-- +-- >>> pz @(Proxify "abc") () ^!? acts . _Val . to typeRep +-- Just Char +-- +-- >>> eval (Proxy @(Proxify Id)) defOpts ([] @Double) ^!? acts . ttVal . _Val . to typeRep +-- Just Double +-- +-- >>> eval (Proxy @(Proxify Id)) defOpts ([] @Int) ^? _Id . ttVal . _Val == Just (Proxy @Int) +-- True +-- +-- >>> eval (Proxy @(Proxify Id)) defOpts ([] @Int) ^? _Wrapped @(Identity _) . ttVal . _Val == Just (Proxy @Int) +-- True +-- +-- >>> eval (Proxy @(Proxify Id)) defOpts ([] @Int) ^? folded @Identity . ttVal . _Val == Just (Proxy @Int) +-- True +-- +data Proxify p deriving Show + +instance PP p x ~ proxy (z :: k) + => P (Proxify p) x where + type PP (Proxify p) x = ProxifyT (PP p x) + eval _ opts _ = + pure $ mkNode opts (Val Proxy) "Proxify" [] + +type family ProxifyT p where + ProxifyT (_proxy z) = Proxy z + ProxifyT p = GL.TypeError ( + 'GL.Text "ProxifyT: requires any 'proxy z'" + 'GL.:$$: 'GL.Text " p = " 'GL.:<>: 'GL.ShowType p + ) +
src/Predicate/Data/ReadShow.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,35 +12,32 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted read, show, and printf functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted read, show, and printf functions module Predicate.Data.ReadShow ( - + -- ** read-show ShowP , ReadP , ReadP' , ReadMaybe , ReadMaybe' - -- ** print expressions + -- ** print , PrintF - , PrintC , PrintL , PrintT - + , PrintI ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import GHC.TypeLits (Nat,KnownNat) -import qualified GHC.TypeLits as GL -import Data.Proxy +import Predicate.Data.Tuple (ToITuple, ToITupleList, ReverseITuple) +import GHC.TypeLits (Nat) +import Data.Proxy (Proxy(Proxy)) import Data.Kind (Type) -import Text.Printf -import qualified Control.Exception as E -import Data.Typeable +import Text.Printf (PrintfArg, printf, PrintfType) +import Data.Typeable (Typeable) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications @@ -59,15 +50,15 @@ -- | similar to 'show' -- -- >>> pz @(ShowP Id) [4,8,3,9] --- PresentT "[4,8,3,9]" +-- Val "[4,8,3,9]" -- -- >>> pz @(ShowP Id) 'x' --- PresentT "'x'" +-- Val "'x'" -- -- >>> pz @(ShowP (42 -% 10)) 'x' --- PresentT "(-21) % 5" +-- Val "(-21) % 5" -- -data ShowP p +data ShowP p deriving Show instance ( Show (PP p x) , P p x @@ -76,109 +67,106 @@ eval _ opts x = do let msg0 = "ShowP" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " " <> litL opts d <> showVerbose opts " | " p) [hh pp] --- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read -data ReadP' t p +-- | uses the 'Read' of the given type @t@ and @p@ which points to the content to read +data ReadP' t p deriving Show -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 +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 + pure $ case getValueLR NoInline 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 + [(b,"")] -> mkNode opts (Val b) (msg0 <> " " ++ showL opts b) hhs + o -> mkNode opts (Fail (msg0 <> " (" ++ s ++ ")")) (showVerbose opts "" o) hhs --- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read +-- | 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) +-- Val (4 % 5) -- -- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2018-10-12" --- TrueT +-- Val True -- -- >>> pz @(Between (ReadP Day "2017-04-11") (ReadP Day "2018-12-30") (ReadP Day Id)) "2016-10-12" --- FalseT +-- Val False -- -- >>> pl @(ReadP Rational Id) "123 % 4" -- Present 123 % 4 (ReadP Ratio Integer 123 % 4) --- PresentT (123 % 4) +-- Val (123 % 4) -- -- >>> pl @(ReadP Rational Id) "x123 % 4" -- Error ReadP Ratio Integer (x123 % 4) ([]) --- FailT "ReadP Ratio Integer (x123 % 4)" +-- Fail "ReadP Ratio Integer (x123 % 4)" -- -- >>> pl @(ReadP Day Id) "1999-11-30" -- Present 1999-11-30 (ReadP Day 1999-11-30) --- PresentT 1999-11-30 +-- Val 1999-11-30 -- -- >>> pl @(ReadP Day Id) "1999-02-29" -- Error ReadP Day (1999-02-29) ([]) --- FailT "ReadP Day (1999-02-29)" +-- Fail "ReadP Day (1999-02-29)" -- -- >>> pl @(ReadP TimeOfDay Id) "14:59:20" -- Present 14:59:20 (ReadP TimeOfDay 14:59:20) --- PresentT 14:59:20 +-- Val 14:59:20 -- -data ReadP (t :: Type) p +data ReadP (t :: Type) p deriving Show 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 +data ReadMaybe' t p deriving Show -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 +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 + pure $ case getValueLR NoInline 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 + [(b,rest)] -> mkNode opts (Val (Just (b,rest))) (lit3 opts msg1 b "" s) hhs + o -> mkNode opts (Val Nothing) (msg1 <> " failed" <> showVerbose opts " " o) hhs -data ReadMaybe (t :: Type) p +-- | Read but returns the Maybe of the value and any remaining unparsed string +-- +-- >>> pz @(ReadMaybe Int Id) "123x" +-- Val (Just (123,"x")) +-- +-- >>> pz @(ReadMaybe Int Id) "123" +-- Val (Just (123,"")) +-- +-- >>> pz @(ReadMaybe Int Id) "x123" +-- Val Nothing +-- +data ReadMaybe (t :: Type) p deriving Show type ReadMaybeT (t :: Type) p = ReadMaybe' (Hole t) p instance P (ReadMaybeT t p) x => P (ReadMaybe t p) x where @@ -188,57 +176,57 @@ -- | uses PrintF (unsafe) to format output for a single value -- -- >>> pz @(PrintF "value=%03d" Id) 12 --- PresentT "value=012" +-- Val "value=012" -- --- >>> pz @(PrintF "%s" (Fst Id)) ("abc",'x') --- PresentT "abc" +-- >>> pz @(PrintF "%s" Fst) ("abc",'x') +-- Val "abc" -- --- >>> pz @(PrintF "%d" (Fst Id)) ("abc",'x') --- FailT "PrintF (IO e=printf: bad formatting char 'd')" +-- >>> pz @(PrintF "%d" Fst) ("abc",'x') +-- Fail "PrintF (IO e=printf: bad formatting char 'd')" -- --- >>> pl @(PrintF "someval %d" Id) ("!23"::String) +-- >>> pl @(PrintF "someval %d" Id) "!23" -- Error PrintF (IO e=printf: bad formatting char 'd') ("!23" s=someval %d) --- FailT "PrintF (IO e=printf: bad formatting char 'd')" +-- Fail "PrintF (IO e=printf: bad formatting char 'd')" -- --- >>> pl @(PrintF "%-6s" Id) (1234 :: Int) +-- >>> pl @(PrintF "%-6s" Id) 1234 -- Error PrintF (IO e=printf: bad formatting char 's') (1234 s=%-6s) --- FailT "PrintF (IO e=printf: bad formatting char 's')" +-- Fail "PrintF (IO e=printf: bad formatting char 's')" -- --- >>> pl @(PrintF "%06x" Id) (1234 :: Int) +-- >>> pl @(PrintF "%06x" Id) 1234 -- Present "0004d2" (PrintF [0004d2] | p=1234 | s=%06x) --- PresentT "0004d2" +-- Val "0004d2" -- --- >>> pl @(Msg (PrintF "digits=%d" Len) (Head Id)) [1..4] +-- >>> pl @(Msg (PrintF "digits=%d" Len) Head) [1..4] -- Present 1 (digits=4 Head 1 | [1,2,3,4]) --- PresentT 1 +-- Val 1 -- --- >>> pl @(PrintF "ask%%dfas%%kef%05d hey %%" Id) (35 :: Int) +-- >>> pl @(PrintF "ask%%dfas%%kef%05d hey %%" Id) 35 -- Present "ask%dfas%kef00035 hey %" (PrintF [ask%dfas%kef00035 hey %] | p=35 | s=ask%%dfas%%kef%05d hey %%) --- PresentT "ask%dfas%kef00035 hey %" +-- Val "ask%dfas%kef00035 hey %" -- --- >>> pl @(Fail () (PrintF "someval int=%d" Id)) (45 :: Int) --- Error someval int=45 (Fail someval int=45) --- FailT "someval int=45" +-- >>> pl @(Fail () (PrintF "someval int=%d" Id)) 45 +-- Error someval int=45 +-- Fail "someval int=45" -- -data PrintF s p +data PrintF s p deriving Show -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 +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 [] + lrx <- runPQ NoInline 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) + lr <- catchitNF (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] + Left e -> mkNode opts (Fail (msg0 <> " (" <> e <> ")")) (showL opts p <> " s=" <> s) [hh ss, hh pp] + Right ret -> mkNode opts (Val ret) (msg0 <> " [" <> litL opts ret <> "]" <> showVerbose opts " | p=" p <> litVerbose opts " | s=" s) [hh ss, hh pp] -- | uses inductive tuples to replace variable arguments @@ -254,159 +242,149 @@ -- | 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 "%d %s %s %s" '(Fst, Snd, Snd,Snd)) (10,"Asdf") +-- Present "10 Asdf Asdf Asdf" ((>>) "10 Asdf Asdf Asdf" | {PrintI [10 Asdf Asdf Asdf] | s=%d %s %s %s}) +-- Val "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" +-- Present "x 10 Asdf" ((>>) "x 10 Asdf" | {PrintI [x 10 Asdf] | s=%c %d %s}) +-- Val "x 10 Asdf" -- -- >>> pz @(PrintT "fst=%s snd=%03d" Id) ("ab",123) --- PresentT "fst=ab snd=123" +-- Val "fst=ab snd=123" -- -- >>> pz @(PrintT "fst=%s snd=%03d thd=%s" Id) ("ab",123,"xx") --- PresentT "fst=ab snd=123 thd=xx" +-- Val "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 "%s %d %c %s" '(W "xyz", Fst, Snd, Thd)) (123,'x',"ab") +-- Present "xyz 123 x ab" ((>>) "xyz 123 x ab" | {PrintI [xyz 123 x ab] | s=%s %d %c %s}) +-- Val "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)" +-- Error PrintI(IO e=printf: argument list ended prematurely) (PrintI %d %c %s | ('x',(123,()))) +-- Fail "PrintI(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)" +-- Error PrintI(IO e=printf: formatting string ended prematurely) (PrintI %d %c %s | (11,("abc",('x',(123,()))))) +-- Fail "PrintI(IO e=printf: formatting string ended prematurely)" -- --- >>> pl @(PrintT "lhs = %d rhs = %s" Id) (123::Int,"asdf"::String) --- Present "lhs = 123 rhs = asdf" (PrintT [lhs = 123 rhs = asdf] | s=lhs = %d rhs = %s) --- PresentT "lhs = 123 rhs = asdf" +-- >>> pl @(PrintT "lhs = %d rhs = %s" Id) (123,"asdf") +-- Present "lhs = 123 rhs = asdf" ((>>) "lhs = 123 rhs = asdf" | {PrintI [lhs = 123 rhs = asdf] | s=lhs = %d rhs = %s}) +-- Val "lhs = 123 rhs = asdf" -- --- >>> pl @(PrintT "d=%03d s=%s" Id) (9::Int,"ab"::String) --- Present "d=009 s=ab" (PrintT [d=009 s=ab] | s=d=%03d s=%s) --- PresentT "d=009 s=ab" +-- >>> pl @(PrintT "d=%03d s=%s" Id) (9,"ab") +-- Present "d=009 s=ab" ((>>) "d=009 s=ab" | {PrintI [d=009 s=ab] | s=d=%03d s=%s}) +-- Val "d=009 s=ab" -- --- >>> pl @(PrintT "d=%03d s=%s c=%c f=%4.2f" Id) (9::Int,"ab"::String,'x',1.54::Float) --- Present "d=009 s=ab c=x f=1.54" (PrintT [d=009 s=ab c=x f=1.54] | s=d=%03d s=%s c=%c f=%4.2f) --- PresentT "d=009 s=ab c=x f=1.54" +-- >>> pl @(PrintT "d=%03d s=%s c=%c f=%4.2f" Id) (9,"ab",'x',1.54) +-- Present "d=009 s=ab c=x f=1.54" ((>>) "d=009 s=ab c=x f=1.54" | {PrintI [d=009 s=ab c=x f=1.54] | s=d=%03d s=%s c=%c f=%4.2f}) +-- Val "d=009 s=ab c=x f=1.54" -- --- >>> pl @(PrintT "d=%03d s=%s" Id) (9::Int, "ab"::String,'x',1.54::Float) --- Error PrintT(IO e=printf: formatting string ended prematurely) (PrintT d=%03d s=%s) --- FailT "PrintT(IO e=printf: formatting string ended prematurely)" +-- >>> pl @(PrintT "d=%03d s=%s" Id) (9, "ab",'x',1.54) +-- Error PrintI(IO e=printf: formatting string ended prematurely) (PrintI d=%03d s=%s | (1.54,('x',("ab",(9,()))))) +-- Fail "PrintI(IO e=printf: formatting string ended prematurely)" -- --- >>> pl @(PrintT "lhs = %d rhs = %s c=%d" Id) (123::Int,"asdf"::String,'x') --- Present "lhs = 123 rhs = asdf c=120" (PrintT [lhs = 123 rhs = asdf c=120] | s=lhs = %d rhs = %s c=%d) --- PresentT "lhs = 123 rhs = asdf c=120" +-- >>> pl @(PrintT "lhs = %d rhs = %s c=%d" Id) (123,"asdf",'x') +-- Present "lhs = 123 rhs = asdf c=120" ((>>) "lhs = 123 rhs = asdf c=120" | {PrintI [lhs = 123 rhs = asdf c=120] | s=lhs = %d rhs = %s c=%d}) +-- Val "lhs = 123 rhs = asdf c=120" -- --- >>> pl @(PrintT "hello d=%d %c %s" '(12, Char1 "z", "someval")) () --- Present "hello d=12 z someval" (PrintT [hello d=12 z someval] | s=hello d=%d %c %s) --- PresentT "hello d=12 z someval" +-- >>> pl @(PrintT "hello d=%d %c %s" '(12, C "z", "someval")) () +-- Present "hello d=12 z someval" ((>>) "hello d=12 z someval" | {PrintI [hello d=12 z someval] | s=hello d=%d %c %s}) +-- Val "hello d=12 z someval" -- -- >>> pl @(PrintT "ipaddress %03d.%03d.%03d.%03d" '(1,2,3,4)) () --- Present "ipaddress 001.002.003.004" (PrintT [ipaddress 001.002.003.004] | s=ipaddress %03d.%03d.%03d.%03d) --- PresentT "ipaddress 001.002.003.004" +-- Present "ipaddress 001.002.003.004" ((>>) "ipaddress 001.002.003.004" | {PrintI [ipaddress 001.002.003.004] | s=ipaddress %03d.%03d.%03d.%03d}) +-- Val "ipaddress 001.002.003.004" -- -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 +data PrintT s p deriving Show +type PrintTT s p = p >> ToITuple >> ReverseITuple >> PrintI s + +instance P (PrintTT s p) x => P (PrintT s p) x where + type PP (PrintT s p) x = PP (PrintTT s p) x + eval _ = eval (Proxy @(PrintTT s p)) + +-- | prints inductive tuples in reverse order +-- +-- >>> pz @(PrintI "d=%d s=%s f=%f") (1.73,("abc",(12,()))) +-- Val "d=12 s=abc f=1.73" +-- +-- >>> pz @(PrintI "d=%d s=%s f=%f") ("abc",(12,())) +-- Fail "PrintI(IO e=printf: argument list ended prematurely)" +-- +-- >>> pz @(PrintI "d=%s s=%d") ("abc",('x',())) +-- Fail "PrintI(IO e=printf: bad formatting char 's')" +-- +-- >>> pz @(PrintI "%s %s %d") (123,("sss",("bb",()))) +-- Val "bb sss 123" +-- +data PrintI s deriving Show +instance ( PrintC bs + , (b,bs) ~ x + , PrintfArg b + , PP s x ~ String + , P s x + ) => P (PrintI s) x where + type PP (PrintI s) x = String eval _ opts x = do - let msg0 = "PrintT" - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x [] - case lrx of + let msg0 = "PrintI" + ss <- eval (Proxy @s) opts x + case getValueLR NoInline opts msg0 ss [] 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)) + Right s -> do + let hhs = [hh ss] + lr <- catchitNF (prtC @bs s x) 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 - -type family CheckT (tp :: Type) :: Bool where - CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") - CheckT o = 'True - + Left e -> mkNode opts (Fail (msg0 <> "(" <> e <> ")")) (msg0 <> " " <> s) hhs + Right ret -> mkNode opts (Val 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" +-- >>> pl @(PrintL 4 "%s %s %s %s" '[W "xyz", ShowP Fst, ShowP Snd, Thd]) (123,'x',"ab") +-- Present "xyz 123 'x' ab" ((>>) "xyz 123 'x' ab" | {PrintI [xyz 123 'x' ab] | s=%s %s %s %s}) +-- Val "xyz 123 'x' ab" -- --- >>> pz @(PrintL 1 "%05d" '[Id]) 123 -- tick is required for a one element list (use 'PrintF') --- PresentT "00123" +-- >>> pz @(PrintL 1 "%05d" '[Id]) 123 -- tick is required for a one element lis) +-- Val "00123" -- --- >>> pz @(PrintL 2 "%d %05d" [Fst Id,Snd Id]) (29,123) --- PresentT "29 00123" +-- >>> pz @(PrintL 2 "%d %05d" [Fst,Snd]) (29,123) +-- Val "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" +-- Present "first=10 second=11 third=12" ((>>) "first=10 second=11 third=12" | {PrintI [first=10 second=11 third=12] | s=first=%d second=%d third=%d}) +-- Val "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" +-- Error toITupleListC: expected exactly 2 values (ToITupleList(2) instead found 3) +-- Fail "toITupleListC: expected exactly 2 values" -- -- >>> 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" +-- Error toITupleListC: expected exactly 4 values (ToITupleList(4) instead found 3) +-- Fail "toITupleListC: expected exactly 4 values" -- --- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4::Int] --- Present "001.002.003.004" (PrintL(4) [001.002.003.004] | s=%03d.%03d.%03d.%03d) --- PresentT "001.002.003.004" +-- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4] +-- Present "001.002.003.004" ((>>) "001.002.003.004" | {PrintI [001.002.003.004] | s=%03d.%03d.%03d.%03d}) +-- Val "001.002.003.004" -- --- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4,5::Int] --- Error PrintL(4) arg count=5 (wrong length 5) --- FailT "PrintL(4) arg count=5" +-- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4,5] +-- Error toITupleListC: expected exactly 4 values (ToITupleList(4) instead found 5) +-- Fail "toITupleListC: expected exactly 4 values" -- --- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3::Int] --- Error PrintL(4) arg count=3 (wrong length 3) --- FailT "PrintL(4) arg count=3" +-- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3] +-- Error toITupleListC: expected exactly 4 values (ToITupleList(4) instead found 3) +-- Fail "toITupleListC: expected exactly 4 values" -- --- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4::Int] --- Present "001.002.003.004" (PrintL(4) [001.002.003.004] | s=%03d.%03d.%03d.%03d) --- PresentT "001.002.003.004" +-- >>> pl @(PrintL 4 "%03d.%03d.%03d.%03d" Id) [1,2,3,4] +-- Present "001.002.003.004" ((>>) "001.002.003.004" | {PrintI [001.002.003.004] | s=%03d.%03d.%03d.%03d}) +-- Val "001.002.003.004" -- --- >>> pl @(PrintL 4 "%d %4d %-d %03d" Id) [1..4::Int] --- Present "1 2 3 004" (PrintL(4) [1 2 3 004] | s=%d %4d %-d %03d) --- PresentT "1 2 3 004" +-- >>> pl @(PrintL 4 "%d %4d %-d %03d" Id) [1..4] +-- Present "1 2 3 004" ((>>) "1 2 3 004" | {PrintI [1 2 3 004] | s=%d %4d %-d %03d}) +-- Val "1 2 3 004" -- - -data PrintL (n :: Nat) s p +data PrintL (n :: Nat) s p deriving Show +type PrintLT (n :: Nat) s p = p >> ToITupleList n >> ReverseITuple >> PrintI s -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 +instance P (PrintLT n s p) x => P (PrintL n s p) x where + type PP (PrintL n s p) x = PP (PrintLT n s p) x + eval _ = eval (Proxy @(PrintLT n s p))
src/Predicate/Data/Regex.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,14 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted regular expression functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted regular expression functions module Predicate.Data.Regex ( - - -- ** regex expressions Re , Re' , Rescan @@ -46,11 +36,11 @@ , ReplaceFn1 , ReplaceFn2 , ReplaceFn3 - ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import qualified Text.Regex.PCRE.Heavy as RH -- $setup @@ -58,7 +48,6 @@ -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import Safe (readNote) -- >>> import Predicate.Prelude -- >>> import Data.Time @@ -67,108 +56,108 @@ -- -- >>> pl @(Re' '[ 'Caseless, 'Dotall ] "ab" Id) "aB" -- True (Re' ['Caseless, 'Dotall] (ab) | aB) --- TrueT +-- Val True -- -- >>> pl @(Re' '[ 'Caseless, 'Dotall ] "ab." Id) "aB\n" -- True (Re' ['Caseless, 'Dotall] (ab.) | aB -- ) --- TrueT +-- Val True -- -- >>> pl @(Re' '[ 'Caseless ] "ab." Id) "aB\n" -- False (Re' ['Caseless] (ab.) | aB -- ) --- FalseT +-- Val False -- -data Re' (rs :: [ROpt]) p q +data Re' (rs :: [ROpt]) p q deriving Show +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 NoInline 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 msg1 p of + Left (e,e1) -> mkNode opts (Fail e) e1 hhs + Right regex -> + let b = q RH.=~ regex + in mkNodeB opts b (msg1 <> litVerbose opts " | " q) hhs + + -- | runs a regular expression and returns a boolean: see 'RH.=~' -- --- >>> pz @(Re "^\\d{2}:\\d{2}:\\d{2}$" Id) "13:05:25" --- TrueT +-- >>> pz @(Re "^\\d{2}:\\d{2}:\\d{2}$") "13:05:25" +-- Val True -- --- >>> pl @(Re "\\d{4}-\\d{3}" Id) "1234-123" +-- >>> pl @(Re "\\d{4}-\\d{3}") "1234-123" -- True (Re (\d{4}-\d{3}) | 1234-123) --- TrueT +-- Val True -- --- >>> pl @(Re "\\d{4}-\\d{3}" Id) "1234-1x3" +-- >>> pl @(Re "\\d{4}-\\d{3}") "1234-1x3" -- False (Re (\d{4}-\d{3}) | 1234-1x3) --- FalseT +-- Val False -- --- >>> pl @(Re "(?i)ab" Id) "aB" -- runtime [use 'Caseless instead] +-- >>> pl @(Re "(?i)ab") "aB" -- runtime [use 'Caseless instead] -- True (Re ((?i)ab) | aB) --- TrueT +-- Val True -- --- >>> pl @(Re "ab" Id) "aB" +-- >>> pl @(Re "ab") "aB" -- False (Re (ab) | aB) --- FalseT +-- Val False -- --- >>> pl @(Re "^\\d{1,3}(?:\\.\\d{1,3}){3}$" Id) "123.1.1.21" +-- >>> pl @(Re "^\\d{1,3}(?:\\.\\d{1,3}){3}$") "123.1.1.21" -- True (Re (^\d{1,3}(?:\.\d{1,3}){3}$) | 123.1.1.21) --- TrueT +-- Val True -- --- >>> pl @(Guard "regex failed" (Re "^\\d+(?:\\.\\d+)?$" Id) >> ReadP Double Id) "13.345" +-- >>> pl @(Guard "regex failed" (Re "^\\d+(?:\\.\\d+)?$") >> ReadP Double Id) "13.345" -- Present 13.345 ((>>) 13.345 | {ReadP Double 13.345}) --- PresentT 13.345 +-- Val 13.345 -- --- >>> pl @(Guard "regex failed" (Re "^\\d+(?:\\.\\d+)?$" Id) >> ReadP Double Id) "13" +-- >>> pl @(Guard "regex failed" (Re "^\\d+(?:\\.\\d+)?$") >> ReadP Double Id) "13" -- Present 13.0 ((>>) 13.0 | {ReadP Double 13.0}) --- PresentT 13.0 +-- Val 13.0 -- --- >>> pl @(ExitWhen "regex failed" (Not (Re "^\\d+(?:\\.\\d+)?$" Id)) >> ReadP Double Id) "-13.4" --- Error regex failed ((>>) lhs failed) --- FailT "regex failed" +-- >>> pl @(ExitWhen "regex failed" (Not (Re "^\\d+(?:\\.\\d+)?$")) >> ReadP Double Id) "-13.4" +-- Error regex failed (Guard | "-13.4") +-- Fail "regex failed" -- --- >>> pl @(Re "\\d{4}\\" Id) "ayx" +-- >>> pl @(Re "\\d{4}\\") "ayx" -- Error Regex failed to compile (Re (\d{4}\) ([],[]):\ at end of pattern) --- FailT "Regex failed to compile" +-- Fail "Regex failed to compile" -- --- >>> pl @(Re "^\\d+$" Id) "123\nx" +-- >>> pl @(Re "^\\d+$") "123\nx" -- False (Re (^\d+$) | 123 -- x) --- FalseT +-- Val False -- --- >>> pl @(Re "(?m)^\\d+$" Id) "123\nx" -- (?m) anchors match beginning/end of line instead of whole string +-- >>> pl @(Re "(?m)^\\d+$") "123\nx" -- (?m) anchors match beginning/end of line instead of whole string -- True (Re ((?m)^\d+$) | 123 -- x) --- TrueT +-- Val True -- --- >>> pl @(Catch (Re "\\d+(" Id) 'False) "123" +-- >>> pl @(Catch (Re "\\d+(") 'False) "123" -- False (Catch caught exception[Regex failed to compile]) --- FalseT +-- Val False -- --- >>> pl @(Catch (Re "\\d+" Id) 'False) "123" +-- >>> pl @(Catch (Re "\\d+") 'False) "123" -- True (Catch did not fire) --- TrueT +-- Val True -- -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 +data Re p deriving Show +type ReT p = Re' '[] p Id -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)) +instance P (ReT p) x => P (Re p) x where + type PP (Re p) x = PP (ReT p) x + eval _ = evalBool (Proxy @(ReT p)) -- 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 @@ -181,135 +170,135 @@ -- -- >>> pl @(Rescan' '[ 'Anchored ] "([[:xdigit:]]{2})" Id) "wfeb12az" -- Error Regex no results (Rescan' ['Anchored] (([[:xdigit:]]{2})) | "wfeb12az") --- FailT "Regex no results" +-- Fail "Regex no results" -- -data Rescan' (rs :: [ROpt]) p q +-- >>> pz @(Rescan' '[] Snd "13:05:25") ('a',"^(\\d{2}):(\\d{2}):(\\d{2})$") +-- Val [("13:05:25",["13","05","25"])] +-- +data Rescan' (rs :: [ROpt]) p q deriving Show -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Rescan' rs p q) x where +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 [] + lr <- runPQ NoInline 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] + in case compileRegex @rs msg1 p of + Left (e,e1) -> mkNode opts (Fail e) e1 hhs + Right regex -> + case splitAt (oRecursion opts) $ RH.scan regex q of + (b, _:_) -> mkNode opts (Fail ("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 (Fail "Regex no results") (msg1 <> showVerbose opts " | " q) [hh pp, hh qq] + (b, _) -> mkNode opts (Val b) (lit3 opts msg1 b "" q) [hh pp, hh qq] -- | see 'RH.scan' -- --- >>> 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})$") "13:05:25" +-- Val [("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] +-- >>> pz @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" >> L2 Head >> Map (ReadP Int Id)) "13:05:25" +-- Val [13,5,25] -- --- >>> pl @(Rescan "(\\d+)\\D?" Id >> Map (Second (ReadP Int (OneP Id))) Id) "123-444-987" +-- >>> pl @(Rescan "(\\d+)\\D?" >> Map (Second (ReadP Int (OneP)))) "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)] +-- Val [("123-",123),("444-",444),("987",987)] -- --- >>> pl @(Rescan ".(.)" Id) "aBcd" +-- >>> pl @(Rescan ".(.)") "aBcd" -- Present [("aB",["B"]),("cd",["d"])] (Rescan (.(.)) [("aB",["B"]),("cd",["d"])] | aBcd) --- PresentT [("aB",["B"]),("cd",["d"])] +-- Val [("aB",["B"]),("cd",["d"])] -- --- >>> pl @(Rescan "\\d{1,3}(\\.)?" Id) "123.8.99.21" +-- >>> pl @(Rescan "\\d{1,3}(\\.)?") "123.8.99.21" -- Present [("123.",["."]),("8.",["."]),("99.",["."]),("21",[])] (Rescan (\d{1,3}(\.)?) [("123.",["."]),("8.",["."]),("99.",["."]),("21",[])] | 123.8.99.21) --- PresentT [("123.",["."]),("8.",["."]),("99.",["."]),("21",[])] +-- Val [("123.",["."]),("8.",["."]),("99.",["."]),("21",[])] -- --- >>> pl @(Map (Fst Id) (Rescan "." (ShowP Id)) >> Filter (Same "2") Id) 12324 +-- >>> pl @(Map' Fst (Rescan "." << ShowP Id) >> Filter (Same "2") Id) 12324 -- Present ["2","2"] ((>>) ["2","2"] | {Fst ["2","2"] | (["2","2"],["1","3","4"])}) --- PresentT ["2","2"] +-- Val ["2","2"] -- --- >>> pl @(Rescan "(\\d)+?" Id) "1234" +-- >>> pl @(Rescan "(\\d)+?") "1234" -- Present [("1",["1"]),("2",["2"]),("3",["3"]),("4",["4"])] (Rescan ((\d)+?) [("1",["1"]),("2",["2"]),("3",["3"]),("4",["4"])] | 1234) --- PresentT [("1",["1"]),("2",["2"]),("3",["3"]),("4",["4"])] +-- Val [("1",["1"]),("2",["2"]),("3",["3"]),("4",["4"])] -- --- >>> pl @(Rescan "(\\d)+" Id) "1234" +-- >>> pl @(Rescan "(\\d)+") "1234" -- Present [("1234",["4"])] (Rescan ((\d)+) [("1234",["4"])] | 1234) --- PresentT [("1234",["4"])] +-- Val [("1234",["4"])] -- --- >>> pl @(Rescan "(\\d{1,3})(\\.(\\d{1,3}))+?" Id) "1.2.3.4" -- overcapturing +-- >>> pl @(Rescan "(\\d{1,3})(\\.(\\d{1,3}))+?") "1.2.3.4" -- overcapturing -- Present [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] (Rescan ((\d{1,3})(\.(\d{1,3}))+?) [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] | 1.2.3.4) --- PresentT [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] +-- Val [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] -- --- >>> pl @(Rescan "^(\\d)+?$" Id) "1234" +-- >>> pl @(Rescan "^(\\d)+?$") "1234" -- Present [("1234",["4"])] (Rescan (^(\d)+?$) [("1234",["4"])] | 1234) --- PresentT [("1234",["4"])] +-- Val [("1234",["4"])] -- --- >>> pl @(Rescan "(\\d{1,3})(\\.(\\d{1,3}))+?" Id) "1.2.3.4" +-- >>> pl @(Rescan "(\\d{1,3})(\\.(\\d{1,3}))+?") "1.2.3.4" -- Present [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] (Rescan ((\d{1,3})(\.(\d{1,3}))+?) [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] | 1.2.3.4) --- PresentT [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] +-- Val [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])] -- --- >>> pl @(Rescan "(\\d{1,3})(?:\\.(\\d{1,3}))+?" Id) "1.2.3.4" -- bizzare! +-- >>> pl @(Rescan "(\\d{1,3})(?:\\.(\\d{1,3}))+?") "1.2.3.4" -- bizzare! -- Present [("1.2",["1","2"]),("3.4",["3","4"])] (Rescan ((\d{1,3})(?:\.(\d{1,3}))+?) [("1.2",["1","2"]),("3.4",["3","4"])] | 1.2.3.4) --- PresentT [("1.2",["1","2"]),("3.4",["3","4"])] +-- Val [("1.2",["1","2"]),("3.4",["3","4"])] -- --- >>> pl @(Rescan "^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" Id) "1.2.3.4" +-- >>> pl @(Rescan "^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$") "1.2.3.4" -- Present [("1.2.3.4",["1","2","3","4"])] (Rescan (^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$) [("1.2.3.4",["1","2","3","4"])] | 1.2.3.4) --- PresentT [("1.2.3.4",["1","2","3","4"])] +-- Val [("1.2.3.4",["1","2","3","4"])] -- --- >>> pl @(Rescan "([[:xdigit:]]{2})" Id) "wfeb12az" +-- >>> pl @(Rescan "([[:xdigit:]]{2})") "wfeb12az" -- Present [("fe",["fe"]),("b1",["b1"]),("2a",["2a"])] (Rescan (([[:xdigit:]]{2})) [("fe",["fe"]),("b1",["b1"]),("2a",["2a"])] | wfeb12az) --- PresentT [("fe",["fe"]),("b1",["b1"]),("2a",["2a"])] +-- Val [("fe",["fe"]),("b1",["b1"]),("2a",["2a"])] -- -data Rescan p q -type RescanT p q = Rescan' '[] p q +data Rescan p deriving Show +type RescanT p = Rescan' '[] p Id -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)) +instance P (RescanT p) x => P (Rescan p) x where + type PP (Rescan p) x = PP (RescanT p) x + eval _ = eval (Proxy @(RescanT p)) --- | see 'RH.scanRanges' --- --- >>> 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 +data RescanRanges' (rs :: [ROpt]) p q deriving Show -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (RescanRanges' rs p q) x where +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 [] + lr <- runPQ NoInline 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 + in case compileRegex @rs msg1 p of + Left (e,e1) -> mkNode opts (Fail e) e1 hhs 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 + (b, _:_) -> mkNode opts (Fail ("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 + mkNode opts (Fail "Regex no results") (msg1 <> showVerbose opts " | " q) hhs + (b, _) -> mkNode opts (Val b) (lit3 opts msg1 b "" q) hhs -data RescanRanges p q +-- | see 'RH.scanRanges' +-- +-- >>> pz @(RescanRanges "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" +-- Val [((0,8),[(0,2),(3,5),(6,8)])] +-- +data RescanRanges p q deriving Show type RescanRangesT p q = RescanRanges' '[] p q instance P (RescanRangesT p q) x => P (RescanRanges p q) x where @@ -320,98 +309,98 @@ -- -- >>> pl @(Resplit' '[ 'Caseless ] "aBc" Id) "123AbC456abc" -- Present ["123","456",""] (Resplit' ['Caseless] (aBc) ["123","456",""] | 123AbC456abc) --- PresentT ["123","456",""] +-- Val ["123","456",""] -- -data Resplit' (rs :: [ROpt]) p q +-- >>> pz @(Resplit' '[] (Singleton Fst) Snd) (':', "12:13:1") +-- Val ["12","13","1"] +-- +data Resplit' (rs :: [ROpt]) p q deriving Show -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Resplit' rs p q) x where +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 [] + lr <- runPQ NoInline 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 + in case compileRegex @rs msg1 p of + Left (e,e1) -> mkNode opts (Fail e) e1 hhs 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 + (b, _:_) -> mkNode opts (Fail ("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 + mkNode opts (Fail "Regex no results") (msg1 <> showVerbose opts " | " q) hhs + (b, _) -> mkNode opts (Val b) (lit3 opts msg1 b "" q) hhs -- | splits a string on a regex delimiter: see 'RH.split' -- --- >>> 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"] +-- >>> pz @(Resplit "\\.") "141.201.1.22" +-- Val ["141","201","1","22"] -- --- >>> pl @(Resplit "\\." Id) "123.2.3.5.6" +-- >>> pl @(Resplit "\\.") "123.2.3.5.6" -- Present ["123","2","3","5","6"] (Resplit (\.) ["123","2","3","5","6"] | 123.2.3.5.6) --- PresentT ["123","2","3","5","6"] +-- Val ["123","2","3","5","6"] -- --- >>> pl @(Map (ReadP Int Id) (Resplit "\\." Id) >> '(Id, '(Len == 4, All (Between 0 255 Id) Id))) "141.214.125.1.2.3333" +-- >>> pl @(Map' (ReadP Int Id) (Resplit "\\.") >> '(Id, '(Len == 4, All (0 <..> 0xff)))) "141.214.125.1.2.3333" -- Present ([141,214,125,1,2,3333],(False,False)) ((>>) ([141,214,125,1,2,3333],(False,False)) | {'([141,214,125,1,2,3333],(False,False))}) --- PresentT ([141,214,125,1,2,3333],(False,False)) +-- Val ([141,214,125,1,2,3333],(False,False)) -- --- >>> pl @(Map (ReadP Int Id) (Resplit "\\." Id) >> Id &&& ((Len == 4) &&& All (Between 0 255 Id) Id)) "141.214.125.1.2.6" --- Present ([141,214,125,1,2,6],(False,True)) ((>>) ([141,214,125,1,2,6],(False,True)) | {W '([141,214,125,1,2,6],(False,True))}) --- PresentT ([141,214,125,1,2,6],(False,True)) +-- >>> pl @(Map' (ReadP Int Id) (Resplit "\\.") >> Id &&& ((Len == 4) &&& All (0 <..> 0xff))) "141.214.125.1.2.6" +-- Present ([141,214,125,1,2,6],(False,True)) ((>>) ([141,214,125,1,2,6],(False,True)) | {'([141,214,125,1,2,6],(False,True))}) +-- Val ([141,214,125,1,2,6],(False,True)) -- --- >>> pl @(Resplit "\\." Id >> Map (ReadP Int Id) Id >> Id &&& ((Len == 4) &&& All (Between 0 255 Id) Id)) "141.214.125." --- Error ReadP Int () (["141","214","125",""] (>>) rhs failed) --- FailT "ReadP Int ()" +-- >>> pl @(Resplit "\\." >> Map (ReadP Int Id) >> Id &&& ((Len == 4) &&& All (0 <..> 0xff))) "141.214.125." +-- Error ReadP Int () (Map(i=3, a="") excnt=1) +-- Fail "ReadP Int ()" -- -data Resplit p q -type ResplitT p q = Resplit' '[] p q +data Resplit p deriving Show +type ResplitT p = Resplit' '[] p Id -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)) +instance P (ResplitT p) x => P (Resplit p) x where + type PP (Resplit p) x = PP (ResplitT p) x + eval _ = eval (Proxy @(ResplitT p)) --- | replaces regex \'s\' with a string \'s1\' inside the value: see 'RH.sub' and 'RH.gsub' +-- | replaces regex @s@ with a string @s1@ inside the value: see 'RH.sub' and 'RH.gsub' -- -- >>> pz @(ReplaceAllString 'ROverWrite "\\." ":" Id) "141.201.1.22" --- PresentT "141:201:1:22" +-- Val "141:201:1:22" -- -data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r +data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r deriving Show -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 +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 [] + lr <- runPQ NoInline 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 + in case compileRegex @rs msg1 p of + Left (e,e1) -> pure $ mkNode opts (Fail e) e1 hhs Right regex -> do rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of + pure $ case getValueLR NoInline opts msg0 rr hhs of Left e -> e Right r -> let ret :: String @@ -425,99 +414,99 @@ 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]) + in mkNode opts (Val ret) (msg1 <> " " <> litL opts r <> litVerbose opts " | " ret) (hhs <> [hh rr]) -data ReplaceAll' (rs :: [ROpt]) p q r +data ReplaceAll' (rs :: [ROpt]) p q r deriving Show 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 +data ReplaceAll p q r deriving Show 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 +data ReplaceOne' (rs :: [ROpt]) p q r deriving Show 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\' +-- | 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" +-- Val "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})\\)" >> Head >> Snd >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z") "Date(1530144000123+0530)" +-- Val 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{4})\\)" >> Head >> Snd >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z") "Date(1593460089052+0800)" +-- Val 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 +-- >>> pz @(Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" >> Head >> Snd >> (Id !! 0 <> "." <> Id !! 1) >> ParseTimeP ZonedTime "%s%Q%z") "Date(1593460089052+0800)" +-- Val 2020-06-30 03:48:09.052 +0800 -- -data ReplaceOne p q r +data ReplaceOne p q r deriving Show 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\' +-- | 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" +-- Val "123def456def" -- -- >>> pl @(ReplaceAllString' '[] 'ROverWrite "abc" "def" Id) "123AbC456abc" -- Present "123AbC456def" (ReplaceAll (abc) 123AbC456abc | 123AbC456def) --- PresentT "123AbC456def" +-- Val "123AbC456def" -- -- >>> pl @(ReplaceAllString' '[ 'Caseless ] 'ROverWrite "abc" "def" Id) "123AbC456abc" -- Present "123def456def" (ReplaceAll' ['Caseless] (abc) 123AbC456abc | 123def456def) --- PresentT "123def456def" +-- Val "123def456def" -- -- >>> pl @(ReplaceAllString 'RPrepend "abc" "def" Id) "123AbC456abc" -- Present "123AbC456defabc" (ReplaceAll (abc) 123AbC456abc | 123AbC456defabc) --- PresentT "123AbC456defabc" +-- Val "123AbC456defabc" -- -- >>> pl @(ReplaceAllString 'ROverWrite "abc" "def" Id) "123AbC456abc" -- Present "123AbC456def" (ReplaceAll (abc) 123AbC456abc | 123AbC456def) --- PresentT "123AbC456def" +-- Val "123AbC456def" -- -- >>> pl @(ReplaceAllString 'RAppend "abc" "def" Id) "123AbC456abc" -- Present "123AbC456abcdef" (ReplaceAll (abc) 123AbC456abc | 123AbC456abcdef) --- PresentT "123AbC456abcdef" +-- Val "123AbC456abcdef" -- -data ReplaceAllString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r +data ReplaceAllString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r deriving Show 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 +data ReplaceAllString o p q r deriving Show 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 +data ReplaceOneString' (rs :: [ROpt]) (o :: ReplaceFnSub) p q r deriving Show 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 +data ReplaceOneString (o :: ReplaceFnSub) p q r deriving Show 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 @@ -526,37 +515,39 @@ -- | Simple replacement string: see 'ReplaceAllString' and 'ReplaceOneString' -- -data ReplaceFn (o :: ReplaceFnSub) p +data ReplaceFn (o :: ReplaceFnSub) p deriving Show -instance (GetReplaceFnSub r - , PP p x ~ String - , P p x) => P (ReplaceFn r p) x where +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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val 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 +data ReplaceFn1 p deriving Show -instance (PP p x ~ (String -> [String] -> String) - , P p x) => P (ReplaceFn1 p) x where +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 + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e - Right f -> mkNode opts (PresentT (RReplace1 f)) msg0 [hh pp] + Right f -> mkNode opts (Val (RReplace1 f)) msg0 [hh pp] -- | A replacement function @(String -> String)@ that yields the whole match -- Used by 'RH.sub' and 'RH.gsub' @@ -564,20 +555,21 @@ -- 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" +-- >>> pz @(ReplaceAll "\\." (ReplaceFn2 Fst) Snd) (\x -> x <> ":" <> x, "141.201.1.22") +-- Val "141.:.201.:.1.:.22" -- -data ReplaceFn2 p +data ReplaceFn2 p deriving Show -instance (PP p x ~ (String -> String) - , P p x) => P (ReplaceFn2 p) x where +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 + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e - Right f -> mkNode opts (PresentT (RReplace2 f)) msg0 [hh pp] + Right f -> mkNode opts (Val (RReplace2 f)) msg0 [hh pp] -- | A replacement function @([String] -> String)@ which yields the groups -- Used by 'RH.sub' and 'RH.gsub' @@ -586,17 +578,18 @@ -- -- >>> :m + Text.Show.Functions -- >>> import Data.List (intercalate) --- >>> 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" +-- >>> pz @(ReplaceAll "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" (ReplaceFn3 Fst) Snd) (\ys -> intercalate " | " $ map (show . succ . readNote @Int "invalid int") ys, "141.201.1.22") +-- Val "142 | 202 | 2 | 23" -- -data ReplaceFn3 p +data ReplaceFn3 p deriving Show -instance (PP p x ~ ([String] -> String) - , P p x) => P (ReplaceFn3 p) x where +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 + pure $ case getValueLR NoInline opts msg0 pp [] of Left e -> e - Right f -> mkNode opts (PresentT (RReplace3 f)) msg0 [hh pp] + Right f -> mkNode opts (Val (RReplace3 f)) msg0 [hh pp]
src/Predicate/Data/String.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -19,11 +13,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted String functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted String functions module Predicate.Data.String ( TrimBoth , TrimL @@ -31,28 +23,29 @@ , StripR , StripL - , IsPrefix - , IsInfix - , IsSuffix - , IsPrefixI - , IsInfixI - , IsSuffixI + , IsPrefixC + , IsInfixC + , IsSuffixC + , IsPrefixCI + , IsInfixCI + , IsSuffixCI , ToString , FromString , FromString' ) where import Predicate.Core +import Predicate.Misc import Predicate.Util import qualified GHC.TypeLits as GL -import Control.Lens hiding (iall) -import Data.List +import Control.Lens +import Data.List (dropWhileEnd, isInfixOf, isPrefixOf, isSuffixOf) import qualified Data.Text.Lens as DTL -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import Data.Kind (Type) -import Data.String -import Data.Char -import Data.Function +import Data.String (IsString(..)) +import Data.Char (isSpace, toLower) +import Data.Function (on) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Text as T @@ -63,124 +56,93 @@ -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings --- >>> :set -XNoOverloadedLists -- >>> import qualified Data.Text as T -- >>> import Predicate.Prelude -- >>> import qualified Data.Sequence as Seq --- | 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 +data TrimImpl (left :: Bool) (right :: Bool) deriving Show -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 +instance ( FailUnlessT (OrT l r) + ('GL.Text "TrimImpl: left and right cannot both be False") + , GetBool l + , GetBool r + , DTL.IsText x + ) => P (TrimImpl l r) x where + type PP (TrimImpl l r) x = x + eval _ opts x = 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] + p = view DTL.unpacked x + fl = if l then dropWhile isSpace else id + fr = if r then dropWhileEnd isSpace else id + b = (fl . fr) p + in pure $ mkNode opts (Val (b ^. DTL.packed)) (msg0 <> litL opts b <> litVerbose opts " | " p) [] -- | similar to 'T.stripStart' -- --- >>> pz @(TrimL (Snd Id)) (20," abc ") --- PresentT "abc " +-- >>> pz @(Snd >> TrimL) (20," abc ") +-- Val "abc " -- -data TrimL p -type TrimLT p = TrimImpl 'True 'False p +data TrimL deriving Show +type TrimLT = TrimImpl 'True 'False -instance P (TrimLT p) x => P (TrimL p) x where - type PP (TrimL p) x = PP (TrimLT p) x - eval _ = eval (Proxy @(TrimLT p)) +instance P TrimLT x => P TrimL x where + type PP TrimL x = PP TrimLT x + eval _ = eval (Proxy @TrimLT) -- | similar to 'T.stripEnd' -- --- >>> pz @(TrimR (Snd Id)) (20," abc ") --- PresentT " abc" +-- >>> pz @(Snd >> TrimR) (20," abc ") +-- Val " abc" -- --- >>> pz @(TrimR " abc ") () --- PresentT " abc" +-- >>> pz @(" abc " >> TrimR) () +-- Val " abc" -- --- >>> pz @(TrimR "") () --- PresentT "" +-- >>> pz @("" >> TrimR) () +-- Val "" -- -data TrimR p -type TrimRT p = TrimImpl 'False 'True p +data TrimR deriving Show +type TrimRT = TrimImpl 'False 'True -instance P (TrimRT p) x => P (TrimR p) x where - type PP (TrimR p) x = PP (TrimRT p) x - eval _ = eval (Proxy @(TrimRT p)) +instance P TrimRT x => P TrimR x where + type PP TrimR x = PP TrimRT x + eval _ = eval (Proxy @TrimRT) -- | similar to 'T.strip' -- --- >>> pz @(TrimBoth (Snd Id)) (20," abc " :: String) --- PresentT "abc" +-- >>> pz @(Snd >> TrimBoth) (20," abc ") +-- Val "abc" -- --- >>> pz @(TrimBoth (Snd Id)) (20,T.pack " abc ") --- PresentT "abc" +-- >>> pz @(Snd >> TrimBoth) (20,T.pack " abc ") +-- Val "abc" -- --- >>> pz @(TrimBoth " ") () --- PresentT "" +-- >>> pz @(" " >> TrimBoth) () +-- Val "" -- --- >>> pz @(TrimBoth "") () --- PresentT "" +-- >>> pz @("" >> TrimBoth) () +-- Val "" -- -data TrimBoth p -type TrimBothT p = TrimImpl 'True 'True p +data TrimBoth deriving Show +type TrimBothT = TrimImpl 'True 'True -instance P (TrimBothT p) x => P (TrimBoth p) x where - type PP (TrimBoth p) x = PP (TrimBothT p) x - eval _ = eval (Proxy @(TrimBothT p)) +instance P TrimBothT x => P TrimBoth x where + type PP TrimBoth x = PP TrimBothT x + eval _ = eval (Proxy @TrimBothT) -data StripImpl(left :: Bool) p q +data StripImpl(left :: Bool) p q deriving Show -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 +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 [] + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] pure $ case lr of Left e -> e Right (p,view DTL.unpacked -> q,pp,qq) -> @@ -190,20 +152,20 @@ 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] + in mkNode opts (Val (fmap (view DTL.packed) b)) (msg0 <> showL opts b <> litVerbose opts " | p=" p <> litVerbose opts " | q=" q) [hh pp, hh qq] -- | similar to 'T.stripLeft' -- --- >>> pz @(StripL "xyz" Id) ("xyzHello" :: String) --- PresentT (Just "Hello") +-- >>> pz @(StripL "xyz" Id) "xyzHello" +-- Val (Just "Hello") -- -- >>> pz @(StripL "xyz" Id) (T.pack "xyzHello") --- PresentT (Just "Hello") +-- Val (Just "Hello") -- -- >>> pz @(StripL "xyz" Id) "xywHello" --- PresentT Nothing +-- Val Nothing -- -data StripL p q +data StripL p q deriving Show type StripLT p q = StripImpl 'True p q instance P (StripLT p q) x => P (StripL p q) x where @@ -213,173 +175,157 @@ -- | similar to 'T.stripRight' -- -- >>> pz @(StripR "xyz" Id) "Hello xyz" --- PresentT (Just "Hello ") +-- Val (Just "Hello ") -- -- >>> pz @(StripR "xyz" Id) "xyzHelloxyw" --- PresentT Nothing +-- Val Nothing -- -- >>> pz @(StripR "xyz" Id) "" --- PresentT Nothing +-- Val Nothing -- -- >>> pz @(StripR "xyz" "xyz") () --- PresentT (Just "") +-- Val (Just "") -- -data StripR p q +data StripR p q deriving Show 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)) --- | 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 +data IsFixImplC (cmp :: Ordering) (ignore :: Bool) p q deriving Show -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 +instance ( GetBool ignore + , P p x + , P q x + , PP p x ~ String + , PP q x ~ String + , GetOrdering cmp + ) => P (IsFixImplC cmp ignore p q) x where + type PP (IsFixImplC 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] + LT -> (isPrefixOf, "IsPrefixC") + EQ -> (isInfixOf, "IsInfixC") + GT -> (isSuffixOf, "IsSuffixC") + lr <- runPQ NoInline msg0 (Proxy @p) (Proxy @q) opts x [] + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> (if ignore then "I" else "") <> " | " <> p + in mkNodeB opts (on ff lwr p q) (msg1 <> " " <> litL opts q) [hh pp, hh qq] + -- | similar to 'isPrefixOf' for strings -- --- >>> pl @(IsPrefix "xy" Id) "xyzabw" --- True (IsPrefix(xy) xyzabw) --- TrueT +-- >>> pl @(IsPrefixC "xy" Id) "xyzabw" +-- True (IsPrefixC | xy xyzabw) +-- Val True -- --- >>> pl @(IsPrefix "ab" Id) "xyzbaw" --- False (IsPrefix(ab) xyzbaw) --- FalseT +-- >>> pl @(IsPrefixC "ab" Id) "xyzbaw" +-- False (IsPrefixC | ab xyzbaw) +-- Val False -- -data IsPrefix p q -type IsPrefixT p q = IsFixImpl 'LT 'False p q +-- >>> pz @(IsPrefixC "abc" "aBcbCd") () +-- Val False +-- +data IsPrefixC p q deriving Show +type IsPrefixCT p q = IsFixImplC '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)) +instance P (IsPrefixCT p q) x => P (IsPrefixC p q) x where + type PP (IsPrefixC p q) x = PP (IsPrefixCT p q) x + eval _ = evalBool (Proxy @(IsPrefixCT p q)) -- | similar to 'isInfixOf' for strings -- --- >>> pl @(IsInfix "ab" Id) "xyzabw" --- True (IsInfix(ab) xyzabw) --- TrueT +-- >>> pl @(IsInfixC "ab" Id) "xyzabw" +-- True (IsInfixC | ab xyzabw) +-- Val True -- --- >>> pl @(IsInfix "aB" Id) "xyzAbw" --- False (IsInfix(aB) xyzAbw) --- FalseT +-- >>> pl @(IsInfixC "aB" Id) "xyzAbw" +-- False (IsInfixC | aB xyzAbw) +-- Val False -- --- >>> pl @(IsInfix "ab" Id) "xyzbaw" --- False (IsInfix(ab) xyzbaw) --- FalseT +-- >>> pl @(IsInfixC "ab" Id) "xyzbaw" +-- False (IsInfixC | ab xyzbaw) +-- Val False -- --- >>> pl @(IsInfix (Fst Id) (Snd Id)) ("ab","xyzabw") --- True (IsInfix(ab) xyzabw) --- TrueT +-- >>> pl @(IsInfixC Fst Snd) ("ab","xyzabw") +-- True (IsInfixC | ab xyzabw) +-- Val True -- - -data IsInfix p q -type IsInfixT p q = IsFixImpl 'EQ 'False p q +data IsInfixC p q deriving Show +type IsInfixCT p q = IsFixImplC '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)) +instance P (IsInfixCT p q) x => P (IsInfixC p q) x where + type PP (IsInfixC p q) x = PP (IsInfixCT p q) x + eval _ = evalBool (Proxy @(IsInfixCT p q)) -- | similar to 'isSuffixOf' for strings -- --- >>> pl @(IsSuffix "bw" Id) "xyzabw" --- True (IsSuffix(bw) xyzabw) --- TrueT +-- >>> pl @(IsSuffixC "bw" Id) "xyzabw" +-- True (IsSuffixC | bw xyzabw) +-- Val True -- --- >>> pl @(IsSuffix "bw" Id) "xyzbaw" --- False (IsSuffix(bw) xyzbaw) --- FalseT +-- >>> pl @(IsSuffixC "bw" Id) "xyzbaw" +-- False (IsSuffixC | bw xyzbaw) +-- Val False -- -data IsSuffix p q -type IsSuffixT p q = IsFixImpl 'GT 'False p q +-- >>> pz @(IsSuffixC "bCd" "aBcbCd") () +-- Val True +-- +data IsSuffixC p q deriving Show +type IsSuffixCT p q = IsFixImplC '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)) +instance P (IsSuffixCT p q) x => P (IsSuffixC p q) x where + type PP (IsSuffixC p q) x = PP (IsSuffixCT p q) x + eval _ = evalBool (Proxy @(IsSuffixCT p q)) -- | similar to case insensitive 'isPrefixOf' for strings -- -data IsPrefixI p q -type IsPrefixIT p q = IsFixImpl 'LT 'True p q +-- >>> pz @(IsPrefixCI "abc" "aBcbCd") () +-- Val True +-- +data IsPrefixCI p q deriving Show +type IsPrefixCIT p q = IsFixImplC '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)) +instance P (IsPrefixCIT p q) x => P (IsPrefixCI p q) x where + type PP (IsPrefixCI p q) x = PP (IsPrefixCIT p q) x + eval _ = evalBool (Proxy @(IsPrefixCIT p q)) -- | similar to case insensitive 'isInfixOf' for strings -- --- >>> pl @(IsInfixI "aB" Id) "xyzAbw" --- True (IsInfixI(aB) xyzAbw) --- TrueT +-- >>> pl @(IsInfixCI "aB" Id) "xyzAbw" +-- True (IsInfixCI | aB xyzAbw) +-- Val True -- -data IsInfixI p q -type IsInfixIT p q = IsFixImpl 'EQ 'True p q +-- >>> pz @(IsInfixCI "abc" "axAbCd") () +-- Val True +-- +data IsInfixCI p q deriving Show +type IsInfixCIT p q = IsFixImplC '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)) +instance P (IsInfixCIT p q) x => P (IsInfixCI p q) x where + type PP (IsInfixCI p q) x = PP (IsInfixCIT p q) x + eval _ = evalBool (Proxy @(IsInfixCIT p q)) -- | similar to case insensitive 'isSuffixOf' for strings -- -data IsSuffixI p q -type IsSuffixIT p q = IsFixImpl 'GT 'True p q +data IsSuffixCI p q deriving Show +type IsSuffixCIT p q = IsFixImplC '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)) +instance P (IsSuffixCIT p q) x => P (IsSuffixCI p q) x where + type PP (IsSuffixCI p q) x = PP (IsSuffixCIT p q) x + eval _ = evalBool (Proxy @(IsSuffixCIT 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] +data ToString deriving Show +instance ToStringC x => P ToString x where + type PP ToString x = String + eval _ opts x = pure $ mkNode opts (Val (toStringC x)) "ToString" [] class ToStringC a where toStringC :: a -> String @@ -394,33 +340,33 @@ instance ToStringC BS8.ByteString where toStringC = BS8.unpack --- | 'fromString' function where you need to provide the type \'t\' of the result -data FromString' t s +-- | 'fromString' function where you need to provide the type @t@ of the result +data FromString' t s deriving Show -instance (P s a - , PP s a ~ String - , Show (PP t a) - , IsString (PP t a) - ) => P (FromString' t s) a where +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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val b) (msg0 <> " " <> showL opts b) [hh ss] --- | 'fromString' function where you need to provide the type \'t\' of the result +-- | 'fromString' function where you need to provide the type @t@ of the result -- -- >>> pz @(FromString (Identity _) Id) "abc" --- PresentT (Identity "abc") +-- Val (Identity "abc") -- -- >>> pz @(FromString (Seq.Seq Char) Id) "abc" --- PresentT (fromList "abc") +-- Val (fromList "abc") -- -data FromString (t :: Type) p +data FromString (t :: Type) p deriving Show type FromStringPT (t :: Type) p = FromString' (Hole t) p instance P (FromStringPT t p) x => P (FromString t p) x where
src/Predicate/Data/These.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,11 +12,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted 'These' functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted 'These' functions module Predicate.Data.These ( -- ** boolean predicates IsThis @@ -63,8 +55,9 @@ ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) import Data.Kind (Type) import Data.These (partitionThese, These(..)) import qualified Data.These.Combinators as TheseC @@ -81,17 +74,17 @@ -- | 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)]) +-- Val ("ac",[2,4,99],[('z',1),('a',2)]) -- -- >>> pl @PartitionThese [This 4, That 'x', That 'y',These 3 'b', This 99, These 5 'x'] -- Present ([4,99],"xy",[(3,'b'),(5,'x')]) (PartitionThese ([4,99],"xy",[(3,'b'),(5,'x')]) | [This 4,That 'x',That 'y',These 3 'b',This 99,These 5 'x']) --- PresentT ([4,99],"xy",[(3,'b'),(5,'x')]) +-- Val ([4,99],"xy",[(3,'b'),(5,'x')]) -- -- >>> pl @PartitionThese [This 1,That 'x',This 4,That 'y',These 9 'z',This 10,These 8 'y'] -- Present ([1,4,10],"xy",[(9,'z'),(8,'y')]) (PartitionThese ([1,4,10],"xy",[(9,'z'),(8,'y')]) | [This 1,That 'x',This 4,That 'y',These 9 'z',This 10,These 8 'y']) --- PresentT ([1,4,10],"xy",[(9,'z'),(8,'y')]) +-- Val ([1,4,10],"xy",[(9,'z'),(8,'y')]) -- -data PartitionThese +data PartitionThese deriving Show instance ( Show a , Show b @@ -100,21 +93,21 @@ eval _ opts as = let msg0 = "PartitionThese" b = partitionThese as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + in pure $ mkNode opts (Val b) (show3 opts msg0 b as) [] -- | similar to 'TheseC.catThis' -- -- >>> pz @(Thiss) [That 1, This 'a', These 'b' 33, This 'd', That 4] --- PresentT "ad" +-- Val "ad" -- -- >>> pz @(Thiss) [That 1, This 'a', These 'b' 33] --- PresentT "a" +-- Val "a" -- -- >>> pz @(Thiss) [That 1, That 9, These 1 33] --- PresentT [] +-- Val [] -- -data Thiss -type ThissT = Fst PartitionThese +data Thiss deriving Show +type ThissT = PartitionThese >> Fst instance P ThissT x => P Thiss x where type PP Thiss x = PP ThissT x @@ -123,11 +116,11 @@ -- | similar to 'TheseC.catThat' -- -- >>> pl @Thats [This 1, This 10,That 'x', This 99, That 'y'] --- Present "xy" (Snd "xy" | ([1,10,99],"xy",[])) --- PresentT "xy" +-- Present "xy" ((>>) "xy" | {Snd "xy" | ([1,10,99],"xy",[])}) +-- Val "xy" -- -data Thats -type ThatsT = Snd PartitionThese +data Thats deriving Show +type ThatsT = PartitionThese >> Snd instance P ThatsT x => P Thats x where type PP Thats x = PP ThatsT x @@ -135,11 +128,11 @@ -- | similar to 'TheseC.catThese' -- --- >>> pz @(ZipThese Id (Tail Id) >> Theses) [1..10] --- PresentT [(1,2),(2,3),(3,4),(4,5),(5,6),(6,7),(7,8),(8,9),(9,10)] +-- >>> pz @(ZipThese Id Tail >> Theses) [1..10] +-- Val [(1,2),(2,3),(3,4),(4,5),(5,6),(6,7),(7,8),(8,9),(9,10)] -- -data Theses -type ThesesT = Thd PartitionThese +data Theses deriving Show +type ThesesT = PartitionThese >> Thd instance P ThesesT x => P Theses x where type PP Theses x = PP ThesesT x @@ -147,10 +140,10 @@ -- | similar to 'TheseC.catHere' -- --- >>> pz @(ZipThese Id (Tail Id) >> Heres) [1..10] --- PresentT [1,2,3,4,5,6,7,8,9,10] +-- >>> pz @(ZipThese Id Tail >> Heres) [1..10] +-- Val [1,2,3,4,5,6,7,8,9,10] -- -data Heres +data Heres deriving Show instance ( Show a , Show b @@ -159,14 +152,14 @@ eval _ opts as = let msg0 = "Heres" b = TheseC.catHere as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + in pure $ mkNode opts (Val b) (show3 opts msg0 b as) [] -- | similar to 'TheseC.catThere' -- --- >>> pz @(ZipThese Id (Tail Id) >> Theres) [1..10] --- PresentT [2,3,4,5,6,7,8,9,10] +-- >>> pz @(ZipThese Id Tail >> Theres) [1..10] +-- Val [2,3,4,5,6,7,8,9,10] -- -data Theres +data Theres deriving Show instance ( Show a , Show b @@ -175,127 +168,114 @@ eval _ opts as = let msg0 = "Theres" b = TheseC.catThere as - in pure $ mkNode opts (PresentT b) (show01 opts msg0 b as) [] + in pure $ mkNode opts (Val b) (show3 opts msg0 b as) [] --- | similar to 'Data.These.mergeTheseWith' but additionally provides \'p\', \'q\' and \'r\' the original input as the first element in the tuple +-- | 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 ((L11 + Snd) >> ShowP Id) (ShowP Id) L22 Snd) (9,This 123) +-- Val "132" -- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (This 123) --- PresentT (123,"fromthis") +-- >>> pz @(TheseX '(Snd,"fromthis") '(Negate 99,Snd) Snd Id) (This 123) +-- Val (123,"fromthis") -- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (That "fromthat") --- PresentT (-99,"fromthat") +-- >>> pz @(TheseX '(Snd,"fromthis") '(Negate 99,Snd) Snd Id) (That "fromthat") +-- Val (-99,"fromthat") -- --- >>> pz @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (These 123 "fromthese") --- PresentT (123,"fromthese") +-- >>> pz @(TheseX '(Snd,"fromthis") '(Negate 99,Snd) Snd Id) (These 123 "fromthese") +-- Val (123,"fromthese") -- --- >>> pl @(TheseX (PrintF "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (PrintT "a=%d b=%s" (Snd Id)) Id) (These @Int 9 "rhs") +-- >>> pl @(TheseX (PrintF "a=%d" (Snd >> Succ)) ("b=" <> Snd) (PrintT "a=%d b=%s" Snd) Id) (These @Int 9 "rhs") -- Present "a=9 b=rhs" (TheseX(These)) --- PresentT "a=9 b=rhs" +-- Val "a=9 b=rhs" -- --- >>> pl @(TheseX (PrintF "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (PrintT "a=%d b=%s" (Snd Id)) Id) (This @Int 9) +-- >>> pl @(TheseX (PrintF "a=%d" (Snd >> Succ)) ("b=" <> Snd) (PrintT "a=%d b=%s" Snd) Id) (This @Int 9) -- Present "a=10" (TheseX(This)) --- PresentT "a=10" +-- Val "a=10" -- --- >>> pl @(TheseX (PrintF "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (PrintT "a=%d b=%s" (Snd Id)) Id) (That @Int "rhs") +-- >>> pl @(TheseX (PrintF "a=%d" (Snd >> Succ)) ("b=" <> Snd) (PrintT "a=%d b=%s" Snd) Id) (That @Int "rhs") -- Present "b=rhs" (TheseX(That)) --- PresentT "b=rhs" +-- Val "b=rhs" -- -data TheseX p q r s +data TheseX p q r s deriving Show -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 +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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline opts msg1 pp [hh ss] of Left e -> e - Right _ -> mkNode opts (_tBool pp) msg1 [hh ss, hh pp] + Right _ -> mkNodeCopy opts 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 + pure $ case getValueLR NoInline opts msg1 qq [hh ss] of Left e -> e - Right _ -> mkNode opts (_tBool qq) msg1 [hh ss, hh qq] + Right _ -> mkNodeCopy opts 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 + pure $ case getValueLR NoInline opts msg1 rr [hh ss] of Left e -> e - Right _ -> mkNode opts (_tBool rr) msg1 [hh ss, hh rr] + Right _ -> mkNodeCopy opts rr msg1 [hh ss, hh rr] type family TheseXT lr x p where - TheseXT (These a b) x p = PP p (x,a) + TheseXT (These a _b) x p = PP p (x,a) -- | 'Data.These.This' constructor -- --- >>> pz @(MkThis _ Id) 44 --- PresentT (This 44) --- --- >>> pz @(Proxy Int >> MkThis' Unproxy 10) [] --- PresentT (This 10) +-- >>> pz @(Proxy Int >> MkThis' UnproxyT 10) [] +-- Val (This 10) -- -data MkThis' t p +data MkThis' t p deriving Show -instance ( Show (PP p x) - , P p x +instance ( P p x + , Show (PP 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 + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " This " <> showL opts p) [hh pp] -- | 'Data.These.This' constructor -- -- >>> pl @(MkThis () Id) 'x' -- Present This 'x' (MkThis This 'x') --- PresentT (This 'x') +-- Val (This 'x') -- --- >>> pl @(MkThis () (Fst Id)) ('x',True) +-- >>> pl @(MkThis () Fst) ('x',True) -- Present This 'x' (MkThis This 'x') --- PresentT (This 'x') +-- Val (This 'x') -- - -data MkThis (t :: Type) p +-- >>> pz @(MkThis _ Id) 44 +-- Val (This 44) +-- +data MkThis (t :: Type) p deriving Show 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) --- --- >>> pz @(MkThat _ "Abc" <> MkThis _ '[1,2] <> MkThese [3,4] "def") () --- PresentT (These [1,2,3,4] "Abcdef") --- --- >>> pl @(MkThat () Id) 'x' --- Present That 'x' (MkThat That 'x') --- PresentT (That 'x') --- -data MkThat' t p +data MkThat' t p deriving Show instance ( Show (PP p x) , P p x @@ -304,13 +284,25 @@ eval _ opts x = do let msg0 = "MkThat" pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of + pure $ case getValueLR NoInline 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] + in mkNode opts (Val d) (msg0 <> " That " <> showL opts p) [hh pp] -data MkThat (t :: Type) p +-- | 'Data.These.That' constructor +-- +-- >>> pz @(MkThat _ Id) 44 +-- Val (That 44) +-- +-- >>> pz @(MkThat _ "Abc" <> MkThis _ '[1,2] <> MkThese [3,4] "def") () +-- Val (These [1,2,3,4] "Abcdef") +-- +-- >>> pl @(MkThat () Id) 'x' +-- Present That 'x' (MkThat That 'x') +-- Val (That 'x') +-- +data MkThat (t :: Type) p deriving Show type MkThatT (t :: Type) p = MkThat' (Hole t) p instance P (MkThatT t p) x => P (MkThat t p) x where @@ -322,154 +314,152 @@ -- | 'Data.These.These' constructor -- --- >>> pz @(MkThese (Fst Id) (Snd Id)) (44,'x') --- PresentT (These 44 'x') +-- >>> pz @(MkThese Fst Snd) (44,'x') +-- Val (These 44 'x') -- -- >>> pl @(MkThese Id 'True) 'x' -- Present These 'x' True (MkThese These 'x' True) --- PresentT (These 'x' True) +-- Val (These 'x' True) -- -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 +data MkThese p q deriving Show +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 [] + lr <- runPQ NoInline 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] + in mkNode opts (Val d) (msg0 <> " " <> showL opts d) [hh pp, hh qq] --- | predicate on 'These' +data IsTh (th :: These x y) deriving Show +-- x y can be anything + +-- trying to avoid Show instance cos of ambiguities +instance ( x ~ These a b + , Show a + , Show b + , GetThese th + ) => P (IsTh (th :: These x1 x2)) x where + type PP (IsTh th) x = Bool + eval _ opts x = + let msg0 = "Is" + (t,f) = getThese @th + b = f x + in pure $ mkNodeB opts b (msg0 <> t <> showVerbose opts " | " x) [] + +-- | predicate on 'Data.These.This' -- --- >>> pz @(IsThis Id) (This "aBc") --- TrueT +-- >>> pz @IsThis (This "aBc") +-- Val True -- --- >>> pz @(IsThis Id) (These 1 'a') --- FalseT +-- >>> pz @IsThis (These 1 'a') +-- Val False -- --- >>> pz @(IsThese Id) (These 1 'a') --- TrueT +-- >>> pl @IsThis (This 12) +-- True (IsThis | This 12) +-- Val True -- --- >>> pl @(IsThat Id) (This 12) +data IsThis deriving Show +type IsThisT = IsTh ('This '()) + +instance P IsThisT x => P IsThis x where + type PP IsThis x = PP IsThisT x + eval _ = evalBool (Proxy @IsThisT) + +-- | predicate on 'Data.These.That' +-- +-- >>> pl @IsThat (This 12) -- False (IsThat | This 12) --- FalseT +-- Val False -- --- >>> pl @(IsThis Id) (This 12) --- True (IsThis | This 12) --- TrueT +data IsThat deriving Show +type IsThatT = IsTh ('That '()) + +instance P IsThatT x => P IsThat x where + type PP IsThat x = PP IsThatT x + eval _ = evalBool (Proxy @IsThatT) + +-- | predicate on 'Data.These.These' -- --- >>> pl @(IsThese Id) (This 12) +-- >>> pl @IsThese (This 12) -- False (IsThese | This 12) --- FalseT +-- Val False -- --- >>> pl @(IsThese Id) (These 'x' 12) +-- >>> pz @IsThese (These 1 'a') +-- Val True +-- +-- >>> pl @IsThese (These 'x' 12) -- True (IsThese | These 'x' 12) --- TrueT +-- Val True -- --- >>> pl @(IsThese Id) (That (SG.Sum 12)) +-- >>> pl @IsThese (That (SG.Sum 12)) -- False (IsThese | That (Sum {getSum = 12})) --- FalseT +-- Val False -- --- >>> pl @(IsThese Id) (These 1 (SG.Sum 12)) +-- >>> pl @IsThese (These 1 (SG.Sum 12)) -- True (IsThese | These 1 (Sum {getSum = 12})) --- TrueT +-- Val True -- - -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 +data IsThese deriving Show +type IsTheseT = IsTh ('These '() '()) -instance P (IsTheseT p) x => P (IsThese p) x where - type PP (IsThese p) x = PP (IsTheseT p) x - eval _ = evalBool (Proxy @(IsTheseT p)) +instance P IsTheseT x => P IsThese x where + type PP IsThese x = PP IsTheseT x + eval _ = evalBool (Proxy @IsTheseT) -- | similar to 'Data.These.these' -- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (This 13) --- PresentT 13 +-- >>> pz @(TheseIn Id Len (Fst + Length Snd)) (This 13) +-- Val 13 -- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (That "this is a long string") --- PresentT 21 +-- >>> pz @(TheseIn Id Len (Fst + Length Snd)) (That "this is a long string") +-- Val 21 -- --- >>> pz @(TheseIn Id Len (Fst Id + Length (Snd Id))) (These 20 "somedata") --- PresentT 28 +-- >>> pz @(TheseIn Id Len (Fst + Length Snd)) (These 20 "somedata") +-- Val 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 > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (That "this is a long string") +-- Val (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 > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (These 1 "this is a long string") +-- Val (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) +-- >>> pz @(TheseIn (MkLeft _ Id) (MkRight _ Id) (If (Fst > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (These 100 "this is a long string") +-- Val (Left 100) -- -- >>> pl @(TheseIn "this" "that" "these") (This (SG.Sum 12)) -- Present "this" (TheseIn "this" | This Sum {getSum = 12}) --- PresentT "this" +-- Val "this" -- -- >>> pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (These "Ab" 13) -- Present ("Ab",13) (TheseIn ("Ab",13) | These "Ab" 13) --- PresentT ("Ab",13) +-- Val ("Ab",13) -- -- >>> pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (This "Ab") -- Present ("Ab",999) (TheseIn ("Ab",999) | This "Ab") --- PresentT ("Ab",999) +-- Val ("Ab",999) -- -- >>> pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (That 13) -- Present ("no value",13) (TheseIn ("no value",13) | That 13) --- PresentT ("no value",13) +-- Val ("no value",13) -- - -data TheseIn p q r +data TheseIn p q r deriving Show -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) +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 @@ -479,40 +469,40 @@ let msg1 = "This " msg2 = msg0 <> msg1 pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts (msg2 <> "p failed") pp [] of + pure $ case getValueLR NoInline opts (msg2 <> "p failed") pp [] of Left e -> e - Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 a) [hh pp] + Right c -> mkNode opts (Val c) (show3' 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 + pure $ case getValueLR NoInline opts (msg2 <> "q failed") qq [] of Left e -> e - Right c -> mkNode opts (PresentT c) (show01' opts msg0 c msg1 b) [hh qq] + Right c -> mkNode opts (Val c) (show3' 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 + pure $ case getValueLR NoInline opts (msg2 <> "r failed") rr [] of Left e -> e - Right c -> mkNode opts (PresentT c) (show01 opts msg0 c (These a b)) [hh rr] + Right c -> mkNode opts (Val c) (show3 opts msg0 c (These a b)) [hh rr] --- | TheseId: returns a tuple so you need to provide a value for rhs in the This case and lhs for the That case +-- | TheseId: given a 'These' returns a tuple but you need to provide default values for both sides -- --- >>> pl @(TheseId 'True "xyz") (This "abc") +-- >>> pl @(TheseId "xyz" 'True ) (This "abc") -- Present ("abc",True) (TheseIn ("abc",True) | This "abc") --- PresentT ("abc",True) +-- Val ("abc",True) -- --- >>> pl @(TheseId 'True "xyz") (That False) +-- >>> pl @(TheseId "xyz" 'True) (That False) -- Present ("xyz",False) (TheseIn ("xyz",False) | That False) --- PresentT ("xyz",False) +-- Val ("xyz",False) -- --- >>> pl @(TheseId 'True "xyz") (These "abc" False) +-- >>> pl @(TheseId "xyz" 'True) (These "abc" False) -- Present ("abc",False) (TheseIn ("abc",False) | These "abc" False) --- PresentT ("abc",False) +-- Val ("abc",False) -- -data TheseId p q -type TheseIdT p q = TheseIn '(I, p) '(q, I) I +data TheseId p q deriving Show +type TheseIdT p q = TheseIn '(Id, q) '(p, Id) Id instance P (TheseIdT p q) x => P (TheseId p q) x where type PP (TheseId p q) x = PP (TheseIdT p q) x @@ -522,56 +512,54 @@ -- -- 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 Snd) ("aBc", [1..5]) +-- Val [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 Fst Snd) ("aBcDeF", [1..3]) +-- Val [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'] +-- Val [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'] +-- Val [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'] +-- Val [That 'a',That 'B',That 'c',That 'D',That 'e',That 'F'] -- -- >>> pz @(ZipThese '[] '[]) "aBcDeF" --- PresentT [] +-- Val [] -- --- >>> pl @(ZipThese (Fst Id) (Snd Id) >> Map (TheseIn Id Id (Fst Id)) Id) (['w'..'y'],['a'..'f']) +-- >>> pl @(ZipThese Fst Snd >> Map (TheseIn Id Id Fst)) (['w'..'y'],['a'..'f']) -- Present "wxydef" ((>>) "wxydef" | {Map "wxydef" | [These 'w' 'a',These 'x' 'b',These 'y' 'c',That 'd',That 'e',That 'f']}) --- PresentT "wxydef" +-- Val "wxydef" -- --- >>> pl @(("sdf" &&& Id) >> ZipThese (Fst Id) (Snd Id) >> Map (TheseIn (Id &&& 0) (Head "x" &&& Id) Id) Id) [1..5] +-- >>> pl @(("sdf" &&& Id) >> ZipThese Fst Snd >> Map (TheseIn (Id &&& 0) (C "x" &&& Id) Id)) [1..5] -- Present [('s',1),('d',2),('f',3),('x',4),('x',5)] ((>>) [('s',1),('d',2),('f',3),('x',4),('x',5)] | {Map [('s',1),('d',2),('f',3),('x',4),('x',5)] | [These 's' 1,These 'd' 2,These 'f' 3,That 4,That 5]}) --- PresentT [('s',1),('d',2),('f',3),('x',4),('x',5)] +-- Val [('s',1),('d',2),('f',3),('x',4),('x',5)] -- - -data ZipThese p q +data ZipThese p q deriving Show -instance (PP p a ~ [x] +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 + , 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 [] + lr <- runPQ NoInline 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 + in case chkSize2 opts msg0 p q hhs of Left e -> e - Right () -> + Right _ -> let d = simpleAlign p q - in mkNode opts (PresentT d) (show01' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs - + in mkNode opts (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs simpleAlign :: [a] -> [b] -> [These a b] simpleAlign as [] = map This as @@ -580,37 +568,35 @@ -- | 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 +-- 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) +-- Val (102 % 5) -- -- >>> pz @(ThisDef (1 % 4) Id) (That "aa") --- PresentT (1 % 4) +-- Val (1 % 4) -- -- >>> pz @(ThisDef (1 % 4) Id) (These 2.3 "aa") --- PresentT (1 % 4) +-- Val (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 (PrintT "found %s fst=%d" '(ShowP Snd, Fst)) Snd) (123,That "xy") +-- Val "found That \"xy\" fst=123" -- -- >>> pz @(ThisDef (MEmptyT _) Id) (That 222) --- PresentT () +-- Val () -- -- >>> pz @(ThisDef (MEmptyT (SG.Sum _)) Id) (These 222 'x') --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -- >>> pl @(ThisDef (MEmptyT _) Id) (This (SG.Sum 12)) -- Present Sum {getSum = 12} (ThisDef This) --- PresentT (Sum {getSum = 12}) +-- Val (Sum {getSum = 12}) -- -- >>> pl @(ThisDef (MEmptyT _) Id) (That 12) -- Present () (ThisDef That) --- PresentT () +-- Val () -- - -data ThisDef p q +data ThisDef p q deriving Show instance ( PP q x ~ These a b , PP p x ~ a @@ -621,41 +607,41 @@ eval _ opts x = do let msg0 = "ThisDef" qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - This a -> pure $ mkNode opts (PresentT a) (msg0 <> " This") [hh qq] + This a -> pure $ mkNode opts (Val a) (msg0 <> " This") [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Val p) (msg0 <> " " <> showThese q) [hh qq, hh pp] -- | 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 +-- 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) +-- Val (102 % 5) -- -- >>> pz @(ThatDef (1 % 4) Id) (This "aa") --- PresentT (1 % 4) +-- Val (1 % 4) -- -- >>> pz @(ThatDef (1 % 4) Id) (These "aa" 2.3) --- PresentT (1 % 4) +-- Val (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 (PrintT "found %s fst=%d" '(ShowP Snd, Fst)) Snd) (123,This "xy") +-- Val "found This \"xy\" fst=123" -- -- >>> pz @(ThatDef (MEmptyT _) Id) (This 222) --- PresentT () +-- Val () -- -- >>> pz @(ThatDef (MEmptyT (SG.Sum _)) Id) (These 'x' 1120) --- PresentT (Sum {getSum = 0}) +-- Val (Sum {getSum = 0}) -- -data ThatDef p q +data ThatDef p q deriving Show instance ( PP q x ~ These a b , PP p x ~ b @@ -666,52 +652,52 @@ eval _ opts x = do let msg0 = "ThatDef" qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - That a -> pure $ mkNode opts (PresentT a) (msg0 <> " That") [hh qq] + That a -> pure $ mkNode opts (Val a) (msg0 <> " That") [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Val 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 +-- 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") +-- Val (102 % 5,"x") -- -- >>> pz @(TheseDef '(1 % 4,"zz") Id) (This 20.4) --- PresentT (1 % 4,"zz") +-- Val (1 % 4,"zz") -- -- >>> pz @(TheseDef '(1 % 4,"zz") Id) (That "x") --- PresentT (1 % 4,"zz") +-- Val (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 '(PrintT "found %s fst=%d" '(ShowP Snd, Fst),999) Snd) (123,This "xy") +-- Val ("found This \"xy\" fst=123",999) -- -- >>> pz @(TheseDef (MEmptyT (SG.Sum _, String)) Id) (This 222) --- PresentT (Sum {getSum = 0},"") +-- Val (Sum {getSum = 0},"") -- --- >>> pz @(TheseDef (MEmptyT _) Id) (These (222 :: SG.Sum Int) "aa") --- PresentT (Sum {getSum = 222},"aa") +-- >>> pz @(TheseDef (MEmptyT _) Id) (These (SG.Sum 222) "aa") +-- Val (Sum {getSum = 222},"aa") -- -- >>> pl @(TheseDef '("xyz",'True) Id) (This "abc") -- Present ("xyz",True) (TheseDef This) --- PresentT ("xyz",True) +-- Val ("xyz",True) -- -- >>> pl @(TheseDef '("xyz",'True) Id) (That False) -- Present ("xyz",True) (TheseDef That) --- PresentT ("xyz",True) +-- Val ("xyz",True) -- -- >>> pl @(TheseDef '("xyz",'True) Id) (These "abc" False) -- Present ("abc",False) (TheseDef These) --- PresentT ("abc",False) +-- Val ("abc",False) -- -data TheseDef p q +data TheseDef p q deriving Show instance ( PP q x ~ These a b , PP p x ~ (a,b) @@ -722,175 +708,178 @@ eval _ opts x = do let msg0 = "TheseDef" qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of + case getValueLR NoInline 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] + These a b -> pure $ mkNode opts (Val (a,b)) (msg0 <> " These") [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (PresentT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Val 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 +-- if there is no This value then @p@ is passed the whole context only -- -- >>> pz @(ThisFail "oops" Id) (This 20.4) --- PresentT 20.4 +-- Val 20.4 -- -- >>> pz @(ThisFail "oops" Id) (That "aa") --- FailT "oops" +-- Fail "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 (PrintT "found %s fst=%d" '(ShowP Snd,Fst)) Snd) (123,That "xy") +-- Fail "found That \"xy\" fst=123" -- -- >>> pz @(ThisFail (MEmptyT _) Id) (That 222) --- FailT "" +-- Fail "" -- -- >>> pl @(ThisFail "sdf" Id) (This (SG.Sum 12)) -- Present Sum {getSum = 12} (This) --- PresentT (Sum {getSum = 12}) +-- Val (Sum {getSum = 12}) -- -- >>> pl @(ThisFail "sdf" Id) (That (SG.Sum 12)) -- Error sdf (ThisFail That) --- FailT "sdf" +-- Fail "sdf" -- -- >>> pl @(ThisFail "sdf" Id) (That 12) -- Error sdf (ThisFail That) --- FailT "sdf" +-- Fail "sdf" -- -data ThisFail p q +data ThisFail p q deriving Show instance ( PP p x ~ String , PP q x ~ These a b , P p x - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - This a -> pure $ mkNode opts (PresentT a) "This" [hh qq] + This a -> pure $ mkNode opts (Val a) "This" [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Fail 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 +-- if there is no That value then @p@ is passed the whole context only -- -- >>> pz @(ThatFail "oops" Id) (That 20.4) --- PresentT 20.4 +-- Val 20.4 -- -- >>> pz @(ThatFail "oops" Id) (This "aa") --- FailT "oops" +-- Fail "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 (PrintT "found %s fst=%d" '(ShowP Snd,Fst)) Snd) (123,This "xy") +-- Fail "found This \"xy\" fst=123" -- -- >>> pz @(ThatFail (MEmptyT _) Id) (This 222) --- FailT "" +-- Fail "" -- -data ThatFail p q +data ThatFail p q deriving Show instance ( PP p x ~ String , PP q x ~ These a b , P p x - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - That a -> pure $ mkNode opts (PresentT a) "That" [hh qq] + That a -> pure $ mkNode opts (Val a) "That" [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Fail 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 +-- 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) +-- Val ("abc",20.4) -- -- >>> pz @(TheseFail "oops" Id) (That "aa") --- FailT "oops" +-- Fail "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 (PrintT "found %s fst=%d" '(ShowP Snd,Fst)) Snd) (123,That "xy") +-- Fail "found That \"xy\" fst=123" -- -- >>> pz @(TheseFail (MEmptyT _) Id) (That 222) --- FailT "" +-- Fail "" -- -data TheseFail p q +data TheseFail p q deriving Show instance ( PP p x ~ String , PP q x ~ These a b , P p x - , P q 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 + case getValueLR NoInline opts msg0 qq [] of Left e -> pure e Right q -> case q of - These a b -> pure $ mkNode opts (PresentT (a,b)) "These" [hh qq] + These a b -> pure $ mkNode opts (Val (a,b)) "These" [hh qq] _ -> do pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [hh qq] of + pure $ case getValueLR NoInline opts msg0 pp [hh qq] of Left e -> e - Right p -> mkNode opts (FailT p) (msg0 <> " " <> showThese q) [hh qq, hh pp] + Right p -> mkNode opts (Fail p) (msg0 <> " " <> showThese q) [hh qq, hh pp] -- | assoc using 'AssocC' -- -- >>> pz @Assoc (This (These 123 'x')) --- PresentT (These 123 (This 'x')) +-- Val (These 123 (This 'x')) -- -- >>> pz @Assoc ((99,'a'),True) --- PresentT (99,('a',True)) +-- Val (99,('a',True)) -- -- >>> pz @Assoc ((99,'a'),True) --- PresentT (99,('a',True)) +-- Val (99,('a',True)) -- -- >>> pz @Assoc (Right "Abc" :: Either (Either () ()) String) --- PresentT (Right (Right "Abc")) +-- Val (Right (Right "Abc")) -- -- >>> pz @Assoc (Left (Left 'x')) --- PresentT (Left 'x') +-- Val (Left 'x') -- -- >>> pl @Assoc ((10,'c'),True) -- Present (10,('c',True)) (Assoc (10,('c',True)) | ((10,'c'),True)) --- PresentT (10,('c',True)) +-- Val (10,('c',True)) -- -- >>> pl @(Assoc >> Unassoc) ((10,'c'),True) -- Present ((10,'c'),True) ((>>) ((10,'c'),True) | {Unassoc ((10,'c'),True) | (10,('c',True))}) --- PresentT ((10,'c'),True) +-- Val ((10,'c'),True) -- -data Assoc +data Assoc deriving Show class AssocC p where assoc :: p (p a b) c -> p a (p b c) @@ -922,108 +911,107 @@ 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 +instance ( AssocC p + , Show (p (p a b) c) + , Show (p a (p b c)) + ) => 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) [] + in pure $ mkNode opts (Val d) (show3 opts msg0 d pabc) [] -- | unassoc using 'AssocC' -- -- >>> pz @Unassoc (These 123 (This 'x')) --- PresentT (This (These 123 'x')) +-- Val (This (These 123 'x')) -- -- >>> pz @Unassoc (99,('a',True)) --- PresentT ((99,'a'),True) +-- Val ((99,'a'),True) -- -- >>> pz @Unassoc (This 10 :: These Int (These Bool ())) --- PresentT (This (This 10)) +-- Val (This (This 10)) -- -- >>> pz @Unassoc (Right (Right 123)) --- PresentT (Right 123) +-- Val (Right 123) -- -- >>> pz @Unassoc (Left 'x' :: Either Char (Either Bool Double)) --- PresentT (Left (Left 'x')) +-- Val (Left (Left 'x')) -- -- >>> pl @Unassoc (10,('c',True)) -- Present ((10,'c'),True) (Unassoc ((10,'c'),True) | (10,('c',True))) --- PresentT ((10,'c'),True) +-- Val ((10,'c'),True) -- -data Unassoc +data Unassoc deriving Show -instance (Show (p (p a b) c) - , Show (p a (p b c)) - , AssocC p - ) => P Unassoc (p a (p b c)) where +instance ( AssocC p + , Show (p (p a b) c) + , Show (p a (p b c)) + ) => 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) [] + in pure $ mkNode opts (Val d) (show3 opts msg0 d pabc) [] -- | tries to extract a value from the 'Data.These.This' constructor -- --- >>> pz @(This' >> Succ Id) (This 20) --- PresentT 21 +-- >>> pz @(This' >> Succ) (This 20) +-- Val 21 -- --- >>> pz @(This' >> Succ Id) (That 'a') --- FailT "This' found That" +-- >>> pz @(This' >> Succ) (That 'a') +-- Fail "This' found That" -- -data This' -instance (Show a - ) => P This' (These a x) where +data This' deriving Show +instance Show a => P This' (These a x) where type PP This' (These a x) = a eval _ opts lr = let msg0 = "This'" in pure $ case lr of - These _ _ -> mkNode opts (FailT (msg0 <> " found These")) "" [] - That _ -> mkNode opts (FailT (msg0 <> " found That")) "" [] - This a -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + These _ _ -> mkNode opts (Fail (msg0 <> " found These")) "" [] + That _ -> mkNode opts (Fail (msg0 <> " found That")) "" [] + This a -> mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -- | tries to extract a value from the 'Data.These.That' constructor -- --- >>> pz @(That' >> Succ Id) (That 20) --- PresentT 21 +-- >>> pz @(That' >> Succ) (That 20) +-- Val 21 -- --- >>> pz @(That' >> Succ Id) (This 'a') --- FailT "That' found This" +-- >>> pz @(That' >> Succ) (This 'a') +-- Fail "That' found This" -- -data That' -instance (Show a - ) => P That' (These x a) where +data That' deriving Show +instance Show a => P That' (These x a) where type PP That' (These x a) = a eval _ opts lr = let msg0 = "That'" in pure $ case lr of - These _ _ -> mkNode opts (FailT (msg0 <> " found These")) "" [] - This _ -> mkNode opts (FailT (msg0 <> " found This")) "" [] - That a -> mkNode opts (PresentT a) (msg0 <> " " <> showL opts a) [] + These _ _ -> mkNode opts (Fail (msg0 <> " found These")) "" [] + This _ -> mkNode opts (Fail (msg0 <> " found This")) "" [] + That a -> mkNode opts (Val a) (msg0 <> " " <> showL opts a) [] -- | tries to extract the values from the 'Data.These.These' constructor -- --- >>> pz @(These' >> Second (Succ Id)) (These 1 'a') --- PresentT (1,'b') +-- >>> pz @(These' >> Second Succ) (These 1 'a') +-- Val (1,'b') -- --- >>> pz @(That' >> Succ Id) (This 'a') --- FailT "That' found This" +-- >>> pz @(That' >> Succ) (This 'a') +-- Fail "That' found This" -- --- >>> pz @(These' >> Second (Succ Id)) (That 8) --- FailT "These' found That" +-- >>> pz @(These' >> Second Succ) (That 8) +-- Fail "These' found That" -- -data These' -instance (Show a, Show b +data These' deriving Show +instance ( Show a + , Show b ) => P These' (These a b) where type PP These' (These a b) = (a,b) eval _ opts lr = let msg0 = "These'" in pure $ case lr of - This _ -> mkNode opts (FailT (msg0 <> " found This")) "" [] - That _ -> mkNode opts (FailT (msg0 <> " found That")) "" [] - These a b -> mkNode opts (PresentT (a,b)) (msg0 <> " " <> showL opts (a,b)) [] + This _ -> mkNode opts (Fail (msg0 <> " found This")) "" [] + That _ -> mkNode opts (Fail (msg0 <> " found That")) "" [] + These a b -> mkNode opts (Val (a,b)) (msg0 <> " " <> showL opts (a,b)) []
src/Predicate/Data/Tuple.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -18,29 +12,46 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE NoStarIsType #-} -{- | - promoted tuple functions --} +{-# LANGUAGE EmptyDataDeriving #-} +-- | promoted tuple functions module Predicate.Data.Tuple ( + -- ** arrows Dup , First , Second , type (&&&) , type (***) + , Both + , On + + -- ** flat tuples + , Tuple + , Tuple' , Pairs + -- ** boolean , AndA , type (&*) , OrA , type (|+) + -- ** inductive tuples + , EachITuple + , ToITuple + , ReverseITuple + , ToITupleList + ) where import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Proxy +import Data.Proxy (Proxy(Proxy)) +import GHC.TypeNats (Nat, KnownNat) +import qualified GHC.TypeLits as GL +import Control.Lens +import Data.Kind (Type) -- $setup -- >>> :set -XDataKinds @@ -49,26 +60,28 @@ -- >>> :set -XOverloadedStrings -- >>> :set -XNoOverloadedLists -- >>> import Predicate.Prelude +-- >>> import qualified Data.Semigroup as SG +-- >>> :m + Data.Ratio -- | duplicate a value into a tuple -- -- >>> pl @Dup 4 --- Present (4,4) (W '(4,4)) --- PresentT (4,4) +-- Present (4,4) ('(4,4)) +-- Val (4,4) -- -- >>> pl @(Dup >> Id) 4 -- Present (4,4) ((>>) (4,4) | {Id (4,4)}) --- PresentT (4,4) +-- Val (4,4) -- --- >>> pl @(Dup << Fst Id * Snd Id) (4,5) --- Present (20,20) ((>>) (20,20) | {W '(20,20)}) --- PresentT (20,20) +-- >>> pl @(Dup << Fst * Snd) (4,5) +-- Present (20,20) ((>>) (20,20) | {'(20,20)}) +-- Val (20,20) -- --- >>> pl @(Fst Id * Snd Id >> Dup) (4,5) --- Present (20,20) ((>>) (20,20) | {W '(20,20)}) --- PresentT (20,20) +-- >>> pl @(Fst * Snd >> Dup) (4,5) +-- Present (20,20) ((>>) (20,20) | {'(20,20)}) +-- Val (20,20) -- -data Dup +data Dup deriving Show type DupT = W '(Id, Id) instance Show x => P Dup x where @@ -78,79 +91,80 @@ -- | 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)] +-- Val [(1,2),(2,3),(3,4)] -- -- >>> pz @Pairs [] --- FailT "Pairs no data found" +-- Val [] -- -- >>> pz @Pairs [1] --- FailT "Pairs only one element found" --- --- >>> pl @Pairs ([] :: [()]) --- Error Pairs no data found (Pairs no data found) --- FailT "Pairs no data found" --- --- >>> pl @Pairs [1] --- Error Pairs only one element found (Pairs only one element found) --- FailT "Pairs only one element found" +-- Val [] -- -- >>> pl @Pairs [1,2] -- Present [(1,2)] (Pairs [(1,2)] | [1,2]) --- PresentT [(1,2)] +-- Val [(1,2)] -- -- >>> pl @Pairs [1,2,3] -- Present [(1,2),(2,3)] (Pairs [(1,2),(2,3)] | [1,2,3]) --- PresentT [(1,2),(2,3)] +-- Val [(1,2),(2,3)] -- -- >>> pl @Pairs [1,2,3,4] -- Present [(1,2),(2,3),(3,4)] (Pairs [(1,2),(2,3),(3,4)] | [1,2,3,4]) --- PresentT [(1,2),(2,3),(3,4)] +-- Val [(1,2),(2,3),(3,4)] -- -data Pairs -instance Show a => P Pairs [a] where - type PP Pairs [a] = [(a,a)] +-- >>> pan @(Pairs >> Len >> 'True >> 'False >> FailT _ "xyzzy") "abcde" +-- [Error xyzzy] False +-- | +-- +- P Pairs [('a','b'),('b','c'),('c','d'),('d','e')] +-- | +-- +- P Len 4 +-- | +-- +- True 'True +-- | +-- +- False 'False +-- | +-- `- [Error xyzzy] +-- Fail "xyzzy" +-- +data Pairs deriving Show +instance ([a] ~ x, Show a) => P Pairs x where + type PP Pairs x = [(ExtractAFromTA x,ExtractAFromTA x)] 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 ) [] - + let zs = case as of + [] -> [] + _:bs -> zip as bs + in pure $ mkNode opts (Val zs) (show3 opts "Pairs" zs as) [] -- | similar to 'Control.Arrow.&&&' -- --- >>> pl @(Min &&& Max >> Id >> Fst Id < Snd Id) [10,4,2,12,14] +-- >>> pl @(Min &&& Max >> Id >> Fst < Snd) [10,4,2,12,14] -- True ((>>) True | {2 < 14}) --- TrueT +-- Val True -- --- >>> pl @((123 &&& Id) >> Fst Id + Snd Id) 4 +-- >>> pl @((123 &&& Id) >> Fst + Snd) 4 -- Present 127 ((>>) 127 | {123 + 4 = 127}) --- PresentT 127 +-- Val 127 -- -- >>> pl @(4 &&& "sadf" &&& 'LT) () --- Present (4,("sadf",LT)) (W '(4,("sadf",LT))) --- PresentT (4,("sadf",LT)) +-- Present (4,("sadf",LT)) ('(4,("sadf",LT))) +-- Val (4,("sadf",LT)) -- -- >>> pl @(Id &&& '() &&& ()) (Just 10) --- Present (Just 10,((),())) (W '(Just 10,((),()))) --- PresentT (Just 10,((),())) +-- Present (Just 10,((),())) ('(Just 10,((),()))) +-- Val (Just 10,((),())) -- --- >>> pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,'x',True) --- Present (1,('x',(True,()))) (W '(1,('x',(True,())))) --- PresentT (1,('x',(True,()))) +-- >>> pl @(Fst &&& Snd &&& Thd &&& ()) (1,'x',True) +-- Present (1,('x',(True,()))) ('(1,('x',(True,())))) +-- Val (1,('x',(True,()))) -- --- >>> pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,'x',True) --- Present (1,('x',(True,()))) (W '(1,('x',(True,())))) --- PresentT (1,('x',(True,()))) +-- >>> pl @(Fst &&& Snd &&& Thd &&& ()) (1,'x',True) +-- Present (1,('x',(True,()))) ('(1,('x',(True,())))) +-- Val (1,('x',(True,()))) -- --- >>> pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,1.4,"aaa") --- Present (1,(1.4,("aaa",()))) (W '(1,(1.4,("aaa",())))) --- PresentT (1,(1.4,("aaa",()))) +-- >>> pl @(Fst &&& Snd &&& Thd &&& ()) (1,1.4,"aaa") +-- Present (1,(1.4,("aaa",()))) ('(1,(1.4,("aaa",())))) +-- Val (1,(1.4,("aaa",()))) -- -data p &&& q +data p &&& q deriving Show infixr 3 &&& type WAmpT p q = W '(p, q) @@ -160,46 +174,46 @@ -- | similar to 'Control.Arrow.***' -- --- >>> pz @(Pred Id *** ShowP Id) (13, True) --- PresentT (12,"True") +-- >>> pz @(Pred *** ShowP Id) (13, True) +-- Val (12,"True") -- -- >>> pl @(FlipT (***) Len (Id * 12)) (99,"cdef") -- Present (1188,4) ((***) (1188,4) | (99,"cdef")) --- PresentT (1188,4) +-- Val (1188,4) -- -- >>> pl @(4 *** "sadf" *** 'LT) ('x',("abv",[1])) -- Present (4,("sadf",LT)) ((***) (4,("sadf",LT)) | ('x',("abv",[1]))) --- PresentT (4,("sadf",LT)) +-- Val (4,("sadf",LT)) -- -data p *** q +data p *** q deriving Show 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 +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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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] + Right b1 -> mkNode opts (Val (a1,b1)) (msg0 <> " " <> showL opts (a1,b1) <> showVerbose opts " | " (a,b)) [hh pp, hh qq] -- | applies a function against the first part of a tuple: similar to 'Control.Arrow.first' -- --- >>> pz @(First (Succ Id)) (12,True) --- PresentT (13,True) +-- >>> pz @(First Succ) (12,True) +-- Val (13,True) -- -data First p -type FirstT p = p *** I +data First p deriving Show +type FirstT p = p *** Id instance P (FirstT p) x => P (First p) x where type PP (First p) x = PP (FirstT p) x @@ -207,43 +221,43 @@ -- | applies a function against the second part of a tuple: similar to 'Control.Arrow.second' -- --- >>> pz @(Second (Succ Id)) (12,False) --- PresentT (12,True) +-- >>> pz @(Second Succ) (12,False) +-- Val (12,True) -- -data Second q -type SecondT q = I *** q +data Second q deriving Show +type SecondT q = Id *** 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)) --- | applies \'p\' to lhs of the tuple and \'q\' to the rhs and then \'Ands\' them together +-- | applies @p@ to lhs of the tuple and @q@ to the rhs and then @ands@ them together: see '&*' -- -- >>> pl @(AndA (Gt 3) (Lt 10) Id) (1,2) -- False (False (&*) True | (1 > 3)) --- FalseT +-- Val False -- -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 +data AndA p q r deriving Show +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 + case getValueLR NoInline 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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline opts msg0 qq [hh rr, hh pp] of Left e -> e Right q -> let zz = case (p,q) of @@ -251,15 +265,15 @@ (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] + in mkNodeB opts (p&&q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> nullIf " | " zz) [hh rr, hh pp, hh qq] --- | applies \'p\' to lhs of the tuple and \'q\' to the rhs and then \'Ands\' them together +-- | applies @p@ to lhs of the tuple and @q@ to the rhs and then @Ands@ them together -- -- >>> pl @(SplitAt 4 "abcdefg" >> Len > 4 &* Len < 5) () -- False ((>>) False | {False (&*) True | (4 > 4)}) --- FalseT +-- Val False -- -data p &* q +data p &* q deriving Show type AndAT p q = AndA p q Id infixr 3 &* @@ -267,58 +281,295 @@ type PP (p &* q) x = PP (AndAT p q) x eval _ = evalBool (Proxy @(AndAT p q)) --- | applies \'p\' to lhs of the tuple and \'q\' to the rhs and then \'Ors\' them together +-- | applies @p@ to lhs of the tuple and @q@ to the rhs and then @ors@ them together: see '|+' -- -- >>> pl @(OrA (Gt 3) (Lt 10) Id) (1,2) -- True (False (|+) True) --- TrueT +-- Val True -- -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 +data OrA p q r deriving Show +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 + case getValueLR NoInline 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 + case getValueLR NoInline 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 + pure $ case getValueLR NoInline 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] + in mkNodeB opts (p||q) (showL opts p <> " " <> msg0 <> " " <> showL opts q <> nullIf " | " zz) [hh rr, hh pp, hh qq] --- | applies \'p\' to lhs of the tuple and \'q\' to the rhs and then \'Ors\' them together +-- | applies @p@ to lhs of the tuple and @q@ to the rhs and then @Ors@ them together -- -- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,8,14,44],9) -- True (True (|+) False) --- TrueT +-- Val True -- -- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],9) -- False (False (|+) False | (32 > 44) (|+) (9 < 2)) --- FalseT +-- Val False -- -- >>> pl @(Sum > 44 |+ Id < 2) ([5,6,7,14],1) -- True (False (|+) True) --- TrueT +-- Val True -- -data p |+ q +data p |+ q deriving Show 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)) + +-- | applies @p@ to the first and second slot of an n-tuple (similar to '***') +-- +-- >>> pl @(Fst >> Both Len) (("abc",[10..17]),True) +-- Present (3,8) ((>>) (3,8) | {Both}) +-- Val (3,8) +-- +-- >>> pl @(Lift (Both Pred) Fst) ((12,'z'),True) +-- Present (11,'y') ((>>) (11,'y') | {Both}) +-- Val (11,'y') +-- +-- >>> pl @(Both Succ) (4,'a') +-- Present (5,'b') (Both) +-- Val (5,'b') +-- +-- >>> import Data.Time +-- >>> pl @(Both (ReadP Day Id)) ("1999-01-01","2001-02-12") +-- Present (1999-01-01,2001-02-12) (Both) +-- Val (1999-01-01,2001-02-12) +-- +data Both p deriving Show +instance ( P p a + , P p a' + ) => P (Both p) (a,a') where + type PP (Both p) (a,a') = (PP p a, PP p a') + eval _ opts (a,a') = do + let msg0 = "Both" + pp <- eval (Proxy @p) opts a + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right b -> do + pp' <- eval (Proxy @p) opts a' + pure $ case getValueLR NoInline opts msg0 pp' [hh pp] of + Left e -> e + Right b' -> + mkNode opts (Val (b,b')) msg0 [hh pp, hh pp'] + +-- | similar to 'Data.Function.on' +-- +-- >>> pz @('(4,2) >> On (**) (FromIntegral _)) () +-- Val 16.0 +-- +-- >>> pz @(On (+) (Id * Id) >> Id ** (1 % 2 >> FromRational _)) (3,4) +-- Val 5.0 +-- +data On (p :: Type -> Type -> k2) q deriving Show + +instance ( P q a + , P q a' + , P (p Fst Snd) (PP q a, PP q a') + ) => P (On p q) (a,a') where + type PP (On p q) (a,a') = PP (p Fst Snd) (PP q a, PP q a') + eval _ opts (a,a') = do + let msg0 = "On" + qq <- eval (Proxy @q) opts a + case getValueLR NoInline opts msg0 qq [] of + Left e -> pure e + Right b -> do + qq' <- eval (Proxy @q) opts a' + case getValueLR NoInline opts msg0 qq' [hh qq] of + Left e -> pure e + Right b' -> do + pp <- eval (Proxy @(p Fst Snd)) opts (b,b') + pure $ case getValueLR NoInline opts msg0 pp [hh qq, hh qq'] of + Left e -> e + Right p -> mkNode opts (Val p) msg0 [hh qq, hh qq', hh pp] + +-- | create a n tuple from a list +-- +-- >>> pz @(Tuple 4) "abcdefg" +-- Val ('a','b','c','d') +-- +-- >>> pz @(Tuple 4) "abc" +-- Fail "Tuple(4) not enough elements(3)" +-- +-- >>> pz @(Fst >> Tuple 3) ([1..5],True) +-- Val (1,2,3) +-- +-- >>> pz @(Lift (Tuple 3) Fst) ([1..5],True) +-- Val (1,2,3) +-- +data Tuple (n :: Nat) deriving Show + +instance ( KnownNat n + , FailWhenT (n GL.<=? 1) + ('GL.Text "Tuple:n cannot be less than two but found n=" + 'GL.:<>: 'GL.ShowType n) + , TupleC n a + , x ~ [a] + , Show a + ) => P (Tuple n) x where + type PP (Tuple n) x = TupleT n (ExtractAFromList x) + eval _ opts as = + let msg0 = "Tuple(" ++ show n ++ ")" + n = nat @n @Int + in pure $ case getTupleC @n as of + Left es -> mkNode opts (Fail (msg0 <> " not enough elements(" <> show (length as) <> ")")) (showVerbose opts " | " es) [] + Right r -> mkNode opts (Val r) msg0 [] + +-- | create a n tuple from a list +-- +-- >>> pz @(Tuple' 4) "abcdefg" +-- Val (Right ('a','b','c','d')) +-- +-- >>> pz @(Tuple' 4) "abc" +-- Val (Left "abc") +-- +-- >>> pz @(Tuple' 4) [] +-- Val (Left []) +-- +-- >>> pl @(Tuple' 4) "abc" +-- Present Left "abc" (Tuple'(4) not enough elements(3)) +-- Val (Left "abc") +-- +-- >>> :set -XPolyKinds +-- >>> type F n i = ChunksOf' n i Id >> Map (Tuple' n) >> PartitionEithers +-- >>> pz @(F 3 1) [1..7] +-- Val ([[6,7],[7]],[(1,2,3),(2,3,4),(3,4,5),(4,5,6),(5,6,7)]) +-- +data Tuple' (n :: Nat) deriving Show + +instance ( KnownNat n + , FailWhenT (n GL.<=? 1) + ('GL.Text "Tuple':n cannot be less than two but found n=" + 'GL.:<>: 'GL.ShowType n) + , TupleC n a + , x ~ [a] + ) => P (Tuple' n) x where + type PP (Tuple' n) x = Either x (TupleT n (ExtractAFromList x)) + eval _ opts as = + let msg0 = "Tuple'(" ++ show n ++ ")" + n = nat @n @Int + lr = getTupleC @n as + in pure $ case lr of + Left e -> mkNode opts (Val (Left e)) (msg0 <> " not enough elements(" <> show (length as) <> ")") [] + Right ret -> mkNode opts (Val (Right ret)) msg0 [] + +-- | run @p@ with inductive tuples +-- +-- >>> pz @(EachITuple Succ) (False,(2,(LT,('c',())))) +-- Val (True,(3,(EQ,('d',())))) +-- +-- >>> pz @(EachITuple (Id + (4 >> FromIntegral _))) (1,(1/4,(5%6,()))) +-- Val (5 % 1,(17 % 4,(29 % 6,()))) +-- +-- >>> pz @(ToITuple >> EachITuple (Id + (4 >> FromIntegral _))) (1000,1/4,5%6) +-- Val (1004 % 1,(17 % 4,(29 % 6,()))) +-- +-- >>> pz @(ToITuple >> EachITuple ((Id >> FromIntegral _) + (4 >> FromIntegral _))) (1000::Integer,17::Int) +-- Val (1004,(21,())) +-- +-- >>> pz @(ToITuple >> EachITuple (Dup >> Fst<>Snd)) (SG.Min 1,SG.First 'x',"abcd") +-- Val (Min {getMin = 1},(First {getFirst = 'x'},("abcdabcd",()))) +-- +data EachITuple p deriving Show + +instance ( P p b + , P (EachITuple p) bs + ) => P (EachITuple p) (b,bs) where + type PP (EachITuple p) (b,bs) = (PP p b, PP (EachITuple p) bs) + eval _ opts (b,bs) = do + let msg0 = "EachITuple" + pp <- eval (Proxy @p) opts b + case getValueLR NoInline opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @(EachITuple p)) opts bs + pure $ case getValueLR NoInline opts msg0 qq [] of + Left e -> e + Right q -> + qq & ttVal .~ Val (p,q) + & ttForest %~ (hh pp:) + +instance P (EachITuple p) () where + type PP (EachITuple p) () = () + eval _ opts () = do + let msg0 = "EachITuple" + pure $ mkNode opts (Val ()) msg0 [] + +-- | create inductive tuples from flat tuples +-- +-- >>> pz @(ToITuple >> EachITuple Succ) (1,2,False,'x') +-- Val (2,(3,(True,('y',())))) +-- +data ToITuple deriving Show + +instance ToITupleC x => P ToITuple x where + type PP ToITuple x = ToITupleP x + eval _ opts x = do + let msg0 = "ToITuple" + pure $ mkNode opts (Val (toITupleC x)) msg0 [] + +-- | reverse an inductive tuple +-- +-- >>> pz @ReverseITuple (1.4,(1,(2,(False,('x',()))))) +-- Val ('x',(False,(2,(1,(1.4,()))))) +-- +data ReverseITuple deriving Show + +instance P ReverseITuple () where + type PP ReverseITuple () = () + eval _ opts () = do + let msg0 = "ReverseITuple" + pure $ mkNode opts (Val ()) msg0 [] + +instance ReverseITupleC x xs () => P ReverseITuple (x,xs) where + type PP ReverseITuple (x,xs) = ReverseITupleT x xs () + eval _ opts (x,xs) = do + let msg0 = "ReverseITuple" + pure $ mkNode opts (Val (reverseITupleC x xs ())) msg0 [] + +-- | create inductive tuples from a list of the exact size @n@ +-- +-- >>> pz @(ToITupleList 4 >> EachITuple Succ) ['a','c','y','B'] +-- Val ('b',('d',('z',('C',())))) +-- +-- >>> pz @(ToITupleList 4) ['a','c','y','B'] +-- Val ('a',('c',('y',('B',())))) +-- +-- >>> pz @(Take 10 Id >> ToITupleList 10) ['a'..'z'] +-- Val ('a',('b',('c',('d',('e',('f',('g',('h',('i',('j',())))))))))) +-- +data ToITupleList (n :: Nat) deriving Show + +instance ( KnownNat n + , FailWhenT (n GL.<=? 0) + ('GL.Text "ToITupleList:n cannot be 0") + , ToITupleListC n a + , xs ~ [a] + ) => P (ToITupleList n) xs where + type PP (ToITupleList n) xs = ToITupleListP n (ExtractAFromTA xs) + eval _ opts xs = + let msg0 = "ToITupleList(" <> show n <> ")" + n = nat @n @Int + in pure $ case toITupleListC @n @a xs of + Left e -> mkNode opts (Fail e) (msg0 <> " instead found " <> show (length xs)) [] + Right d -> mkNode opts (Val d) msg0 []
src/Predicate/Examples/Common.hs view
@@ -1,12 +1,6 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -15,11 +9,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NoStarIsType #-} -{- | - Common predicates for use with Refined, Refined2, and Refined3 --} +-- | Common predicates for use with Refined, Refined2, and Refined3 module Predicate.Examples.Common ( - -- ** date time checkers + -- ** datetime DateNip , DateFmts , DateTimeFmts @@ -30,7 +22,8 @@ , Ddmmyyyyop , Ddmmyyyyop' , JsonMicrosoftDateTime - -- *** time checkers + + -- ** time , Hmsip , Hmsop , Hmsop' @@ -38,15 +31,11 @@ , HmsRE -- ** credit cards - , Ccip - , Ccop - , Ccfmt , Luhnip , Luhnop + , Luhnfmt , Luhn' , Luhnop' - , Luhn'' --- , Luhnfmt -- ** ssn , Ssnip @@ -77,34 +66,29 @@ , Isbn13ip , Isbn13op , Isbn13fmt - ) where import Predicate.Prelude import GHC.TypeLits (Nat) -import Data.Time - --- | \'ip\' type for converting a credit card number to a list of singleton digits -type Ccip = Map (ReadP Int Id) (Ones (Remove "-" Id)) +import Data.Time (Day, UTCTime, ZonedTime) --- | \'op\' type for validating a credit card number by check digit -type Ccop (n :: Nat) = Guard (PrintT "expected %d digits but found %d" '(n,Len)) (Len == n) >> Luhn Id +-- | @ip@ type for converting a credit card number to a list of singleton digits +type Luhnip = Map' (ReadP Int Id) (Remove "-" Id >> Ones) --- | \'fmt\' type for formatting a credit card using \'ns\' as the format -type Ccfmt (ns :: [Nat]) = ConcatMap (ShowP Id) Id >> SplitAts ns Id >> Concat (Intercalate '["-"] Id) +-- | @op@ type for validating a credit card number by check digit +type Luhnop (n :: Nat) = GuardBool (PrintT "expected %d digits but found %d" '(n,Len)) (Len == n) && GuardBool "invalid checkdigit" IsLuhn --- | uses builtin 'Luhn' -type Luhnip = Map (ReadP Int Id) (Ones Id) -type Luhnop (n :: Nat) = Msg "incorrect number of digits:" (Len == n) && Luhn Id +-- | @fmt@ type for formatting a credit card using @ns@ as the format +type Luhnfmt (ns :: [Nat]) = ConcatMap (ShowP Id) Id >> SplitAts ns Id >> Intercalate '["-"] Id >> Concat -- now that time is actually validated we dont need Dtop* --- | \'ip\' type for reading in a date time -type Dtip t = ParseTimeP t "%F %T" Id --- | \'fmt\' type for formatting the date time compatible ith 'Dtip' -type Dtfmt = FormatTimeP "%F %T" Id +-- | @ip@ type for reading in a date time +type Dtip t = ParseTimeP t "%F %T" +-- | @fmt@ type for formatting the date time compatible ith 'Dtip' +type Dtfmt = FormatTimeP "%F %T" --- | \'ip\' type for reading in a ssn -type Ssnip = Map (ReadP Int Id) (Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> Snd (OneP Id)) --- | \'op\' type for validating a ssn +-- | @ip@ type for reading in a ssn +type Ssnip = Map' (ReadP Int Id) (Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Snd) +-- | @op@ type for validating a ssn type Ssnop = BoolsQuick (PrintT "number for group %d invalid: found %d" Id) '[Between 1 899 Id && Id /= 666, Between 1 99 Id, Between 1 9999 Id] @@ -116,20 +100,20 @@ ] >> 'True -} --- | \'fmt\' type for formatting the ssn compatible with 'Ssnip' +-- | @fmt@ type for formatting the ssn compatible with 'Ssnip' type Ssnfmt = PrintL 3 "%03d-%02d-%04d" Id --- | \'ip\' type for reading in time -type Hmsip = Map (ReadP Int Id) (Resplit ":" Id) --- type Hmsop' = BoolsQuick "" '[ Msg "hours:" (Between 0 23 Id), Msg "minutes:" (Between 0 59 Id), Msg "seconds:" (Between 0 59 Id)] +-- | @ip@ type for reading in time +type Hmsip = Map' (ReadP Int Id) (Resplit ":") +-- type Hmsop' = BoolsQuick "" '[Msg "hours:" (Between 0 23 Id), Msg "minutes:" (Between 0 59 Id), Msg "seconds:" (Between 0 59 Id)] --- | \'op\' type for validating the time using a guard -type Hmsop = GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)] +-- | @op@ type for validating the time using a guard +type Hmsop = GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23 Id),'("minutes",Between 0 59 Id),'("seconds",Between 0 59 Id)] >> 'True --- | \'op\' type for validating the time using predicate +-- | @op@ type for validating the time using predicate type Hmsop' = Bools '[ '("hours", Between 0 23 Id), '("minutes",Between 0 59 Id), '("seconds",Between 0 59 Id) ] --- | \'fmt\' type for formatting the time +-- | @fmt@ type for formatting the time type Hmsfmt = PrintL 3 "%02d:%02d:%02d" Id -- | regular expression for a time component @@ -138,19 +122,19 @@ -- | regular expression for an ip4 address type Ip4RE = "^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" --- | \'ip\' type for reading in an ip4 address -type Ip4ip = Map (ReadP Int Id) (Resplit "\\." Id) +-- | @ip@ type for reading in an ip4 address +type Ip4ip = Map' (ReadP Int Id) (Resplit "\\.") --- | \'ip\' type for reading in an ip4 address using a regular expression -type Ip4ip' = Map (ReadP Int Id) (Rescan Ip4RE Id >> Snd (OneP Id)) +-- | @ip@ type for reading in an ip4 address using a regular expression +type Ip4ip' = Map' (ReadP Int Id) (Rescan Ip4RE >> OneP >> Snd) -- RepeatT is a type family so it expands everything! replace RepeatT with a type class --- | \'op\' type for validating an ip4 address using a predicate -type Ip4op' = BoolsN (PrintT "octet %d out of range 0-255 found %d" Id) 4 (Between 0 255 Id) --- | \'op\' type for validating an ip4 address using a guard -type Ip4op = GuardsN (PrintT "octet %d out of range 0-255 found %d" Id) 4 (Between 0 255 Id) +-- | @op@ type for validating an ip4 address using a predicate +type Ip4op' = BoolsN (PrintT "octet %d out of range 0-255 found %d" Id) 4 (0 <..> 0xff) +-- | @op@ type for validating an ip4 address using a guard +type Ip4op = GuardsN (PrintT "octet %d out of range 0-255 found %d" Id) 4 (0 <..> 0xff) >> 'True --- | \'fmt\' type for formatting an ip4 address +-- | @fmt@ type for formatting an ip4 address type Ip4fmt = PrintL 4 "%03d.%03d.%03d.%03d" Id -- | regular expression for an octet @@ -160,58 +144,56 @@ type Ip4StrictRE = "^" <%> IntersperseT "\\." (RepeatT 4 OctetRE) <%> "$" --- | \'ip\' type for reading in an ip6 address -type Ip6ip = Resplit ":" Id - >> Map (If (Id == "") "0" Id) Id - >> Map (ReadBase Int 16 Id) Id +-- | @ip@ type for reading in an ip6 address +type Ip6ip = Resplit ":" + >> Map (If (Id == "") "0" Id) + >> Map (ReadBase Int 16) >> PadL 8 0 Id ---type Ip6ip' = Map (If (Id == "") 0 (ReadBase Int 16 Id)) (Resplit ":" Id) >> PadL 8 0 Id +--type Ip6ip' = Map' (If (Id == "") 0 (ReadBase Int 16)) (Resplit ":") >> PadL 8 0 Id --- | \'op\' type for validating an ip6 address using predicates +-- | @op@ type for validating an ip6 address using predicates type Ip6op = Msg "count is bad:" (Len == 8) - && Msg "out of bounds:" (All (Between 0 65535 Id) Id) + && Msg "out of bounds:" (All (0 <..> 0xffff)) --- | \'fmt\' type for formatting an ip6 address +-- | @fmt@ type for formatting an ip6 address type Ip6fmt = PrintL 8 "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x" Id -type Isbn10ip = Resplit "-" Id - >> Concat Id +type Isbn10ip = Resplit "-" + >> Concat >> 'Just Unsnoc - >> Map (ReadP Int (Singleton Id)) Id *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) + >> Map (ReadP Int (Singleton Id)) *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id)) -type Isbn10op = GuardSimple (All (0 <..> 9) (Fst Id) && Between 0 10 (Snd Id)) - >> ZipWith (Fst Id * Snd Id) (1...10 >> Reverse) (Fst Id +: Snd Id) +type Isbn10op = GuardSimple ((Fst >> All (0 <..> 9)) && Between 0 10 Snd) + >> ZipWith (Fst * Snd) (1...10 >> Reverse) (Fst +: Snd) >> Sum - >> Guard "mod 0 oops" (Id `Mod` 11 == 0) - >> 'True + >> GuardBool "mod 0 oops" (Id `Mod` 11 == 0) type Isbn10fmt = ConcatMap (ShowP Id) Id *** If (Id == 10) "X" (ShowP Id) - >> Fst Id <> "-" <> Snd Id -- no standard format: just hyphen before checkdigit + >> Fst <> "-" <> Snd -- no standard format: just hyphen before checkdigit -type Isbn13ip = Resplit "-" Id - >> Concat Id - >> Map (ReadP Int (Singleton Id)) Id +type Isbn13ip = Resplit "-" + >> Concat + >> Map (ReadP Int (Singleton Id)) -type Isbn13op = ZipWith (Fst Id * Snd Id) (Cycle 13 [1,3] >> Reverse) Id +type Isbn13op = ZipWith (Fst * Snd) (Cycle 13 [1,3] >> Reverse) Id >> Sum >> '(Id,Id `Mod` 10) - >> Guard (PrintT "sum=%d mod 10=%d" Id) (Snd Id == 0) - >> 'True + >> GuardBool (PrintT "sum=%d mod 10=%d" Id) (Snd == 0) -type Isbn13fmt = 'Just Unsnoc >> ConcatMap (ShowP Id) (Fst Id) <> "-" <> ShowP (Snd Id) +type Isbn13fmt = 'Just Unsnoc >> ConcatMap (ShowP Id) Fst <> "-" <> ShowP Snd -- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07" type DateFmts = '["%Y-%m-%d", "%m/%d/%y", "%B %d %Y"] --- | \'ip\' type for reading one of many date formats from 'DateFmts' +-- | @ip@ type for reading one of many date formats from 'DateFmts' type DateNip = ParseTimes Day DateFmts Id type DateTimeFmts = '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] --- | \'ip\' type for reading one of many date time formats from 'DateTimeFmts' +-- | @ip@ type for reading one of many date time formats from 'DateTimeFmts' type DateTimeNip = ParseTimes UTCTime DateTimeFmts Id -- ParseTimeP is easier and accurate @@ -221,9 +203,10 @@ Guards '[ '(PrintT "guard(%d) day %d is out of range" Id, Between 1 31 Id) , '(PrintT "guard(%d) month %d is out of range" Id, Between 1 12 Id) , '(PrintT "guard(%d) year %d is out of range" Id, Between 1990 2050 Id) ] + >> 'True -} --type Ddmmyyyyop' = GuardsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id] -type Ddmmyyyyop = GuardsDetail "%s %d is out of range" '[ '("day", Between 1 31 Id), '("month", Between 1 12 Id), '("year", Between 1990 2050 Id) ] +type Ddmmyyyyop = GuardsDetail "%s %d is out of range" '[ '("day", Between 1 31 Id), '("month", Between 1 12 Id), '("year", Between 1990 2050 Id) ] >> 'True type Ddmmyyyyop' = Bools '[ '("day", Between 1 31 Id), '("month", Between 1 12 Id), '("year", Between 1990 2050 Id) ] --type Ddmmyyyyop'''' = BoolsQuick (PrintT "guard(%d) %d is out of range" Id) '[Between 1 31 Id, Between 1 12 Id, Between 1990 2050 Id] @@ -231,39 +214,35 @@ Guard (PrintT "incorrect number of digits found %d but expected %d in [%s]" '(Len, n, ShowP Id)) (Len == n) >> Do '[ Reverse - ,Zip (Cycle n [1,2]) Id - ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id + ,ZipWith (Fst * Snd >> If (Id >= 10) (Id - 9) Id) (Cycle n [1,2]) Id ,Sum ] >> Guard (PrintT "expected %d mod 10 = 0 but found %d" '(Id, Id `Mod` 10)) (Mod Id 10 == 0) -type Luhn'' (n :: Nat) = Luhnip >> Luhnop' n - type Luhn' (n :: Nat) = Msg "Luhn'" (Do - '[Guard (PrintT "incorrect number of digits found %d but expected %d in [%s]" '(Len, n, Id)) (Len == n) + '[Guard (PrintT "incorrect length: found %d but expected %d in [%s]" '(Len, n, Id)) (Len == n) ,Do - '[Ones Id - ,Map (ReadP Int Id) Id + '[Ones + ,Map (ReadP Int Id) ,Reverse - ,Zip (Cycle n [1,2]) Id - ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id + ,ZipWith (Fst * Snd >> If (Id >= 10) (Id - 9) Id) (Cycle n [1,2]) Id ,Sum ] ,Guard (PrintT "expected %d mod 10 = 0 but found %d" '(Id, Id `Mod` 10)) (Mod Id 10 == 0) ]) -- convert json microsoft datetime to zonedtime ---type JsonMicrosoftDateTime = Rescan "^Date\\((\\d+[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" Id +--type JsonMicrosoftDateTime = Rescan "^Date\\((\\d+[+-]\\d{4})\\)" >> Head >> Snd >> Id !! 0 >> ReplaceOneString 'RPrepend "\\d{3}[+-]" "." Id >> ParseTimeP ZonedTime "%s%Q%z" --- type JsonMicrosoftDateTime = Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" Id >> Head Id >> Snd Id >> (Id !! 0 <> "." <> Id !! 1) >> ParseTimeP ZonedTime "%s%Q%z" Id +-- type JsonMicrosoftDateTime = Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" >> Head >> Snd >> (Id !! 0 <> "." <> Id !! 1) >> ParseTimeP ZonedTime "%s%Q%z" -- jam the values together -- eg pu @JsonMicrosoftDateTime "Date(1593460089052+0800)" type JsonMicrosoftDateTime = - Do '[ Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" Id - , Head Id - , Snd Id + Do '[ Rescan "^Date\\((\\d+)(\\d{3}[+-]\\d{4})\\)" + , Head + , Snd , Id !! 0 <> "." <> Id !! 1 - , ParseTimeP ZonedTime "%s%Q%z" Id + , ParseTimeP ZonedTime "%s%Q%z" ]
− src/Predicate/Examples/Refined1.hs
@@ -1,55 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wno-unused-imports #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoStarIsType #-} -{- | - Contains imports needed for 'Refined1' --} -module Predicate.Examples.Refined1 where -import Predicate.Examples.Common -import Predicate.Refined -import Predicate.Refined1 -import Predicate.Refined3 -import Predicate.Examples.Refined3 -import Predicate.Core -import Predicate.Prelude -import Predicate.Util -import Predicate.Util_TH -import Predicate.TH_Orphans () -import Data.Proxy -import GHC.TypeLits (KnownNat, Nat) -import Data.Kind (Type) -import Data.Time - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> :set -XTemplateHaskell --- >>> :m + Data.Ratio - --- | refined1 tests --- --- >>> newRefined1P (readshow @OZ @Rational) "13 % 3" --- Right (Refined1 (13 % 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" --- Right (Refined1 ((-13) % 3)) ---
src/Predicate/Examples/Refined2.hs view
@@ -1,13 +1,7 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} {-# OPTIONS -Wno-unused-imports #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -16,32 +10,27 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NoStarIsType #-} -{- | - Contains prepackaged 4-tuples to use with 'Refined2' --} +-- | Contains prepackaged 4-tuples to use with 'Refined2' module Predicate.Examples.Refined2 ( - -- ** date time checkers + -- ** datetime DateTime1 , datetime1 - , daten , DateN , datetimen , DateTimeN , DateTimeNR - -- *** time checkers + -- ** time , hms , Hms , HmsR - --- , hms' , Hms' , HmsR' -- ** credit cards - , Ccn - , cc11 + , Luhn + , luhn11 -- ** ssn , ssn @@ -79,139 +68,138 @@ , BaseIJ' , BaseIJip ) where -import Predicate.Core -import Predicate.Refined import Predicate.Refined2 import Predicate.Examples.Common -import Predicate.Prelude -import Predicate.Util -import Predicate.Util_TH -import Predicate.TH_Orphans () +import Predicate import GHC.TypeLits (Nat) -import Data.Time -import Data.Kind -import Data.Proxy +import Data.Time (Day, UTCTime) +import Data.Kind (Type) +import Data.Proxy (Proxy(..)) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XTemplateHaskell +-- >>> :set -XTypeApplications +-- >>> :m + Data.Time +-- >>> :m + Control.Lens +-- >>> :m + Text.Show.Functions -- | credit card with luhn algorithm -- --- >>> newRefined2 @OZ @Ccip @(Ccop 11) "1234-5678-901" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- >>> newRefined2 @OZ @Luhnip @(Luhnop 11) "1234-5678-901" +-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit -- --- >>> 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"}) +-- >>> newRefined2 @OZ @Luhnip @(Luhnop 11) "1234-5678-903" +-- Right (Refined2 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") -- --- >>> pz @(Ccip >> Ccop 11) "79927398713" --- TrueT +-- >>> pz @(Luhnip >> Luhnop 11) "79927398713" +-- Val True -- --- >>> pz @(Ccip >> Ccop 10) "79927398713" --- FailT "expected 10 digits but found 11" +-- >>> pz @(Luhnip >> Luhnop 10) "79927398713" +-- Fail "expected 10 digits but found 11" -- -type Ccn (opts :: OptT) (n :: Nat) = '(opts, Ccip, Ccop n, String) +type Luhn (opts :: Opt) (n :: Nat) = '(opts, Luhnip, Luhnop n, String) -- | read in a valid datetime -- -- >>> 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"}) +-- Right (Refined2 2018-09-14 02:57:04 "2018-09-14 02:57:04") -- -- >>> 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" +-- Left Step 1. Failed Initial Conversion(ip) | ParseTimeP LocalTime (%F %T) failed to parse -- datetime1 :: Proxy (DateTime1 opts t) datetime1 = mkProxy2 -type DateTime1 (opts :: OptT) (t :: Type) = '(opts, Dtip t, 'True, String) +type DateTime1 (opts :: Opt) (t :: Type) = '(opts, Dtip t, 'True, String) -datetimen :: OptTC opts => Proxy (DateTimeN opts) +datetimen :: OptC opts => Proxy (DateTimeN opts) datetimen = mkProxy2' -- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07" -type DateN (opts :: OptT) = '(opts,ParseTimes Day DateFmts Id, 'True, String) +type DateN (opts :: Opt) = '(opts,ParseTimes Day DateFmts Id, 'True, String) -daten :: OptTC opts => Proxy (DateN opts) +daten :: OptC opts => Proxy (DateN opts) daten = mkProxy2' -type DateTimeNR (opts :: OptT) = MakeR2 (DateTimeN opts) -type DateTimeN (opts :: OptT) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, String) +type DateTimeNR (opts :: Opt) = MakeR2 (DateTimeN opts) +type DateTimeN (opts :: Opt) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, String) -- | read in an ssn -- -- >>> newRefined2 @OZ @Ssnip @Ssnop "134-01-2211" --- Right (Refined2 {r2In = [134,1,2211], r2Out = "134-01-2211"}) +-- Right (Refined2 [134,1,2211] "134-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))}" +-- Left Step 2. Failed Boolean Check(op) | Bool(0) [number for group 0 invalid: found 666] (True && False | (666 /= 666)) -- -- >>> 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)}" +-- Left Step 2. Failed Boolean Check(op) | Bool(1) [number for group 1 invalid: found 0] (1 <= 0) -- -ssn :: OptTC opts => Proxy (Ssn opts) +ssn :: OptC opts => Proxy (Ssn opts) ssn = mkProxy2' -type SsnR (opts :: OptT) = MakeR2 (Ssn opts) -type Ssn (opts :: OptT) = '(opts, Ssnip, Ssnop, String) +type SsnR (opts :: Opt) = MakeR2 (Ssn opts) +type Ssn (opts :: Opt) = '(opts, Ssnip, Ssnop, String) -- | read in a time and validate it -- -- >>> newRefined2 @OL @Hmsip @Hmsop' "23:13:59" --- Right (Refined2 {r2In = [23,13,59], r2Out = "23:13:59"}) +-- Right (Refined2 [23,13,59] "23:13:59") -- -- >>> newRefined2 @OL @Hmsip @Hmsop' "23:13:60" --- Left "Step 2. False Boolean Check(op) | {Bool(2) [seconds] (60 <= 59)}" +-- Left Step 2. Failed Boolean Check(op) | Bool(2) [seconds] (60 <= 59) -- -- >>> newRefined2 @OL @Hmsip @Hmsop' "26:13:59" --- Left "Step 2. False Boolean Check(op) | {Bool(0) [hours] (26 <= 23)}" +-- Left Step 2. Failed Boolean Check(op) | Bool(0) [hours] (26 <= 23) -- -hms :: OptTC opts => Proxy (Hms opts) +hms :: OptC opts => Proxy (Hms opts) hms = mkProxy2' -type HmsR (opts :: OptT) = MakeR2 (Hms opts) -type Hms (opts :: OptT) = '(opts, Hmsip, Hmsop >> 'True, String) +type HmsR (opts :: Opt) = MakeR2 (Hms opts) +type Hms (opts :: Opt) = '(opts, Hmsip, Hmsop, String) --hms' :: Proxy (Hms' OZ) --hms' = mkProxy2' -type HmsR' (opts :: OptT) = MakeR2 (Hms' opts) -type Hms' (opts :: OptT) = '(opts, Hmsip, Hmsop', String) +type HmsR' (opts :: Opt) = MakeR2 (Hms' opts) +type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', String) -- | read in an ipv4 address and validate it -- -- >>> newRefined2 @OZ @Ip4ip @Ip4op' "001.223.14.1" --- Right (Refined2 {r2In = [1,223,14,1], r2Out = "001.223.14.1"}) +-- Right (Refined2 [1,223,14,1] "001.223.14.1") -- -- >>> 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)}" +-- Left Step 2. Failed Boolean Check(op) | Bool(3) [octet 3 out of range 0-255 found 999] (999 <= 255) -- -- >>> newRefined2P (ip4 @OL) "001.223.14.999" --- Left "Step 2. Failed Boolean Check(op) | octet 3 out of range 0-255 found 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" --- Left "Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4" +-- Left Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4 -- -- >>> newRefined2P (ip4 @OL) "001.257.14.1" --- Left "Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257" +-- Left Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257 -- -type Ip4R (opts :: OptT) = MakeR2 (Ip4 opts) -type Ip4 (opts :: OptT) = '(opts, Ip4ip, Ip4op >> 'True, String) -- guards +type Ip4R (opts :: Opt) = MakeR2 (Ip4 opts) +type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, String) -- guards ip4 :: Proxy (Ip4 opts) ip4 = Proxy -type Ip4R' (opts :: OptT) = MakeR2 (Ip4' opts) -type Ip4' (opts :: OptT) = '(opts, Ip4ip, Ip4op', String) -- boolean predicates +type Ip4R' (opts :: Opt) = MakeR2 (Ip4' opts) +type Ip4' (opts :: Opt) = '(opts, Ip4ip, Ip4op', String) -- boolean predicates ip4' :: Proxy (Ip4' opts) ip4' = Proxy -type Ip6R (opts :: OptT) = MakeR2 (Ip6 opts) -type Ip6 (opts :: OptT) = '(opts, Ip6ip, Ip6op, String) -- guards +type Ip6R (opts :: Opt) = MakeR2 (Ip6 opts) +type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, String) -- guards ip6 :: Proxy (Ip6 opts) ip6 = Proxy @@ -219,13 +207,13 @@ -- | validate isbn10 -- -- >>> newRefined2P (isbn10 @OZ) "0-306-40611-X" --- Right (Refined2 {r2In = ([0,3,0,6,4,0,6,1,1],10), r2Out = "0-306-40611-X"}) +-- Right (Refined2 ([0,3,0,6,4,0,6,1,1],10) "0-306-40611-X") -- -- >>> newRefined2P (isbn10 @OZ) "0-306-40611-9" --- Left "Step 2. Failed Boolean Check(op) | mod 0 oops" +-- Left Step 2. Failed Boolean Check(op) | mod 0 oops -- -type Isbn10R (opts :: OptT) = MakeR2 (Isbn10 opts) -type Isbn10 (opts :: OptT) = '(opts, Isbn10ip, Isbn10op, String) -- guards +type Isbn10R (opts :: Opt) = MakeR2 (Isbn10 opts) +type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, String) -- guards isbn10 :: Proxy (Isbn10 opts) isbn10 = Proxy @@ -233,97 +221,115 @@ -- | validate isbn13 -- -- >>> newRefined2P (isbn13 @OZ) "978-0-306-40615-7" --- Right (Refined2 {r2In = [9,7,8,0,3,0,6,4,0,6,1,5,7], r2Out = "978-0-306-40615-7"}) +-- Right (Refined2 [9,7,8,0,3,0,6,4,0,6,1,5,7] "978-0-306-40615-7") -- -- >>> newRefined2P (isbn13 @OZ) "978-0-306-40615-8" --- Left "Step 2. Failed Boolean Check(op) | sum=101 mod 10=1" +-- Left Step 2. Failed Boolean Check(op) | sum=101 mod 10=1 -- -type Isbn13R (opts :: OptT) = MakeR2 (Isbn13 opts) -type Isbn13 (opts :: OptT) = '(opts, Isbn13ip, Isbn13op, String) -- guards +type Isbn13R (opts :: Opt) = MakeR2 (Isbn13 opts) +type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, String) -- guards isbn13 :: Proxy (Isbn13 opts) isbn13 = Proxy -cc11 :: Proxy (Ccn opts 11) -cc11 = Proxy +luhn11 :: Proxy (Luhn opts 11) +luhn11 = Proxy -- | 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" --- Right (Refined2 {r2In = 254, r2Out = "00fe"}) +-- >>> newRefined2 @OZ @(ReadBase Int 16) @'True "00fe" +-- Right (Refined2 254 "00fe") -- --- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(Between 100 400 Id) "00fe" --- Right (Refined2 {r2In = 254, r2Out = "00fe"}) +-- >>> newRefined2 @OZ @(ReadBase Int 16) @(Between 100 400 Id) "00fe" +-- Right (Refined2 254 "00fe") -- --- >>> newRefined2 @OZ @(ReadBase Int 16 Id) @(GuardSimple (Id < 400) >> 'True) "f0fe" --- Left "Step 2. Failed Boolean Check(op) | (61694 < 400)" +-- >>> newRefined2 @OZ @(ReadBase Int 16) @(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 --- Left "Step 2. False Boolean Check(op) | {61694 < 400}" +-- >>> newRefined2 @OL @(ReadBase Int 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 -type BaseN' (opts :: OptT) (n :: Nat) p = '(opts,ReadBase Int n Id, p, String) +type BaseN (opts :: Opt) (n :: Nat) = BaseN' opts n 'True +type BaseN' (opts :: Opt) (n :: Nat) p = '(opts,ReadBase Int n, p, String) -- | Luhn check -- -- >>> newRefined2 @OZ @Luhnip @(Luhnop 4) "1230" --- Right (Refined2 {r2In = [1,2,3,0], r2Out = "1230"}) +-- Right (Refined2 [1,2,3,0] "1230") -- -- >>> 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])}" +-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit -- --- | uses builtin 'Luhn' +-- | uses builtin 'IsLuhn' -- | convert a string from a given base \'i\' and store it internally as a base \'j\' string -- -- >>> newRefined2 @OZ @(BaseIJip 16 2) @'True "fe" --- Right (Refined2 {r2In = "11111110", r2Out = "fe"}) +-- Right (Refined2 "11111110" "fe") -- -- >>> newRefined2 @OZ @(BaseIJip 16 2) @'True "fge" --- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" +-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16 -- --- >>> newRefined2 @OL @(BaseIJip 16 2) @(ReadBase Int 2 Id < 1000) "ffe" --- Left "Step 2. False Boolean Check(op) | {4094 < 1000}" +-- >>> newRefined2 @OL @(BaseIJip 16 2) @(ReadBase Int 2 < 1000) "ffe" +-- Left Step 2. False Boolean Check(op) | {4094 < 1000} -- -type BaseIJip (i :: Nat) (j :: Nat) = ReadBase Int i Id >> ShowBase j Id +type BaseIJip (i :: Nat) (j :: Nat) = ReadBase Int i >> ShowBase j type BaseIJ (i :: Nat) (j :: Nat) = BaseIJ' i j 'True -type BaseIJ' (i :: Nat) (j :: Nat) p = '(ReadBase Int i Id >> ShowBase j Id, p, String) +type BaseIJ' (i :: Nat) (j :: Nat) p = '(ReadBase Int i >> ShowBase j, p, String) -- | 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" --- Right (Refined2 {r2In = 13 % 3, r2Out = "13 % 3"}) +-- Right (Refined2 (13 % 3) "13 % 3") -- -- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "13x % 3" --- Left "Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3)" +-- Left Step 1. Failed Initial Conversion(ip) | ReadP Ratio Integer (13x % 3) -- -- >>> newRefined2 @OZ @(ReadP Rational Id) @(3 % 1 <..> 5 % 1) "13 % 3" --- Right (Refined2 {r2In = 13 % 3, r2Out = "13 % 3"}) +-- Right (Refined2 (13 % 3) "13 % 3") -- -- >>> newRefined2 @OZ @(ReadP Rational Id) @(11 -% 2 <..> 3 -% 1) "-13 % 3" --- Right (Refined2 {r2In = (-13) % 3, r2Out = "-13 % 3"}) +-- Right (Refined2 ((-13) % 3) "-13 % 3") -- -- >>> newRefined2 @OZ @(ReadP Rational Id) @(Id > (15 % 1)) "13 % 3" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- 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" --- Left "Step 2. False Boolean Check(op) | {invalid=4.33 13 % 3 > 15 % 1}" +-- >>> newRefined2 @OL @(ReadP Rational Id) @(Msg (PrintF "invalid=%3.2f" (FromRational Double)) (Id > (15 % 1))) "13 % 3" +-- Left Step 2. False Boolean Check(op) | {invalid=4.33 13 % 3 > 15 % 1} -- -- >>> newRefined2 @OZ @(ReadP Rational Id) @(Id > (11 % 1)) "13 % 3" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- Left Step 2. False Boolean Check(op) | FalseP -- -- >>> 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"}) +-- Right (Refined2 2018-10-19 14:53:11.5121359 UTC "2018-10-19 14:53:11.5121359 UTC") -- -- >>> :m + Data.Aeson -- >>> newRefined2 @OZ @(ReadP Value Id) @'True "String \"jsonstring\"" --- Right (Refined2 {r2In = String "jsonstring", r2Out = "String \"jsonstring\""}) +-- Right (Refined2 (String "jsonstring") "String \"jsonstring\"") -- -- >>> newRefined2 @OZ @(ReadP Value Id) @'True "Number 123.4" --- Right (Refined2 {r2In = Number 123.4, r2Out = "Number 123.4"}) +-- Right (Refined2 (Number 123.4) "Number 123.4") -- +-- >>> newRefined @OU @((Id $$ 13) > 100) (\x -> x * 14) +-- Right (Refined <function>) +-- +-- >>> newRefined2 @OU @(Id $$ 13) @(Id > 100) (\x -> x * 14) ^? _Right . to r2Out +-- Just <function> +-- +-- >>> newRefined2 @OU @(Id $$ 13) @(Id > 100) (\x -> x * 14) ^? _Right . to r2In +-- Just 182 +-- +-- >>> newRefined2 @OU @(Id $$ 13) @(Id > 100) (\x -> x * 14) ^? _Right . to (($ 13) . r2Out) +-- Just 182 +-- +-- >>> newRefined2 @OZ @(Pop0 Fst Id) @(Len > 1) (Proxy @Snd,"Abcdef") ^? _Right . to r2In +-- Just "Abcdef" +-- +-- >>> newRefined2 @OZ @(Pop0 Fst Id >> Len) @(Id > 1) (Proxy @Snd,"Abcdef") ^? _Right . to r2In +-- Just 6 +--
src/Predicate/Examples/Refined3.hs view
@@ -1,14 +1,7 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# OPTIONS -Wincomplete-record-updates #-} {-# OPTIONS -Wno-unused-imports #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -17,34 +10,30 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NoStarIsType #-} -{- | - Contains prepackaged 5-tuples and proxies to use with 'Refined3' --} +-- | Contains prepackaged 5-tuples and proxies to use with 'Refined3' module Predicate.Examples.Refined3 ( - -- ** date time checkers + -- ** datetime datetime1 , DateTime1 - , daten , DateN , datetimen , DateTimeN , DateTimeNR - -- *** time checkers + -- ** time , hms , Hms , HmsR - , Hms' , HmsR' -- ** credit cards - , ccn - , ccn' - , Ccn - , cc11 - , Cc11 + , luhn + , luhn' + , Luhn + , luhn11 + , Luhn11 , LuhnR , LuhnT @@ -99,7 +88,6 @@ -- ** between , between - , BetweenR , BetweenN -- ** miscellaneous @@ -112,70 +100,67 @@ ) where import Predicate.Examples.Common -import Predicate.Refined import Predicate.Refined3 -import Predicate.Core -import Predicate.Prelude -import Predicate.Util -import Predicate.Util_TH -import Predicate.TH_Orphans () -import Data.Proxy +import Predicate +import Data.Proxy (Proxy(..)) import GHC.TypeLits (KnownNat, Nat) import Data.Kind (Type) -import Data.Time +import Data.Time (Day, UTCTime) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XTemplateHaskell +-- >>> :set -XTypeApplications +-- >>> :m + Data.Time -- | credit card with luhn algorithm -- --- >>> newRefined3P (cc11 @OZ) "1234-5678-901" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- >>> newRefined3P (luhn11 @OZ) "1234-5678-901" +-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit -- --- >>> newRefined3P (cc11 @OZ) "1234-5678-903" --- Right (Refined3 {r3In = [1,2,3,4,5,6,7,8,9,0,3], r3Out = "1234-5678-903"}) +-- >>> newRefined3P (luhn11 @OZ) "1234-5678-903" +-- Right (Refined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") -- --- >>> pz @(Ccip >> Ccop 11) "79927398713" --- TrueT +-- >>> pz @(Luhnip >> Luhnop 11) "79927398713" +-- Val True -- --- >>> pz @(Ccip >> Ccop 10) "79927398713" --- FailT "expected 10 digits but found 11" +-- >>> pz @(Luhnip >> Luhnop 10) "79927398713" +-- Fail "expected 10 digits but found 11" -- -type Ccn (opts :: OptT) (ns :: [Nat]) = '(opts, Ccip, Ccop (SumT ns), Ccfmt ns, String) +type Luhn (opts :: Opt) (ns :: [Nat]) = '(opts, Luhnip, Luhnop (SumT ns), Luhnfmt ns, String) -type Cc11 (opts :: OptT) = Ccn opts '[4,4,3] +type Luhn11 (opts :: Opt) = Luhn opts '[4,4,3] -ccn :: Proxy (Ccn opts ns) -ccn = mkProxy3 +luhn :: Proxy (Luhn opts ns) +luhn = mkProxy3 -- works but have to add all the constraints -ccn' :: ( OptTC opts +luhn' :: ( OptC opts , PP ns String ~ [Integer] , KnownNat (SumT ns) , P ns String - ) => Proxy (Ccn opts ns) -ccn' = mkProxy3' + ) => Proxy (Luhn opts ns) +luhn' = mkProxy3' -cc11 :: OptTC opts => Proxy (Ccn opts '[4,4,3]) -- or Proxy Cc11 -cc11 = mkProxy3' +luhn11 :: OptC opts => Proxy (Luhn opts '[4,4,3]) -- or Proxy Luhn11 +luhn11 = mkProxy3' -- | read in a valid datetime -- -- >>> 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"}) +-- Right (Refined3 2018-09-14 02:57:04 "2018-09-14 02:57:04") -- -- >>> newRefined3P (datetime1 @OL @LocalTime) "2018-09-99 12:12:12" --- Left "Step 1. Initial Conversion(ip) Failed | ParseTimeP LocalTime (%F %T) failed to parse" +-- Left Step 1. Failed Initial Conversion(ip) | ParseTimeP LocalTime (%F %T) failed to parse -- datetime1 :: Proxy (DateTime1 opts t) datetime1 = mkProxy3 -- now that time is actually validated we dont need Dtop* -type DateTime1 (opts :: OptT) (t :: Type) = '(opts, Dtip t, 'True, Dtfmt, String) +type DateTime1 (opts :: Opt) (t :: Type) = '(opts, Dtip t, 'True, Dtfmt, String) -- fixed in time-1.9 -- extra check to validate the time as parseTime doesnt validate the time component @@ -184,76 +169,76 @@ -- 2018-09-14 99:00:96 becomes 2018-09-18 03:01:36 -- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07" -type DateN (opts :: OptT) = '(opts, ParseTimes Day DateFmts Id, 'True, FormatTimeP "%Y-%m-%d" Id, String) +type DateN (opts :: Opt) = '(opts, ParseTimes Day DateFmts Id, 'True, FormatTimeP "%Y-%m-%d", String) -type DateTimeNR (opts :: OptT) = MakeR3 (DateTimeN opts) -type DateTimeN (opts :: OptT) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, FormatTimeP "%Y-%m-%d %H:%M:%S" Id, String) +type DateTimeNR (opts :: Opt) = MakeR3 (DateTimeN opts) +type DateTimeN (opts :: Opt) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, FormatTimeP "%Y-%m-%d %H:%M:%S" , String) -ssn :: OptTC opts => Proxy (Ssn opts) +ssn :: OptC opts => Proxy (Ssn opts) ssn = mkProxy3' -- | read in an ssn -- -- >>> newRefined3P (ssn @OZ) "134-01-2211" --- Right (Refined3 {r3In = [134,1,2211], r3Out = "134-01-2211"}) +-- Right (Refined3 [134,1,2211] "134-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))}" +-- Left Step 2. Failed Boolean Check(op) | Bool(0) [number for group 0 invalid: found 666] (True && False | (666 /= 666)) -- -- >>> newRefined3P (ssn @OL) "667-00-2211" --- Left "Step 2. False Boolean Check(op) | {Bool(1) [number for group 1 invalid: found 0] (1 <= 0)}" +-- Left Step 2. Failed 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) +type Ssn (opts :: Opt) = '(opts, Ssnip, Ssnop, Ssnfmt, String) +type SsnR (opts :: Opt) = MakeR3 (Ssn opts) -- | read in a time and validate it -- -- >>> newRefined3P (hms @OL) "23:13:59" --- Right (Refined3 {r3In = [23,13,59], r3Out = "23:13:59"}) +-- Right (Refined3 [23,13,59] "23:13:59") -- -- >>> newRefined3P (hms @OL) "23:13:60" --- Left "Step 2. Failed Boolean Check(op) | seconds invalid: found 60" +-- Left Step 2. Failed Boolean Check(op) | seconds invalid: found 60 -- -- >>> newRefined3P (hms @OL) "26:13:59" --- Left "Step 2. Failed Boolean Check(op) | hours invalid: found 26" +-- Left Step 2. Failed Boolean Check(op) | hours invalid: found 26 -- -hms :: OptTC opts => Proxy (Hms opts) +hms :: OptC opts => Proxy (Hms opts) hms = mkProxy3' -type HmsR (opts :: OptT) = MakeR3 (Hms opts) -type Hms (opts :: OptT) = '(opts, Hmsip, Hmsop >> 'True, Hmsfmt, String) +type HmsR (opts :: Opt) = MakeR3 (Hms opts) +type Hms (opts :: Opt) = '(opts, Hmsip, Hmsop, Hmsfmt, String) -type HmsR' (opts :: OptT) = MakeR3 (Hms' opts) -type Hms' (opts :: OptT) = '(opts, Hmsip, Hmsop', Hmsfmt, String) +type HmsR' (opts :: Opt) = MakeR3 (Hms' opts) +type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', Hmsfmt, String) -- | read in an ipv4 address and validate it -- -- >>> newRefined3P (ip4 @OZ) "001.223.14.1" --- Right (Refined3 {r3In = [1,223,14,1], r3Out = "001.223.014.001"}) +-- Right (Refined3 [1,223,14,1] "001.223.014.001") -- -- >>> newRefined3P (ip4 @OL) "001.223.14.999" --- Left "Step 2. Failed Boolean Check(op) | octet 3 out of range 0-255 found 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" --- Left "Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4" +-- Left Step 2. Failed Boolean Check(op) | Guards:invalid length(5) expected 4 -- -- >>> newRefined3P (ip4 @OL) "001.257.14.1" --- Left "Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257" +-- Left Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257 -- -type Ip4R (opts :: OptT) = MakeR3 (Ip4 opts) -type Ip4 (opts :: OptT) = '(opts, Ip4ip, Ip4op >> 'True, Ip4fmt, String) -- guards +type Ip4R (opts :: Opt) = MakeR3 (Ip4 opts) +type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, Ip4fmt, String) -- guards -ip4 :: OptTC opts => Proxy (Ip4 opts) +ip4 :: OptC opts => Proxy (Ip4 opts) ip4 = mkProxy3' -type Ip4R' (opts :: OptT) = MakeR3 (Ip4' opts) -type Ip4' (opts :: OptT) = '(opts, Ip4ip, Ip4op', Ip4fmt, String) -- boolean predicates +type Ip4R' (opts :: Opt) = MakeR3 (Ip4' opts) +type Ip4' (opts :: Opt) = '(opts, Ip4ip, Ip4op', Ip4fmt, String) -- boolean predicates -ip4' :: OptTC opts => Proxy (Ip4' opts) +ip4' :: OptC opts => Proxy (Ip4' opts) ip4' = mkProxy3' -type Ip6R (opts :: OptT) = MakeR3 (Ip6 opts) -type Ip6 (opts :: OptT) = '(opts, Ip6ip, Ip6op, Ip6fmt, String) -- guards +type Ip6R (opts :: Opt) = MakeR3 (Ip6 opts) +type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, Ip6fmt, String) -- guards ip6 :: Proxy (Ip6 opts) ip6 = Proxy @@ -261,13 +246,13 @@ -- | validate isbn10 -- -- >>> newRefined3P (isbn10 @OZ) "0-306-40611-X" --- Right (Refined3 {r3In = ([0,3,0,6,4,0,6,1,1],10), r3Out = "030640611-X"}) +-- Right (Refined3 ([0,3,0,6,4,0,6,1,1],10) "030640611-X") -- -- >>> newRefined3P (isbn10 @OZ) "0-306-40611-9" --- Left "Step 2. Failed Boolean Check(op) | mod 0 oops" +-- Left Step 2. Failed Boolean Check(op) | mod 0 oops -- -type Isbn10R (opts :: OptT) = MakeR3 (Isbn10 opts) -type Isbn10 (opts :: OptT) = '(opts, Isbn10ip, Isbn10op, Isbn10fmt, String) -- guards +type Isbn10R (opts :: Opt) = MakeR3 (Isbn10 opts) +type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, Isbn10fmt, String) -- guards isbn10 :: Proxy (Isbn10 opts) isbn10 = Proxy @@ -275,13 +260,13 @@ -- | validate isbn13 -- -- >>> newRefined3P (isbn13 @OZ) "978-0-306-40615-7" --- Right (Refined3 {r3In = [9,7,8,0,3,0,6,4,0,6,1,5,7], r3Out = "978030640615-7"}) +-- Right (Refined3 [9,7,8,0,3,0,6,4,0,6,1,5,7] "978030640615-7") -- -- >>> newRefined3P (isbn13 @OZ) "978-0-306-40615-8" --- Left "Step 2. Failed Boolean Check(op) | sum=101 mod 10=1" +-- Left Step 2. Failed Boolean Check(op) | sum=101 mod 10=1 -- -type Isbn13R (opts :: OptT) = MakeR3 (Isbn13 opts) -type Isbn13 (opts :: OptT) = '(opts, Isbn13ip, Isbn13op, Isbn13fmt, String) -- guards +type Isbn13R (opts :: Opt) = MakeR3 (Isbn13 opts) +type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, Isbn13fmt, String) -- guards isbn13 :: Proxy (Isbn13 opts) isbn13 = Proxy @@ -289,19 +274,22 @@ -- | convert a string from a given base \'i\' and store it internally as an base 10 integer -- -- >>> newRefined3P (base16 @OZ) "00fe" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- Right (Refined3 254 "fe") -- -- >>> newRefined3P (basen' @OZ @16 @(100 <..> 400)) "00fe" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- Right (Refined3 254 "fe") -- -- >>> newRefined3P (basen' @OZ @16 @(GuardSimple (Id < 400) >> 'True)) "f0fe" --- Left "Step 2. Failed Boolean Check(op) | (61694 < 400)" +-- Left Step 2. Failed Boolean Check(op) | (61694 < 400) -- --- >>> newRefined3P (basen' @OL @16 @(Id < 400)) "f0fe" -- todo: why different parens vs braces --- Left "Step 2. False Boolean Check(op) | {61694 < 400}" +-- >>> newRefined3P (basen' @OZ @16 @(GuardBool (PrintF "oops bad hex=%d" Id) (Id < 400))) "f0fe" +-- Left Step 2. Failed Boolean Check(op) | oops bad hex=61694 -- -type BaseN (opts :: OptT) (n :: Nat) = BaseN' opts n 'True -type BaseN' (opts :: OptT) (n :: Nat) p = '(opts, ReadBase Int n Id, p, ShowBase n Id, String) +-- >>> newRefined3P (basen' @OL @16 @(Id < 400)) "f0fe" +-- Left Step 2. False Boolean Check(op) | {61694 < 400} +-- +type BaseN (opts :: Opt) (n :: Nat) = BaseN' opts n 'True +type BaseN' (opts :: Opt) (n :: Nat) p = '(opts, ReadBase Int n, p, ShowBase n, String) base16 :: Proxy (BaseN opts 16) base16 = basen @@ -321,29 +309,25 @@ basen' :: Proxy (BaseN' opts n p) basen' = mkProxy3 -daten :: OptTC opts => Proxy (DateN opts) +daten :: OptC opts => Proxy (DateN opts) daten = mkProxy3' -datetimen :: OptTC opts => Proxy (DateTimeN opts) +datetimen :: OptC opts => Proxy (DateTimeN opts) datetimen = mkProxy3' -- | ensures that two numbers are in a given range (emulates 'Refined.Refined') -- -- >>> newRefined3P (between @OZ @10 @16) 14 --- Right (Refined3 {r3In = 14, r3Out = 14}) +-- Right (Refined3 14 14) -- -- >>> newRefined3P (between @OZ @10 @16) 17 --- Left "Step 2. False Boolean Check(op) | FalseP" +-- Left Step 2. False Boolean Check(op) | FalseP -- --- >>> prtEval3P (between @OAN @10 @16) 17 +-- >>> newRefined3P (between @OAN @10 @16) 17 -- Left Step 2. False Boolean Check(op) | {17 <= 16} --- <BLANKLINE> -- *** Step 1. Success Initial Conversion(ip) (17) *** --- <BLANKLINE> -- P Id 17 --- <BLANKLINE> -- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> -- False 17 <= 16 -- | -- +- P Id 17 @@ -351,42 +335,40 @@ -- +- P '10 -- | -- `- P '16 --- <BLANKLINE> -- between :: Proxy (BetweenN opts m n) between = mkProxy3 -type BetweenN (opts :: OptT) m n = '(opts, Id, Between m n Id, Id, Int) -type BetweenR (opts :: OptT) m n = RefinedEmulate opts (Between m n Id) Int +type BetweenN (opts :: Opt) m n = '(opts, Id, Between m n Id, Id, Int) -type LuhnR (opts :: OptT) (n :: Nat) = MakeR3 (LuhnT opts n) +type LuhnR (opts :: Opt) (n :: Nat) = MakeR3 (LuhnT opts n) -- | Luhn check -- -- >>> newRefined3P (Proxy @(LuhnT OZ 4)) "1230" --- Right (Refined3 {r3In = [1,2,3,0], r3Out = "1230"}) +-- Right (Refined3 [1,2,3,0] "1230") -- -- >>> 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])}" +-- Left Step 2. False Boolean Check(op) | {True && False | (IsLuhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4])} -- --- | uses builtin 'Luhn' -type LuhnT (opts :: OptT) (n :: Nat) = +-- | uses builtin 'IsLuhn' +type LuhnT (opts :: Opt) (n :: Nat) = '(opts - , Map (ReadP Int Id) (Ones Id) + , Map' (ReadP Int Id) Ones , Msg "incorrect number of digits:" - (Len == n) && Luhn Id + (Len == n) && IsLuhn , ConcatMap (ShowP Id) Id , String) -- | noop true -type Ok (opts :: OptT) (t :: Type) = '(opts, Id, 'True, Id, t) -type OkR (opts :: OptT) (t :: Type) = MakeR3 (Ok opts t) +type Ok (opts :: Opt) (t :: Type) = '(opts, Id, 'True, Id, t) +type OkR (opts :: Opt) (t :: Type) = MakeR3 (Ok opts t) ok :: Proxy (Ok opts t) ok = mkProxy3 -- | noop false -type OkNot (t :: Type) = '( OA, Id, 'False, Id, t) +type OkNot (t :: Type) = '(OAN, Id, 'False, Id, t) type OkNotR (t :: Type) = MakeR3 (OkNot t) oknot :: Proxy (OkNot t) @@ -395,56 +377,56 @@ -- | convert a string from a given base \'i\' and store it internally as a base \'j\' string -- -- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fe" --- Right (Refined3 {r3In = "11111110", r3Out = "fe"}) +-- Right (Refined3 "11111110" "fe") -- -- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fge" --- Left "Step 1. Initial Conversion(ip) Failed | invalid base 16" +-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16 -- --- >>> newRefined3P (Proxy @(BaseIJ' OL 16 2 (ReadBase Int 2 Id < 1000))) "ffe" --- Left "Step 2. False Boolean Check(op) | {4094 < 1000}" +-- >>> newRefined3P (Proxy @(BaseIJ' OL 16 2 (ReadBase Int 2 < 1000))) "ffe" +-- Left Step 2. False Boolean Check(op) | {4094 < 1000} -- -type BaseIJ (opts :: OptT) (i :: Nat) (j :: Nat) = BaseIJ' opts i j 'True -type BaseIJ' (opts :: OptT) (i :: Nat) (j :: Nat) p = '(opts, ReadBase Int i Id >> ShowBase j Id, p, ReadBase Int j Id >> ShowBase i Id, String) +type BaseIJ (opts :: Opt) (i :: Nat) (j :: Nat) = BaseIJ' opts i j 'True +type BaseIJ' (opts :: Opt) (i :: Nat) (j :: Nat) p = '(opts, ReadBase Int i >> ShowBase j, p, ReadBase Int j >> ShowBase i, String) -- | take any valid Read/Show instance and turn it into a valid 'Refined3' -- -- >>> :m + Data.Ratio -- >>> newRefined3P (readshow @OZ @Rational) "13 % 3" --- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) +-- Right (Refined3 (13 % 3) "13 % 3") -- -- >>> newRefined3P (readshow @OZ @Rational) "13x % 3" --- Left "Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3)" +-- Left Step 1. Failed Initial Conversion(ip) | ReadP Ratio Integer (13x % 3) -- -- >>> newRefined3P (readshow' @OZ @Rational @(3 % 1 <..> 5 % 1)) "13 % 3" --- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) +-- Right (Refined3 (13 % 3) "13 % 3") -- -- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (11 -% 2 <..> 3 -% 1))) "-13 % 3" --- Right (Refined3 {r3In = (-13) % 3, r3Out = "(-13) % 3"}) +-- Right (Refined3 ((-13) % 3) "(-13) % 3") -- -- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (Id > (15 % 1)))) "13 % 3" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- 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" --- Left "Step 2. False Boolean Check(op) | {invalid=4.33 13 % 3 > 15 % 1}" +-- >>> newRefined3P (Proxy @(ReadShow' OL Rational (Msg (PrintF "invalid=%3.2f" (FromRational Double)) (Id > (15 % 1))))) "13 % 3" +-- Left Step 2. False Boolean Check(op) | {invalid=4.33 13 % 3 > 15 % 1} -- -- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (Id > (11 % 1)))) "13 % 3" --- Left "Step 2. False Boolean Check(op) | FalseP" +-- Left Step 2. False Boolean Check(op) | FalseP -- -- >>> 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"}) +-- Right (Refined3 2018-10-19 14:53:11.5121359 UTC "2018-10-19 14:53:11.5121359 UTC") -- -- >>> :m + Data.Aeson -- >>> newRefined3P (readshow @OZ @Value) "String \"jsonstring\"" --- Right (Refined3 {r3In = String "jsonstring", r3Out = "String \"jsonstring\""}) +-- Right (Refined3 (String "jsonstring") "String \"jsonstring\"") -- -- >>> newRefined3P (readshow @OZ @Value) "Number 123.4" --- Right (Refined3 {r3In = Number 123.4, r3Out = "Number 123.4"}) +-- Right (Refined3 (Number 123.4) "Number 123.4") -- -type ReadShow (opts :: OptT) (t :: Type) = '(opts, ReadP t Id, 'True, ShowP Id, String) -type ReadShowR (opts :: OptT) (t :: Type) = MakeR3 (ReadShow opts t) +type ReadShow (opts :: Opt) (t :: Type) = '(opts, ReadP t Id, 'True, ShowP Id, String) +type ReadShowR (opts :: Opt) (t :: Type) = MakeR3 (ReadShow opts t) -type ReadShow' (opts :: OptT) (t :: Type) p = '(opts, ReadP t Id, p, ShowP Id, String) -type ReadShowR' (opts :: OptT) (t :: Type) p = MakeR3 (ReadShow' opts t p) +type ReadShow' (opts :: Opt) (t :: Type) p = '(opts, ReadP t Id, p, ShowP Id, String) +type ReadShowR' (opts :: Opt) (t :: Type) p = MakeR3 (ReadShow' opts t p) readshow :: Proxy (ReadShow opts t) readshow = mkProxy3 @@ -456,20 +438,20 @@ -- -- >>> 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] +-- Val [1,2,3,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" +-- Error octet 2 out of range 0-255 found 308 (Guard(2) 308) +-- Fail "octet 2 out of range 0-255 found 308" -- -- -- >>> 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" +-- Error Guards:invalid length(5) expected 4 +-- Fail "Guards:invalid length(5) expected 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" +-- Present "141.513.009.004" ((>>) "141.513.009.004" | {PrintI [141.513.009.004] | s=%03d.%03d.%03d.%03d}) +-- Val "141.513.009.004" --
+ src/Predicate/Misc.hs view
@@ -0,0 +1,1269 @@+{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Utility methods for Predicate / methods for displaying the evaluation tree +module Predicate.Misc ( + -- ** useful type families + AndT + , OrT + , NotT + , RepeatT + , IntersperseT + , LenT + , FlipT + , IfT + , SumT + , MapT + , ConsT + , type (%%) + , type (%&) + , type (<%>) + , ExtractAFromList + , ExtractAFromTA + , ExtractTFromTA + , MaybeT + , LeftT + , RightT + , ThisT + , ThatT + , TheseT + , FnT + , ApplyConstT + , CheckT + , JoinT + , FailWhenT + , FailUnlessT + , ZwischenT + + -- ** extract values from the type level + , GetBool(..) + , GetLen(..) + , GetThese(..) + , GetOrdering(..) + , OrderingP(..) + , GetOrd(..) + , nat + , symb + + -- ** inductive tuples + , ToITupleC(..) + , ToITupleListC(..) + , ReverseITupleC(..) + , TupleC(..) + + -- ** extract from n-tuple + , T4_1 + , T4_2 + , T4_3 + , T4_4 + , T5_1 + , T5_2 + , T5_3 + , T5_4 + , T5_5 + + -- ** tuple classes + , ExtractL1C(..) + , ExtractL2C(..) + , ExtractL3C(..) + , ExtractL4C(..) + , ExtractL5C(..) + , ExtractL6C(..) + , ExtractL7C(..) + , ExtractL8C(..) + + -- ** primes + , isPrime + , primeStream + , primeFactors + + -- ** regular expressions + , compileRegex + , ROpt(..) + , GetROpts(..) + , RReplace(..) + , GetReplaceFnSub(..) + , ReplaceFnSub(..) + , displayROpts + + -- ** colors + , SColor(..) + , GetColor(..) + + -- ** miscellaneous + , SwapC(..) + , showTK + , showT + , showThese + , prettyOrd + , unlessNull + , unlessNullM + , nullSpace + , nullIf + , pureTryTest + , pureTryTestPred + , (~>) + , errorInProgram + , drawTreeU + , asProxyLeft + , asProxyRight + , removeAnsi + , _Id + + ) where +import qualified GHC.TypeNats as GN +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) +import qualified GHC.TypeLits as GL +import Data.Proxy (Proxy(Proxy)) +import Data.Typeable (Typeable, typeRep) +import System.Console.Pretty (Color(..)) +import GHC.Exts (Constraint) +import qualified Text.Regex.PCRE.Heavy as RH +import qualified Text.Regex.PCRE.Light as RL +import qualified Data.Text.Encoding as TE +import qualified Data.Text as T +import GHC.Word (Word8) +import Data.Sequence (Seq) +import Control.Applicative (ZipList) +import Data.Kind (Type) +import Data.These (These(..)) +import Data.These.Combinators (isThis, isThat, isThese) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.ByteString (ByteString) +import GHC.Stack (HasCallStack) +import Data.Containers.ListUtils (nubOrd) +import Control.Arrow (Arrow((***)),ArrowChoice(left)) +import Data.List (intercalate, unfoldr) +import qualified Safe (headNote) +import Data.Char (isSpace) +import qualified Control.Exception as E +import Data.Tree (Tree(Node)) +import Control.Lens (Identity(..), Lens) +import qualified Data.Semigroup as SG +import Data.Bifunctor (Bifunctor) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators + +-- | type level Between +type family ZwischenT (a :: Nat) (b :: Nat) (v :: Nat) :: Constraint where + ZwischenT m n v = + FailUnlessT (AndT (m GL.<=? v) (v GL.<=? n)) + ('GL.Text "ZwischenT failure" + ':$$: 'GL.ShowType v + ':$$: 'GL.Text " is outside of " + ':$$: 'GL.ShowType m + ':<>: 'GL.Text " and " + ':<>: 'GL.ShowType n) + +-- | helper method that fails with a msg when True +type family FailWhenT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where + FailWhenT 'False _ = () + FailWhenT 'True e = GL.TypeError e + +-- | helper method that fails with msg when False +type family FailUnlessT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where + FailUnlessT 'True _ = () + FailUnlessT 'False e = GL.TypeError e + +-- | typelevel boolean And +type family AndT (b :: Bool) (b1 :: Bool) :: Bool where + AndT 'False _ = 'False + AndT 'True b1 = b1 + +-- | typelevel boolean Or +type family OrT (b :: Bool) (b1 :: Bool) :: Bool where + OrT 'True _ = 'True + OrT 'False b1 = b1 + +-- | typelevel boolean Not +type family NotT (b :: Bool) :: Bool where + NotT 'True = 'False + NotT 'False = 'True + +-- | get the length of a typelevel container +-- +-- >>> getLen @'["abc","def","g"] +-- 3 +-- +-- >>> getLen @'[] +-- 0 +-- +-- >>> getLen @(9 ':| '[1,2,3]) +-- 4 +-- +-- >>> getLen @('These 9 "Asfs") +-- 1 +-- +-- >>> getLen @('This 1) +-- 0 +-- +class GetLen xs where -- (xs :: [k]) will break it! ghc 8.6.5 + getLen :: Int +instance GetLen '[] where + getLen = 0 +instance GetLen xs => GetLen (x ': xs) where + getLen = 1 + getLen @xs +instance GetLen ('Just a) where + getLen = 1 +instance GetLen 'Nothing where + getLen = 0 +instance GetLen ('Left a) where + getLen = 0 +instance GetLen ('Right a) where + getLen = 1 +instance GetLen ('This a) where + getLen = 0 +instance GetLen ('That a) where + getLen = 1 +instance GetLen ('These a b) where + getLen = 1 +instance GetLen xs => GetLen (x ':| xs) where + getLen = 1 + getLen @xs + +-- | display constructor name for 'These' +showThese :: These a b -> String +showThese = \case + This {} -> "This" + That {} -> "That" + These {} -> "These" + +-- | get 'These' from typelevel +class GetThese th where + getThese :: (String, These w v -> Bool) +instance GetThese ('This x) where + getThese = ("This", isThis) +instance GetThese ('That y) where + getThese = ("That", isThat) +instance GetThese ('These x y) where + getThese = ("These", isThese) + +-- | get ordering from the typelevel +class GetOrdering (cmp :: Ordering) where + getOrdering :: Ordering +instance GetOrdering 'LT where + getOrdering = LT +instance GetOrdering 'EQ where + getOrdering = EQ +instance GetOrdering 'GT where + getOrdering = GT + +-- | all the ways to compare two values +data OrderingP = CGt | CGe | CEq | CLe | CLt | CNe + deriving stock (Read, Show, Eq, Enum, Bounded) + +-- | extract 'OrderingP' from the typelevel +class GetOrd (k :: OrderingP) where + getOrd :: Ord a => (String, a -> a -> Bool) + +instance GetOrd 'CGt where getOrd = (">", (>)) +instance GetOrd 'CGe where getOrd = (">=",(>=)) +instance GetOrd 'CEq where getOrd = ("==",(==)) +instance GetOrd 'CLe where getOrd = ("<=",(<=)) +instance GetOrd 'CLt where getOrd = ("<", (<)) +instance GetOrd 'CNe where getOrd = ("/=",(/=)) + +-- | show the type as a string +showT :: forall (t :: Type) . Typeable t => String +showT = show (typeRep (Proxy @t)) + +-- | Repeat an expression n times +type family RepeatT (n :: Nat) (p :: k) :: [k] where + RepeatT 0 _p = GL.TypeError ('GL.Text "RepeatT is not defined for zero") + RepeatT 1 p = p ': '[] + RepeatT n p = p ': RepeatT (n GN.- 1) p + +type s <%> t = GL.AppendSymbol s t +infixr 7 <%> + +-- | Intersperse a symbol inside a list of symbols +type family IntersperseT (s :: Symbol) (xs :: [Symbol]) :: Symbol where + IntersperseT _s '[] = "" + IntersperseT _s '[x] = x + IntersperseT s (x ': y ': xs) = x <%> s <%> IntersperseT s (y ': xs) + +-- | length of a type level list +type family LenT (xs :: [k]) :: Nat where + LenT '[] = 0 + LenT (_x ': xs) = 1 GN.+ LenT xs + +-- | takes a flat n-tuple and creates an inductive tuple. see 'Predicate.Data.ReadShow.PrintT' +-- +-- >>> toITupleC (123,'x',False,"abc") +-- (123,('x',(False,("abc",())))) +-- +-- >>> toITupleC (123,'x') +-- (123,('x',())) +-- + +class ToITupleC x where + type ToITupleP x + toITupleC :: x -> ToITupleP x +instance (GL.TypeError ('GL.Text "ToITupleC: inductive tuple cannot be empty")) => ToITupleC () where + type ToITupleP () = () + toITupleC () = () +instance ToITupleC (a,b) where + type ToITupleP (a,b) = (a,(b,())) + toITupleC (a,b) = (a,(b,())) +instance ToITupleC (a,b,c) where + type ToITupleP (a,b,c) = (a,(b,(c,()))) + toITupleC (a,b,c) = (a,(b,(c,()))) +instance ToITupleC (a,b,c,d) where + type ToITupleP (a,b,c,d) = (a,(b,(c,(d,())))) + toITupleC (a,b,c,d) = (a,(b,(c,(d,())))) +instance ToITupleC (a,b,c,d,e) where + type ToITupleP (a,b,c,d,e) = (a,(b,(c,(d,(e,()))))) + toITupleC (a,b,c,d,e) = (a,(b,(c,(d,(e,()))))) +instance ToITupleC (a,b,c,d,e,f) where + type ToITupleP (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,())))))) + toITupleC (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,())))))) +instance ToITupleC (a,b,c,d,e,f,g) where + type ToITupleP (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,()))))))) + toITupleC (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,()))))))) +instance ToITupleC (a,b,c,d,e,f,g,h) where + type ToITupleP (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,())))))))) + toITupleC (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,())))))))) +instance ToITupleC (a,b,c,d,e,f,g,h,i) where + type ToITupleP (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) + toITupleC (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) +instance ToITupleC (a,b,c,d,e,f,g,h,i,j) where + type ToITupleP (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) + toITupleC (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) +instance ToITupleC (a,b,c,d,e,f,g,h,i,j,k) where + type ToITupleP (a,b,c,d,e,f,g,h,i,j,k) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) + toITupleC (a,b,c,d,e,f,g,h,i,j,k) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) +instance ToITupleC (a,b,c,d,e,f,g,h,i,j,k,l) where + type ToITupleP (a,b,c,d,e,f,g,h,i,j,k,l) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) + toITupleC (a,b,c,d,e,f,g,h,i,j,k,l) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) + + +-- | takes a list of size @n@ and converts it to an inductive tuple. see 'Predicate.Data.ReadShow.PrintL' +-- +-- >>> toITupleListC @4 [10,12,13,1] +-- Right (10,(12,(13,(1,())))) +-- +-- >>> toITupleListC @2 ["ab","cc"] +-- Right ("ab",("cc",())) +-- +-- >>> toITupleListC @10 [10,12,13,1] +-- Left "toITupleListC: expected exactly 10 values" +-- +-- >>> toITupleListC @2 [10,12,13,1] +-- Left "toITupleListC: expected exactly 2 values" +-- +class ToITupleListC (n :: Nat) a where + type ToITupleListP n a + toITupleListC :: [a] -> Either String (ToITupleListP n a) +instance (GL.TypeError ('GL.Text "ToITupleListC: inductive tuple cannot be empty")) => ToITupleListC 0 a where + type ToITupleListP 0 a = () + toITupleListC _ = Left "ToITupleListC 0: shouldnt be called" +instance ToITupleListC 1 a where + type ToITupleListP 1 a = (a,()) + toITupleListC [a] = Right (a,()) + toITupleListC _ = Left "toITupleListC: expected exactly 1 value" +instance ToITupleListC 2 a where + type ToITupleListP 2 a = (a,(a,())) + toITupleListC [a,b] = Right (a,(b,())) + toITupleListC _ = Left "toITupleListC: expected exactly 2 values" +instance ToITupleListC 3 a where + type ToITupleListP 3 a = (a,(a,(a,()))) + toITupleListC [a,b,c] = Right (a,(b,(c,()))) + toITupleListC _ = Left "toITupleListC: expected exactly 3 values" +instance ToITupleListC 4 a where + type ToITupleListP 4 a = (a,(a,(a,(a,())))) + toITupleListC [a,b,c,d] = Right (a,(b,(c,(d,())))) + toITupleListC _ = Left "toITupleListC: expected exactly 4 values" +instance ToITupleListC 5 a where + type ToITupleListP 5 a = (a,(a,(a,(a,(a,()))))) + toITupleListC [a,b,c,d,e] = Right (a,(b,(c,(d,(e,()))))) + toITupleListC _ = Left "toITupleListC: expected exactly 5 values" +instance ToITupleListC 6 a where + type ToITupleListP 6 a = (a,(a,(a,(a,(a,(a,())))))) + toITupleListC [a,b,c,d,e,f] = Right (a,(b,(c,(d,(e,(f,())))))) + toITupleListC _ = Left "toITupleListC: expected exactly 6 values" +instance ToITupleListC 7 a where + type ToITupleListP 7 a = (a,(a,(a,(a,(a,(a,(a,()))))))) + toITupleListC [a,b,c,d,e,f,g] = Right (a,(b,(c,(d,(e,(f,(g,()))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 7 values" +instance ToITupleListC 8 a where + type ToITupleListP 8 a = (a,(a,(a,(a,(a,(a,(a,(a,())))))))) + toITupleListC [a,b,c,d,e,f,g,h] = Right (a,(b,(c,(d,(e,(f,(g,(h,())))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 8 values" +instance ToITupleListC 9 a where + type ToITupleListP 9 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))) + toITupleListC [a,b,c,d,e,f,g,h,i] = Right (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 9 values" +instance ToITupleListC 10 a where + type ToITupleListP 10 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))) + toITupleListC [a,b,c,d,e,f,g,h,i,j] = Right (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 10 values" +instance ToITupleListC 11 a where + type ToITupleListP 11 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))))) + toITupleListC [a,b,c,d,e,f,g,h,i,j,k] = Right (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 11 values" +instance ToITupleListC 12 a where + type ToITupleListP 12 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))))) + toITupleListC [a,b,c,d,e,f,g,h,i,j,k,l] = Right (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) + toITupleListC _ = Left "toITupleListC: expected exactly 12 values" + +class ReverseITupleC x xs ys where + type ReverseITupleT x xs ys + reverseITupleC :: x -> xs -> ys -> ReverseITupleT x xs ys +instance ReverseITupleC x () ys where + type ReverseITupleT x () ys = (x,ys) + reverseITupleC x () ys = (x,ys) +instance ReverseITupleC w ws (x, ys) => ReverseITupleC x (w,ws) ys where + type ReverseITupleT x (w,ws) ys = (ReverseITupleT w ws (x,ys)) + reverseITupleC x (w,ws) ys = reverseITupleC w ws (x,ys) + +-- partially apply the 2nd arg to an ADT -- $ and & work with functions only +-- doesnt apply more than once because we need to eval it +type family (p :: k -> k1) %% (q :: k) :: k1 where + p %% q = p q + +infixl 9 %% + +type family (p :: k) %& (q :: k -> k1) :: k1 where + p %& q = q p + +infixr 9 %& + +-- | 'flip' at the type level +type family FlipT (d :: k1 -> k -> k2) (p :: k) (q :: k1) :: k2 where + FlipT d p q = d q p + +-- | 'if' at the type level +type family IfT (b :: Bool) (t :: k) (f :: k) :: k where + IfT 'True t _f = t + IfT 'False _t f = f + +-- | 'sum' at the type level for a list of 'Nat' +type family SumT (ns :: [Nat]) :: Nat where + SumT '[] = 0 + SumT (n ': ns) = n GL.+ SumT ns + +-- only works if you use ADTs not type synonyms +-- | 'map' at the type level +type family MapT (f :: k -> k1) (xs :: [k]) :: [k1] where + MapT _f '[] = '[] + MapT f (x ': xs) = f x ': MapT f xs + +-- | Extract @a@ from a list-like container +type family ConsT s where + ConsT [a] = a + ConsT (ZipList a) = a + ConsT T.Text = Char + ConsT ByteString = Word8 + ConsT (Seq a) = a + ConsT s = GL.TypeError ( + 'GL.Text "invalid ConsT instance" + ':$$: 'GL.Text "s = " + ':<>: 'GL.ShowType s) + +-- | extract @opts@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' +type family T4_1 x where + T4_1 '(opts,_,_,_) = opts +-- | extract @ip@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' +type family T4_2 x where + T4_2 '(_,ip,_,_) = ip +-- | extract @op@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' +type family T4_3 x where + T4_3 '(_,_,op,_) = op +-- | extract @i@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' +type family T4_4 x where + T4_4 '(_,_,_,i) = i + +-- | extract @opts@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' +type family T5_1 x where + T5_1 '(opts,_,_,_,_) = opts +-- | extract @ip@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' +type family T5_2 x where + T5_2 '(_,ip,_,_,_) = ip +-- | extract @op@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' +type family T5_3 x where + T5_3 '(_,_,op,_,_) = op +-- | extract @fmt@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' +type family T5_4 x where + T5_4 '(_,_,_,fmt,_) = fmt +-- | extract @i@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' +type family T5_5 x where + T5_5 '(_,_,_,_,i) = i + +-- | type family to extract @a@ from @t a@ +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) + +-- | type family to extract @t@ from @t a@ +type family ExtractTFromTA (ta :: Type) :: (Type -> Type) where + ExtractTFromTA (t _a) = t + ExtractTFromTA z = GL.TypeError ( + 'GL.Text "ExtractTFromTA: expected (t a) but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType z) + + +-- todo: get ExtractAFromList failure to fire if wrong Type +-- | type family to extract @a@ from a list of @a@ +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) + +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) + + +type family LeftT lr where + LeftT (Either a _) = 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) + +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) + +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) + +type family JoinT x y where + JoinT (t a) (t b) = t (a, b) + JoinT ta tb = GL.TypeError ( + 'GL.Text "JoinT: expected (t a) (t b) but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType ta + ':$$: 'GL.Text "t b = " + ':<>: 'GL.ShowType tb) + +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) + +type family CheckT (tp :: Type) :: Bool where + CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") + CheckT _o = 'True + +errorInProgram :: HasCallStack => String -> x +errorInProgram s = error $ "programmer error:" <> s + +-- | boolean implication +-- +-- >>> True ~> False +-- False +-- +-- >>> True ~> True +-- True +-- +-- >>> False ~> False +-- True +-- +-- >>> False ~> True +-- True +-- +(~>) :: Bool -> Bool -> Bool +p ~> q = not p || q +infixr 1 ~> + +-- | extract the first element from a n-tuple +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 +instance ExtractL1C (a,b,c,d,e,f,g) where + type ExtractL1T (a,b,c,d,e,f,g) = a + extractL1C (a,_,_,_,_,_,_) = a +instance ExtractL1C (a,b,c,d,e,f,g,h) where + type ExtractL1T (a,b,c,d,e,f,g,h) = a + extractL1C (a,_,_,_,_,_,_,_) = a + +-- | extract the second element from a n-tuple +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 +instance ExtractL2C (a,b,c,d,e,f,g) where + type ExtractL2T (a,b,c,d,e,f,g) = b + extractL2C (_,b,_,_,_,_,_) = b +instance ExtractL2C (a,b,c,d,e,f,g,h) where + type ExtractL2T (a,b,c,d,e,f,g,h) = b + extractL2C (_,b,_,_,_,_,_,_) = b + +-- | extract the third element from a n-tuple +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 +instance ExtractL3C (a,b,c,d,e,f,g) where + type ExtractL3T (a,b,c,d,e,f,g) = c + extractL3C (_,_,c,_,_,_,_) = c +instance ExtractL3C (a,b,c,d,e,f,g,h) where + type ExtractL3T (a,b,c,d,e,f,g,h) = c + extractL3C (_,_,c,_,_,_,_,_) = c + +-- | extract the fourth element from a n-tuple +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 +instance ExtractL4C (a,b,c,d,e,f,g) where + type ExtractL4T (a,b,c,d,e,f,g) = d + extractL4C (_,_,_,d,_,_,_) = d +instance ExtractL4C (a,b,c,d,e,f,g,h) where + type ExtractL4T (a,b,c,d,e,f,g,h) = d + extractL4C (_,_,_,d,_,_,_,_) = d + +-- | extract the fifth element from a n-tuple +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 +instance ExtractL5C (a,b,c,d,e,f,g) where + type ExtractL5T (a,b,c,d,e,f,g) = e + extractL5C (_,_,_,_,e,_,_) = e +instance ExtractL5C (a,b,c,d,e,f,g,h) where + type ExtractL5T (a,b,c,d,e,f,g,h) = e + extractL5C (_,_,_,_,e,_,_,_) = e + +-- | extract the sixth element from a n-tuple +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 +instance ExtractL6C (a,b,c,d,e,f,g) where + type ExtractL6T (a,b,c,d,e,f,g) = f + extractL6C (_,_,_,_,_,f,_) = f +instance ExtractL6C (a,b,c,d,e,f,g,h) where + type ExtractL6T (a,b,c,d,e,f,g,h) = f + extractL6C (_,_,_,_,_,f,_,_) = f + +-- | extract the seventh element from a n-tuple +class ExtractL7C tp where + type ExtractL7T tp + extractL7C :: tp -> ExtractL7T tp +instance ExtractL7C (a,b) where + type ExtractL7T (a,b) = GL.TypeError ('GL.Text "L7 doesn't work for 2-tuples") + extractL7C _ = errorInProgram "L7 doesn't work for 2-tuples" +instance ExtractL7C (a,b,c) where + type ExtractL7T (a,b,c) = GL.TypeError ('GL.Text "L7 doesn't work for 3-tuples") + extractL7C _ = errorInProgram "L7 doesn't work for 3-tuples" +instance ExtractL7C (a,b,c,d) where + type ExtractL7T (a,b,c,d) = GL.TypeError ('GL.Text "L7 doesn't work for 4-tuples") + extractL7C _ = errorInProgram "L7 doesn't work for 4-tuples" +instance ExtractL7C (a,b,c,d,e) where + type ExtractL7T (a,b,c,d,e) = GL.TypeError ('GL.Text "L7 doesn't work for 5-tuples") + extractL7C _ = errorInProgram "L7 doesn't work for 5-tuples" +instance ExtractL7C (a,b,c,d,e,f) where + type ExtractL7T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L7 doesn't work for 6-tuples") + extractL7C _ = errorInProgram "L7 doesn't work for 6-tuples" +instance ExtractL7C (a,b,c,d,e,f,g) where + type ExtractL7T (a,b,c,d,e,f,g) = g + extractL7C (_,_,_,_,_,_,g) = g +instance ExtractL7C (a,b,c,d,e,f,g,h) where + type ExtractL7T (a,b,c,d,e,f,g,h) = g + extractL7C (_,_,_,_,_,_,g,_) = g + +-- | extract the eighth element from a n-tuple +class ExtractL8C tp where + type ExtractL8T tp + extractL8C :: tp -> ExtractL8T tp +instance ExtractL8C (a,b) where + type ExtractL8T (a,b) = GL.TypeError ('GL.Text "L8 doesn't work for 2-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 2-tuples" +instance ExtractL8C (a,b,c) where + type ExtractL8T (a,b,c) = GL.TypeError ('GL.Text "L8 doesn't work for 3-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 3-tuples" +instance ExtractL8C (a,b,c,d) where + type ExtractL8T (a,b,c,d) = GL.TypeError ('GL.Text "L8 doesn't work for 4-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 4-tuples" +instance ExtractL8C (a,b,c,d,e) where + type ExtractL8T (a,b,c,d,e) = GL.TypeError ('GL.Text "L8 doesn't work for 5-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 5-tuples" +instance ExtractL8C (a,b,c,d,e,f) where + type ExtractL8T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L8 doesn't work for 6-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 6-tuples" +instance ExtractL8C (a,b,c,d,e,f,g) where + type ExtractL8T (a,b,c,d,e,f,g) = GL.TypeError ('GL.Text "L8 doesn't work for 7-tuples") + extractL8C _ = errorInProgram "L8 doesn't work for 7-tuples" +instance ExtractL8C (a,b,c,d,e,f,g,h) where + type ExtractL8T (a,b,c,d,e,f,g,h) = h + extractL8C (_,_,_,_,_,_,_,h) = h + +-- | try to convert a list to a n-tuple +class TupleC (n :: Nat) a where + type TupleT n a + getTupleC :: [a] -> Either [a] (TupleT n a) + +-- | convert a list of at least 2 elements to a 2-tuple +instance TupleC 2 a where + type TupleT 2 a = (a,a) + getTupleC = \case + a:b:_ -> Right (a,b) + o -> Left o + +-- | convert a list of at least 3 elements to a 3-tuple +instance TupleC 3 a where + type TupleT 3 a = (a,a,a) + getTupleC = \case + a:b:c:_ -> Right (a,b,c) + o -> Left o + +-- | convert a list of at least 4 elements to a 4-tuple +instance TupleC 4 a where + type TupleT 4 a = (a,a,a,a) + getTupleC = \case + a:b:c:d:_ -> Right (a,b,c,d) + o -> Left o + +-- | convert a list of at least 5 elements to a 5-tuple +instance TupleC 5 a where + type TupleT 5 a = (a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:_ -> Right (a,b,c,d,e) + o -> Left o + +-- | convert a list of at least 6 elements to a 6-tuple +instance TupleC 6 a where + type TupleT 6 a = (a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:_ -> Right (a,b,c,d,e,f) + o -> Left o + +-- | convert a list of at least 7 elements to a 7-tuple +instance TupleC 7 a where + type TupleT 7 a = (a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:_ -> Right (a,b,c,d,e,f,g) + o -> Left o + +-- | convert a list of at least 8 elements to a 8-tuple +instance TupleC 8 a where + type TupleT 8 a = (a,a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:h:_ -> Right (a,b,c,d,e,f,g,h) + o -> Left o + +-- | convert a list of at least 9 elements to a 9-tuple +instance TupleC 9 a where + type TupleT 9 a = (a,a,a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:h:i:_ -> Right (a,b,c,d,e,f,g,h,i) + o -> Left o + +-- | convert a list of at least 10 elements to a 10-tuple +instance TupleC 10 a where + type TupleT 10 a = (a,a,a,a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:h:i:j:_ -> Right (a,b,c,d,e,f,g,h,i,j) + o -> Left o + +-- | convert a list of at least 11 elements to a 11-tuple +instance TupleC 11 a where + type TupleT 11 a = (a,a,a,a,a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:h:i:j:k:_ -> Right (a,b,c,d,e,f,g,h,i,j,k) + o -> Left o + +-- | convert a list of at least 12 elements to a 12-tuple +instance TupleC 12 a where + type TupleT 12 a = (a,a,a,a,a,a,a,a,a,a,a,a) + getTupleC = \case + a:b:c:d:e:f:g:h:i:j:k:l:_ -> Right (a,b,c,d,e,f,g,h,i,j,k,l) + o -> Left o + +-- | prime predicate +-- +-- >>> isPrime 7 +-- True +-- +-- >>> isPrime 6 +-- False +-- +isPrime :: Int -> Bool +isPrime n = n == 2 || n > 2 && all ((> 0) . mod n) (2:[3,5 .. floor . sqrt @Double . fromIntegral $ n+1]) + +-- | prime factors +-- +-- >>> primeFactors 100 +-- [2,2,5,5] +-- +-- >>> primeFactors 123 +-- [3,41] +-- +primeFactors :: Integer -> [Integer] +primeFactors n = + case factors of + [] -> [n] + _ -> factors ++ primeFactors (n `div` Safe.headNote "primeFactors" factors) + where factors = take 1 $ filter (\x -> (n `mod` x) == 0) [2 .. n-1] + +-- | primes stream +-- +-- >>> take 10 primeStream +-- [2,3,5,7,11,13,17,19,23,29] +-- +primeStream :: [Integer] +primeStream = 2 : 3 : 5 : primes' + where + isPrime' [] _ = errorInProgram "primes is empty" + isPrime' (p:ps) n = p*p > n || n `rem` p /= 0 && isPrime' ps n + primes' = 7 : filter (isPrime' primes') (scanl (+) 11 $ cycle [2,4,2,4,6,2,6,4]) + +-- | pretty print 'Ordering' +prettyOrd :: Ordering -> String +prettyOrd = \case + LT -> "<" + EQ -> "=" + GT -> ">" + +-- | show the kind as a string +showTK :: forall r . Typeable r => String +showTK = show (typeRep (Proxy @r)) + +-- | get a Nat from the typelevel +-- +-- >>> nat @14 +-- 14 +-- +nat :: forall n a + . ( KnownNat n + , Num a + ) => a +nat = fromIntegral (GL.natVal (Proxy @n)) + +-- | gets the Symbol from the typelevel +-- +-- >>> symb @"abc" +-- "abc" +-- +symb :: forall s . KnownSymbol s => String +symb = GL.symbolVal (Proxy @s) + +-- | get a list of Nats from the typelevel +-- +-- >>> getNats @'[10,12,1] +-- [10,12,1] +class GetNats as where + getNats :: [Int] +instance GetNats '[] where + getNats = [] +instance ( KnownNat n + , GetNats ns + ) => GetNats (n ': ns) where + getNats = nat @n : getNats @ns + +-- | get a list of Symbols from the typelevel +-- +-- >>> getSymbs @'["abc","def","g"] +-- ["abc","def","g"] +-- +class GetSymbs ns where + getSymbs :: [String] +instance GetSymbs '[] where + getSymbs = [] +instance ( KnownSymbol s + , GetSymbs ss + ) => GetSymbs (s ': ss) where + getSymbs = symb @s : getSymbs @ss + +-- | get 'Bool' from the typelevel +class GetBool (a :: Bool) where + getBool :: Bool +instance GetBool 'True where + getBool = True +instance GetBool 'False where + getBool = False + +-- | compile a regex using type level options +compileRegex :: forall rs . GetROpts rs + => String + -> String + -> Either (String, String) RH.Regex +compileRegex nm s + | null s = Left ("Regex cannot be empty",nm) + | otherwise = + let rs = getROpts @rs + mm = nm <> " " <> show rs + f e = ("Regex failed to compile", mm <> ":" <> e) + in left f (RH.compileM (TE.encodeUtf8 (T.pack s)) (snd rs)) + +-- | Regex options for Rescan Resplit Re etc +data ROpt = + Anchored -- ^ Force pattern anchoring + | AutoCallout -- ^ Compile automatic callouts +-- | BsrAnycrlf -- \R matches only CR, LF, or CrlF +-- | BsrUnicode -- ^ \R matches all Unicode line endings + | Caseless -- ^ Do caseless matching + | DollarEndonly -- ^ dollar not to match newline at end + | Dotall -- ^ matches anything including NL + | Dupnames -- ^ Allow duplicate names for subpatterns + | Extended -- ^ Ignore whitespace and # comments + | Extra -- ^ PCRE extra features (not much use currently) + | Firstline -- ^ Force matching to be before newline + | Multiline -- ^ caret and dollar match newlines within data +-- | NewlineAny -- ^ Recognize any Unicode newline sequence +-- | NewlineAnycrlf -- ^ Recognize CR, LF, and CrlF as newline sequences + | NewlineCr -- ^ Set CR as the newline sequence + | NewlineCrlf -- ^ Set CrlF as the newline sequence + | NewlineLf -- ^ Set LF as the newline sequence + | NoAutoCapture -- ^ Disable numbered capturing parentheses (named ones available) + | Ungreedy -- ^ Invert greediness of quantifiers + | Utf8 -- ^ Run in UTF--8 mode + | NoUtf8Check -- ^ Do not check the pattern for UTF-8 validity + deriving stock (Read, Show, Eq, Ord, Enum, Bounded) + +-- | extract the regex options from the type level list +class GetROpts (os :: [ROpt]) where + getROpts :: ([String], [RL.PCREOption]) +instance GetROpts '[] where + getROpts = ([], []) +instance ( Typeable r + , GetROpt r + , GetROpts rs + ) => GetROpts (r ': rs) where + getROpts = ((showTK @r :) *** (getROpt @r :)) (getROpts @rs) + +-- | display regex options +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 +instance GetROpt 'Anchored where getROpt = RL.anchored +instance GetROpt 'AutoCallout where getROpt = RL.auto_callout +--instance GetROpt 'BsrAnycrlf where getROpt = RL.bsr_anycrlf +--instance GetROpt 'BsrUnicode where getROpt = RL.bsr_unicode +instance GetROpt 'Caseless where getROpt = RL.caseless +instance GetROpt 'DollarEndonly where getROpt = RL.dollar_endonly +instance GetROpt 'Dotall where getROpt = RL.dotall +instance GetROpt 'Dupnames where getROpt = RL.dupnames +instance GetROpt 'Extended where getROpt = RL.extended +instance GetROpt 'Extra where getROpt = RL.extra +instance GetROpt 'Firstline where getROpt = RL.firstline +instance GetROpt 'Multiline where getROpt = RL.multiline +--instance GetROpt 'NewlineAny where getROpt = RL.newline_any +--instance GetROpt 'NewlineAnycrlf where getROpt = RL.newline_anycrlf +instance GetROpt 'NewlineCr where getROpt = RL.newline_cr +instance GetROpt 'NewlineCrlf where getROpt = RL.newline_crlf +instance GetROpt 'NewlineLf where getROpt = RL.newline_lf +instance GetROpt 'NoAutoCapture where getROpt = RL.no_auto_capture +instance GetROpt 'Ungreedy where getROpt = RL.ungreedy +instance GetROpt 'Utf8 where getROpt = RL.utf8 +instance GetROpt 'NoUtf8Check where getROpt = RL.no_utf8_check + +-- | simple regex string replacement options +data ReplaceFnSub = + RPrepend + | ROverWrite + | RAppend + deriving stock (Read, Show, Eq, Bounded, Enum) + +-- | extract replacement options from typelevel +class GetReplaceFnSub (k :: ReplaceFnSub) where + getReplaceFnSub :: ReplaceFnSub +instance GetReplaceFnSub 'RPrepend where getReplaceFnSub = RPrepend +instance GetReplaceFnSub 'ROverWrite where getReplaceFnSub = ROverWrite +instance GetReplaceFnSub 'RAppend where getReplaceFnSub = RAppend + +-- | used by 'Predicate.ReplaceImpl' and 'RH.sub' and 'RH.gsub' to allow more flexible replacement +-- These parallel the RegexReplacement (not exported) class in "Text.Regex.PCRE.Heavy" but have overlappable instances which is problematic for this code so I use 'RReplace' +data RReplace = + RReplace !ReplaceFnSub !String + | RReplace1 !(String -> [String] -> String) + | RReplace2 !(String -> String) + | RReplace3 !([String] -> String) + +instance Show RReplace where + show = \case + RReplace o s -> "RReplace " ++ show o ++ " " ++ s + RReplace1 {} -> "RReplace1 <fn>" + RReplace2 {} -> "RReplace2 <fn>" + RReplace3 {} -> "RReplace3 <fn>" + +-- | wrapper for a Show instance around 'Color' +newtype SColor = SColor Color + deriving newtype Enum +instance Bounded SColor where + minBound = SColor Black + maxBound = SColor Default + +instance Show SColor where + show (SColor c) = + case c of + Black -> "Black" + Red -> "Red" + Green -> "Green" + Yellow -> "Yellow" + Blue -> "Blue" + Magenta -> "Magenta" + Cyan -> "Cyan" + White -> "White" + Default -> "Default" + +-- | get 'Color' from the typelevel +class GetColor (a :: Color) where + getColor :: Color +instance GetColor 'Black where + getColor = Black +instance GetColor 'Red where + getColor = Red +instance GetColor 'Green where + getColor = Green +instance GetColor 'Yellow where + getColor = Yellow +instance GetColor 'Blue where + getColor = Blue +instance GetColor 'Magenta where + getColor = Magenta +instance GetColor 'Cyan where + getColor = Cyan +instance GetColor 'White where + getColor = White +instance GetColor 'Default where + getColor = Default + +-- | convenience method for optional display +unlessNull :: (Foldable t, Monoid m) => t a -> m -> m +unlessNull t m | null t = mempty + | otherwise = m + +unlessNullM :: (Foldable t, Applicative m) => t a -> (t a -> m ()) -> m () +unlessNullM t f + | null t = pure () + | otherwise = f t + +nullSpace :: String -> String +nullSpace = nullIf " " + +nullIf :: String -> String -> String +nullIf s t + | all isSpace t = "" + | otherwise = s <> t + +pureTryTest :: a -> IO (Either () a) +pureTryTest = fmap (left (const ())) . E.try @E.SomeException . E.evaluate +--pureTryTest = over (mapped . _Left) (const ()) . E.try @E.SomeException . E.evaluate + +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 + Left e | p e -> Right (Left ()) + | otherwise -> Left ("no match found: e=" ++ e) + Right r -> Right (Right r) + +-- https://github.com/haskell/containers/pull/344 +-- | draw a tree using unicode +drawTreeU :: Tree String -> String +drawTreeU = intercalate "\n" . drawU + +drawU :: Tree String -> [String] +drawU (Node x ts0) = x : drawSubTrees ts0 + where + drawSubTrees [] = [] + drawSubTrees [t] = + shift "\x2514\x2500" " " (drawU t) + drawSubTrees (t:ts) = + shift "\x251c\x2500" "\x2502 " (drawU t) ++ drawSubTrees ts + + shift one other = zipWith (++) (one : repeat other) + +asProxyRight :: proxy a -> proxy1 a -> proxy1 a +asProxyRight = flip const + +asProxyLeft :: proxy a -> proxy1 a -> proxy a +asProxyLeft = const + +-- | strip ansi characters from a string and print it (for doctests) +removeAnsi :: Show a => Either String a -> IO () +removeAnsi = putStrLn . removeAnsiImpl + +removeAnsiImpl :: Show a => Either String a -> String +removeAnsiImpl = + \case + Left e -> let esc = '\x1b' + f :: String -> Maybe (String, String) + f = \case + [] -> Nothing + c:cs | c == esc -> case break (=='m') cs of + (_,'m':s) -> Just ("",s) + _ -> Nothing + | otherwise -> Just $ break (==esc) (c:cs) + in concat $ unfoldr f e + Right a -> show a + +_Id :: Lens (Identity a) (Identity b) a b +_Id afb (Identity a) = Identity <$> afb a + +class Bifunctor p => SwapC p 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 SG.Arg where + swapC (SG.Arg a b) = SG.Arg b a +instance SwapC (,) where + swapC (a,b) = (b,a) +instance SwapC ((,,) a) where + swapC (a,b,c) = (a,c,b) +instance SwapC ((,,,) a b) where + swapC (a,b,c,d) = (a,b,d,c) +instance SwapC ((,,,,) a b c) where + swapC (a,b,c,d,e) = (a,b,c,e,d) +instance SwapC ((,,,,,) a b c d) where + swapC (a,b,c,d,e,f) = (a,b,c,d,f,e) +instance SwapC ((,,,,,,) a b c d e) where + swapC (a,b,c,d,e,f,g) = (a,b,c,d,e,g,f) +
src/Predicate/Prelude.hs view
@@ -1,10 +1,9 @@-{-# OPTIONS -Wall #-} -{- | - Dsl for evaluating and displaying type level expressions --} +-- | Dsl for evaluating and displaying type level expressions module Predicate.Prelude ( module Predicate.Core , module Predicate.Util + , module Predicate.Misc + , module Predicate.Data.Bits , module Predicate.Data.Char , module Predicate.Data.Condition , module Predicate.Data.DateTime @@ -16,11 +15,13 @@ , module Predicate.Data.Iterator , module Predicate.Data.IO , module Predicate.Data.Json + , module Predicate.Data.Lifted , module Predicate.Data.List , module Predicate.Data.Maybe , module Predicate.Data.Monoid , module Predicate.Data.Numeric , module Predicate.Data.Ordering + , module Predicate.Data.Proxy , module Predicate.Data.ReadShow , module Predicate.Data.Regex , module Predicate.Data.String @@ -28,7 +29,9 @@ , module Predicate.Data.Tuple ) where import Predicate.Core +import Predicate.Misc import Predicate.Util +import Predicate.Data.Bits import Predicate.Data.Char import Predicate.Data.Condition import Predicate.Data.DateTime @@ -40,11 +43,13 @@ import Predicate.Data.Iterator import Predicate.Data.IO import Predicate.Data.Json +import Predicate.Data.Lifted import Predicate.Data.List import Predicate.Data.Maybe import Predicate.Data.Monoid import Predicate.Data.Numeric import Predicate.Data.Ordering +import Predicate.Data.Proxy import Predicate.Data.ReadShow import Predicate.Data.Regex import Predicate.Data.String
src/Predicate/Refined.hs view
@@ -1,9 +1,4 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -17,61 +12,37 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE NoStarIsType #-} {-# LANGUAGE TypeOperators #-} -{- | - Simple refinement type with only one type and a predicate --} +-- | simple refinement type with only one type and a predicate module Predicate.Refined ( -- ** Refined Refined , unRefined + , Msg0(..) + , showMsg0 , RefinedC - , RefinedT(..) - -- ** print methods - , prtRefinedIO - , prtRefinedTIO - -- ** create methods , newRefined - , newRefinedM - , withRefinedT - , withRefinedTIO - , newRefinedT - , newRefinedTIO + , newRefined' -- ** QuickCheck method , genRefined - -- ** manipulate RefinedT values - , convertRefinedT - , unRavelT - , rapply - , rapplyLift - -- ** unsafe create methods , unsafeRefined , unsafeRefined' - , type ReplaceOptT - , type AppendOptT - ) where import Predicate.Core +import Predicate.Misc (nullIf) import Predicate.Util import Control.Lens -import Data.Functor.Identity (Identity(..)) -import Data.Proxy -import Control.Monad.Except -- (MonadError, ExceptT(..), runExceptT, throwError, catchError) -import Control.Monad.Writer (WriterT(..), runWriterT, MonadWriter, tell) -import Control.Monad.Cont +import Data.Proxy (Proxy(Proxy)) import Data.Aeson (ToJSON(..), FromJSON(..)) -import GHC.Generics (Generic) import qualified Language.Haskell.TH.Syntax as TH import Test.QuickCheck import qualified GHC.Read as GR @@ -79,72 +50,34 @@ import qualified Text.Read.Lex as RL import qualified Data.Binary as B import Data.Binary (Binary) -import Data.String +import Data.String (IsString(..)) import Data.Hashable (Hashable(..)) -import GHC.Stack -import Data.Maybe (fromMaybe) - +import GHC.Stack (HasCallStack) +import Data.Coerce (coerce) +import Control.DeepSeq (NFData) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XTypeOperators -- >>> :set -XOverloadedStrings +-- >>> :set -XNoOverloadedLists -- >>> :m + Predicate.Prelude +-- >>> :m + Control.Arrow +-- >>> :m + Text.Show.Functions --- | a simple refinement type that ensures the predicate \'p\' holds for the type \'a\' --- --- >>> prtRefinedIO @OZ @(Between 10 14 Id) 13 --- Right (Refined 13) --- --- >>> prtRefinedIO @OZ @(Between 10 14 Id) 99 --- Left FalseT --- --- >>> 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" --- 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" --- Left FalseT --- --- >>> 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" --- 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" --- Left (FailT "ReadP Int (1x34)") --- --- >>> 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" --- Left FalseT --- --- >>> 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] --- Left FalseT --- --- >>> 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"]) --- Left (FailT "(!!) index not found") --- --- >>> prtRefinedIO @OZ @(Snd Id !! Fst Id >> Len <= 5) (2,["abc","defghij","xyzxyazsfd"]) --- Left FalseT +-- | a simple refinement type that ensures the predicate @p@ holds for the type @a@ -- -newtype Refined (opts :: OptT) p a = Refined a deriving (Show, Eq, Generic, TH.Lift) +newtype Refined (opts :: Opt) p a = Refined a + deriving stock (Show, TH.Lift) + deriving newtype (Eq, Ord, NFData) -- | extract the value from Refined -unRefined :: forall k (opts :: OptT) (p :: k) a. Refined opts p a -> a -unRefined (Refined a) = a +unRefined :: forall k (opts :: Opt) (p :: k) a + . Refined opts p a + -> a +unRefined = coerce -type role Refined nominal nominal nominal +type role Refined phantom nominal nominal -- | 'IsString' instance for Refined -- @@ -156,27 +89,32 @@ -- instance RefinedC opts p String => IsString (Refined opts p String) where fromString s = - let (w,mr) = runIdentity $ newRefinedM @opts @p s - in fromMaybe (error $ "Refined(fromString):" ++ errorDisplay (getOptT @opts) w) mr + case newRefined @opts @p s of + Left w -> error $ "Refined(fromString):" ++ errorDisplay (getOpt @opts) w + Right r -> r -errorDisplay :: POpts -> (String,(String,String)) -> String -errorDisplay o (bp,(top,e)) = - bp - ++ (if null top then "" else " " ++ top) - ++ (if null e || hasNoTree o then "" else "\n" ++ e) +errorDisplay :: POpts -> Msg0 -> String +errorDisplay o m = + m0ValBoolColor m + ++ nullIf " " (m0Short m) + ++ (if null (m0Long m) || hasNoTree o + then "" + else "\n" ++ m0Long m) -- | 'Read' instance for 'Refined' -- --- >>> reads @(Refined OZ (Between 0 255 Id) Int) "Refined 254" +-- >>> reads @(Refined OZ (0 <..> 299) Int) "Refined 254" -- [(Refined 254,"")] -- --- >>> reads @(Refined OZ (Between 0 255 Id) Int) "Refined 300" +-- >>> reads @(Refined OZ (0 <..> 299) Int) "Refined 300" -- [] -- -- >>> reads @(Refined OZ 'True Int) "Refined (-123)xyz" -- [(Refined (-123),"xyz")] -- -instance (RefinedC opts p a, Read a) => Read (Refined opts p a) where +instance ( RefinedC opts p a + , Read a + ) => Read (Refined opts p a) where readPrec = GR.parens (PCR.prec @@ -191,7 +129,7 @@ readListPrec = GR.readListPrecDefault -- | the constraints that 'Refined' must adhere to -type RefinedC opts p a = (OptTC opts, PP p a ~ Bool, P p a) +type RefinedC opts p a = (OptC opts, PP p a ~ Bool, P p a) -- | 'ToJSON' instance for 'Refined' instance ToJSON a => ToJSON (Refined opts p a) where @@ -204,7 +142,7 @@ -- Right (Refined 13) -- -- >>> removeAnsi $ A.eitherDecode' @(Refined OAN (Between 10 14 Id) Int) "16" --- Error in $: Refined(FromJSON:parseJSON):FalseT (16 <= 14) +-- Error in $: Refined(FromJSON:parseJSON):False (16 <= 14) -- False 16 <= 14 -- | -- +- P Id 16 @@ -212,15 +150,15 @@ -- +- P '10 -- | -- `- P '14 --- <BLANKLINE> -- -instance (RefinedC opts p a, FromJSON a) => FromJSON (Refined opts p a) where +instance ( RefinedC opts p a + , FromJSON a + ) => FromJSON (Refined opts p a) where parseJSON z = do a <- parseJSON z - let (w,mr) = runIdentity $ newRefinedM @opts @p a - case mr of - Nothing -> fail $ "Refined(FromJSON:parseJSON):" ++ errorDisplay (getOptT @opts) w - Just r -> return r + case newRefined @opts @p a of + Left w -> fail $ "Refined(FromJSON:parseJSON):" ++ errorDisplay (getOpt @opts) w + Right r -> return r -- | 'Binary' instance for 'Refined' -- @@ -234,7 +172,7 @@ -- Refined "2019-04-23" -- -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) --- Refined(Binary:get):FalseT (2019-05-30 <= 2019-04-23) +-- Refined(Binary:get):False (2019-05-30 <= 2019-04-23) -- False 2019-05-30 <= 2019-04-23 -- | -- +- P ReadP Day 2019-04-23 @@ -248,15 +186,15 @@ -- `- P ReadP Day 2019-06-01 -- | -- `- P '"2019-06-01" --- <BLANKLINE> -- -instance (RefinedC opts p a, Binary a) => Binary (Refined opts p a) where +instance ( RefinedC opts p a + , Binary a + ) => Binary (Refined opts p a) where get = do fld0 <- B.get @a - let (w,mr) = runIdentity $ newRefinedM @opts @p fld0 - case mr of - Nothing -> fail $ "Refined(Binary:get):" ++ errorDisplay (getOptT @opts) w - Just r -> return r + case newRefined @opts @p fld0 of + Left w -> fail $ "Refined(Binary:get):" ++ errorDisplay (getOpt @opts) w + Right r -> return r put (Refined r) = B.put @a r -- | 'Hashable' instance for 'Refined' @@ -267,11 +205,11 @@ -- | 'Arbitrary' instance for 'Refined' -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OU (Id /= 0) Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OAN (Id /= 0) Int))) -- >>> all ((/=0) . unRefined) xs -- True -- --- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OU (Prime Id) Int))) +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined OAN IsPrime Int))) -- >>> all (isPrime . unRefined) xs -- True -- @@ -283,278 +221,113 @@ -- | create 'Refined' generator using a generator to restrict the values genRefined :: forall opts p a . - RefinedC opts p a + ( RefinedC opts p a + , HasCallStack + ) => Gen a -> Gen (Refined opts p a) genRefined g = - let o = getOptT @opts - f !cnt = do - ma <- suchThatMaybe g (\a -> getValLRFromTT (runIdentity (eval @_ (Proxy @p) o a)) == Right True) + let f !cnt = do + ma <- suchThatMaybe g $ \a -> evalQuick @opts @p a == Right True case ma of Nothing -> - if cnt >= oRecursion o - then error $ setOtherEffects o ("genRefined recursion exceeded(" ++ show (oRecursion o) ++ ")") - else f (cnt+1) + let o = getOpt @opts + in if cnt >= oRecursion o + then error $ setOtherEffects o ("genRefined recursion exceeded(" ++ show (oRecursion o) ++ ")") + else f (cnt+1) Just a -> pure $ unsafeRefined a in f 0 --- | binary operation applied to two 'RefinedT' values --- --- >>> 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 --- <BLANKLINE> --- === b === --- True 4 <= 5 <= 12 --- | --- +- P Id 5 --- | --- +- P '4 --- | --- `- P '12 --- <BLANKLINE> --- === a `op` b === --- True 4 <= 9 <= 12 --- | --- +- P Id 9 --- | --- +- P '4 --- | --- `- P '12 --- <BLANKLINE> --- 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 --- <BLANKLINE> --- === b === --- True True || False --- | --- +- True Prime --- | | --- | `- P Id 5 --- | --- `- False 5 < 3 --- | --- +- P Id 5 --- | --- `- P '3 --- <BLANKLINE> --- === a `op` b === --- False False || False | (Prime) || (8 < 3) --- | --- +- False Prime --- | | --- | `- P Id 8 --- | --- `- False 8 < 3 --- | --- +- P Id 8 --- | --- `- P '3 --- <BLANKLINE> --- failure msg[FalseT] --- -rapply :: forall opts p a opts1 z m . (z ~ (opts ':# opts1), OptTC opts1, RefinedC opts p a, Monad m) - => (a -> a -> 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 - let opts1 = getOptT @opts1 - tell [setOtherEffects opts1 "=== b ==="] - Refined y <- mb - 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 opts p a m . (RefinedC opts p a, Monad m) - => (a -> a -> a) - -> Refined opts p a - -> Refined opts p a - -> RefinedT m (Refined opts p a) -rapplyLift f (Refined a) (Refined b) = newRefinedT (f a b) - --- | attempts to lift a refinement type to another refinement type by way of transformation function --- you can control both the predicate and the type -convertRefinedT :: forall opts p a p1 a1 m - . ( RefinedC opts p1 a1 - , Monad m) - => (a -> a1) - -> RefinedT m (Refined opts p a) - -> RefinedT m (Refined opts p1 a1) -convertRefinedT f ma = do - Refined a <- ma -- you already got a refined in there so no need to check RefinedC - newRefinedT @opts @p1 (f a) +data Msg0 = Msg0 { m0BoolE :: !(Either String Bool) + , m0Short :: !String + , m0Long :: !String + , m0ValBoolColor :: !String + } deriving Eq --- | invokes the callback with the 'Refined' value if \'a\' is valid for the predicate \'p\' -withRefinedT :: forall opts p m a b - . ( Monad m - , RefinedC opts p a - ) - => a - -> (Refined opts p a -> RefinedT m b) - -> RefinedT m b -withRefinedT a k = newRefinedT @opts @p a >>= k +showMsg0 :: Msg0 -> String +showMsg0 (Msg0 a b c d) = "Msg0 [" ++ show a ++ "]\nShort[" ++ b ++ "]\nLong[" ++ c ++ "]\nColor[" ++ d ++ "]" --- | IO version of `withRefinedT` -withRefinedTIO :: forall opts p m a b - . ( MonadIO m - , RefinedC opts p a - ) - => a - -> (Refined opts p a -> RefinedT m b) - -> RefinedT m b -withRefinedTIO a k = newRefinedTIO @opts @p a >>= k +instance Show Msg0 where + show = m0Long --- | same as 'newRefined' but prints the results -prtRefinedIO :: forall opts p a - . RefinedC opts p a +newRefined' :: forall opts p a m + . ( MonadEval m + , RefinedC opts p a + ) => a - -> IO (Either (BoolT Bool) (Refined opts p a)) -prtRefinedIO a = do - let o = getOptT @opts - tt <- evalBool (Proxy @p) o a - let r = _tBool tt - case oDebug o of - DZero -> pure () - DLite -> putStrLn $ colorBoolT o r <> " " <> topMessage tt - _ -> putStrLn $ prtTree o tt - pure $ case getValueLR o "" tt [] of - Right True -> Right (Refined a) - _ -> Left r + -> m (Either Msg0 (Refined opts p a)) +newRefined' a = do + let o = getOpt @opts + pp <- evalBool (Proxy @p) o a + let r = colorValBool o (_ttVal pp) + s = prtTree o pp + msg0 = Msg0 (pp ^. ttVal . _ValEither) (topMessage pp) s r + pure $ case getValueLR NoInline o "" pp [] of + Right True -> Right (Refined a) + _ -> Left msg0 --- | returns a 'Refined' value if \'a\' is valid for the predicate \'p\' +-- | returns a 'Refined' value if @a@ is valid for the predicate @p@ -- -- >>> newRefined @OL @(ReadP Int Id > 99) "123" -- Right (Refined "123") -- --- >>> newRefined @OL @(ReadP Int Id > 99) "12" --- Left "FalseT (12 > 99)" +-- >>> left m0Long $ newRefined @OL @(ReadP Int Id > 99) "12" +-- Left "False (12 > 99)" -- -newRefined :: forall opts p a - . RefinedC opts p a - => a - -> Either String (Refined opts p a) -newRefined a = - let ((bp,(top,e)),mr) = runIdentity $ newRefinedM @opts @p a - in case mr of - Nothing -> case oDebug (getOptT @opts) of - DZero -> Left bp - DLite -> Left (bp <> (if null top then "" else " " <> top)) - _ -> Left e - Just r -> Right r +-- >>> newRefined @OZ @(Between 10 14 Id) 13 +-- Right (Refined 13) +-- +-- >>> left m0BoolE $ newRefined @OZ @(Between 10 14 Id) 99 +-- Left (Right False) +-- +-- >>> newRefined @OZ @(Last >> Len == 4) ["one","two","three","four"] +-- Right (Refined ["one","two","three","four"]) +-- +-- >>> newRefined @OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$") "141.213.1.99" +-- Right (Refined "141.213.1.99") +-- +-- >>> left m0BoolE $ newRefined @OZ @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$") "141.213.1" +-- Left (Right False) +-- +-- >>> left m0BoolE $ newRefined @OZ @(Map' (ReadP Int Id) (Resplit "\\.") >> GuardBool (PrintF "bad length: found %d" Len) (Len == 4)) "141.213.1" +-- Left (Left "bad length: found 3") +-- +-- >>> left m0BoolE $ newRefined @OZ @(Map' (ReadP Int Id) (Resplit "\\.") >> GuardBool (PrintF "bad length: found %d" Len) (Len == 4) && BoolsN (PrintT "octet %d out of range %d" Id) 4 (0 <..> 0xff)) "141.213.1.444" +-- Left (Left "Bool(3) [octet 3 out of range 444]") +-- +-- >>> left m0BoolE $ newRefined @OZ @(Map' (ReadP Int Id) (Resplit "\\.") >> GuardBool (PrintF "bad length: found %d" Len) (Len == 4) && BoolsN (PrintT "octet %d out of range %d" Id) 4 (0 <..> 0xff)) "141.213.1x34.444" +-- Left (Left "ReadP Int (1x34)") +-- +-- >>> newRefined @OZ @(Map ('[Id] >> ReadP Int Id) >> IsLuhn) "12344" +-- Right (Refined "12344") +-- +-- >>> left m0BoolE $ newRefined @OZ @(Map ('[Id] >> ReadP Int Id) >> IsLuhn) "12340" +-- Left (Right False) +-- +-- >>> newRefined @OZ @(Any IsPrime) [11,13,17,18] +-- Right (Refined [11,13,17,18]) +-- +-- >>> left m0BoolE $ newRefined @OZ @(All IsPrime) [11,13,17,18] +-- Left (Right False) +-- +-- >>> newRefined @OZ @(Snd !! Fst >> Len > 5) (2,["abc","defghij","xyzxyazsfd"]) +-- Right (Refined (2,["abc","defghij","xyzxyazsfd"])) +-- +-- >>> left m0BoolE $ newRefined @OZ @(Snd !! Fst >> Len > 5) (27,["abc","defghij","xyzxyazsfd"]) +-- Left (Left "(!!) index not found") +-- +-- >>> left m0BoolE $ newRefined @OZ @(Snd !! Fst >> Len <= 5) (2,["abc","defghij","xyzxyazsfd"]) +-- Left (Right False) +-- +-- >>> newRefined @OU @((Id $$ 13) > 100) (\x -> x * 14) ^? _Right . to unRefined . to ($ 99) +-- Just 1386 +-- -newRefinedM :: forall opts p a m - . ( MonadEval m - , RefinedC opts p a - ) +newRefined :: forall opts p a + . RefinedC opts p a => a - -> m ((String, (String, String)), Maybe (Refined opts p a)) -newRefinedM a = do - let o = getOptT @opts - pp <- evalBool (Proxy @p) o a - let r = colorBoolT' o (_tBool pp) - s = prtTree o pp - pure $ ((r,(topMessage pp, s)),) $ case getValueLR o "" pp [] of - Right True -> Just (Refined a) - _ -> Nothing - -newRefinedTImpl :: forall opts p a n m - . ( RefinedC opts p a - , Monad m - , MonadEval n - ) - => (forall x . n x -> RefinedT m x) - -> a - -> RefinedT m (Refined opts p a) -newRefinedTImpl f a = do - let o = getOptT @opts - tt <- f $ evalBool (Proxy @p) o a - let msg = prtTree o tt - tell [msg] - case getValueLR o "" tt [] of - Right True -> return (Refined a) -- FalseP is also a failure! - _ -> throwError $ colorBoolT' o (_tBool tt) - --- | returns a wrapper 'RefinedT' around a possible 'Refined' value if \'a\' is valid for the predicate \'p\' -newRefinedT :: forall opts p a m - . ( RefinedC opts p a - , Monad m) - => a - -> RefinedT m (Refined opts p a) -newRefinedT = newRefinedTImpl (return . runIdentity) - --- | IO version of 'newRefinedT' -newRefinedTIO :: forall opts p a m - . ( RefinedC opts p a - , MonadIO m) - => a - -> RefinedT m (Refined opts p a) -newRefinedTIO = newRefinedTImpl liftIO - --- | effect wrapper for the refinement value -newtype RefinedT m a = RefinedT { unRefinedT :: ExceptT String (WriterT [String] m) a } - deriving (Functor, Applicative, Monad, MonadCont, MonadWriter [String], Show, MonadIO) - -instance MonadTrans RefinedT where - lift ma = RefinedT $ ExceptT $ WriterT $ do - a <- ma - return (Right a, []) - -instance Monad m => MonadError String (RefinedT m) where - throwError e = RefinedT $ ExceptT $ WriterT $ return (Left e,[]) - catchError (RefinedT (ExceptT (WriterT ma))) ema = - RefinedT $ ExceptT $ WriterT $ do - (lr,ss) <- ma - case lr of - Left e -> unRavelT (tell ss >> ema e) -- keep the old messages?? - Right _ -> ma - --- | unwrap the 'RefinedT' value -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 f rt = do - (lr,ws) <- f $ unRavelT rt - liftIO $ do - forM_ (zip [1::Int ..] ws) $ \(_,y) -> unless (null y) $ putStrLn y - case lr of - Left e -> putStrLn $ "failure msg[" <> e <> "]" - Right a -> print a - -prtRefinedTIO :: (MonadIO m, Show a) => RefinedT m a -> m () -prtRefinedTIO = prtRefinedTImpl id + -> Either Msg0 (Refined opts p a) +newRefined = runIdentity . newRefined' -- | create an unsafe 'Refined' value without running the predicate unsafeRefined :: forall opts p a . a -> Refined opts p a @@ -566,19 +339,13 @@ , HasCallStack ) => a -> Refined opts p a unsafeRefined' a = - let o = getOptT @opts + let o = getOpt @opts tt = runIdentity $ evalBool (Proxy @p) o a - in case getValueLR o "" tt [] of + in case getValueLR NoInline o "" tt [] of Right True -> Refined a _ -> let s = prtTree o tt - bp = colorBoolT' o (view tBool tt) + bp = colorValBool o (_ttVal tt) in case oDebug o of DZero -> error bp - DLite -> error $ bp ++ "\n" ++ s - _ -> error $ bp ++ "\n" ++ s - -type family ReplaceOptT (o :: OptT) t where - ReplaceOptT o (Refined _ p a) = Refined o p a - -type family AppendOptT (o :: OptT) t where - AppendOptT o (Refined o' p a) = Refined (o' ':# o) p a + DLite -> error $ bp ++ nullIf "\n" s + _ -> error $ bp ++ nullIf "\n" s
− src/Predicate/Refined1.hs
@@ -1,935 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wno-redundant-constraints #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE NoStarIsType #-} --- | --- Refinement type allowing the external type to differ from the internal type --- doesnt store the output value but runs on demand but has calculate each time and could fail later --- see 'Refined1' --- --- @ --- similar to 'Predicate.Refined2.Refined2' but also provides: --- * quickCheck methods --- * ability to combine refinement types --- * a canonical output value using the \'fmt\' parameter --- @ --- -module Predicate.Refined1 ( - - -- ** Refined1 - Refined1 - , unRefined1 - , Refined1C - - -- ** display results - , prtEval1 - , prtEval1P - , prtEval1IO - , prtEval1PIO - , prt1IO - , prt1Impl - , Msg1 (..) - , RResults1 (..) - - -- ** evaluation methods - , eval1 - , eval1P - , eval1M - , newRefined1 - , newRefined1P - - -- ** create a wrapped Refined1 value - , newRefined1T - , newRefined1TP - , newRefined1TPIO - , withRefined1T - , withRefined1TIO - , withRefined1TP - - -- ** proxy methods - , mkProxy1 - , mkProxy1' - , MakeR1 - - -- ** unsafe methods for creating Refined1 - , unsafeRefined1 - , unsafeRefined1' - - -- ** combine Refined1 values - , convertRefined1TP - , rapply1 - , rapply1P - - -- ** QuickCheck methods - , genRefined1 - , genRefined1P - - -- ** emulate Refined1 using Refined - , RefinedEmulate - , eval1PX - , eval1X - - , type ReplaceOptT1 - , type AppendOptT1 - - ) where -import Predicate.Refined -import Predicate.Core -import Predicate.Util -import Data.Functor.Identity (Identity(..)) -import Data.Tree -import Data.Proxy -import Control.Arrow (left) -import Control.Monad.Except -import Control.Monad.Writer (tell) -import Data.Aeson (ToJSON(..), FromJSON(..)) -import qualified Language.Haskell.TH.Syntax as TH -import Test.QuickCheck -import qualified GHC.Read as GR -import qualified Text.ParserCombinators.ReadPrec as PCR -import qualified Text.Read.Lex as RL -import qualified Data.Binary as B -import Data.Binary (Binary) -import Data.Maybe (fromMaybe) -import Control.Lens ((^.)) -import Data.Tree.Lens (root) -import Data.Char (isSpace) -import Data.String -import Data.Hashable (Hashable(..)) -import GHC.Stack - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> :set -XOverloadedStrings --- >>> :m + Predicate.Prelude --- >>> :m + Data.Time - --- | Refinement type that differentiates the input from output: similar to 'Predicate.Refined3.Refined3' but only creates the output value as needed. --- --- * @opts@ are the display options --- * @ip@ converts @i@ to @PP ip i@ which is the internal type and stored in 'unRefined1' --- * @op@ validates that internal type using @PP op (PP ip i) ~ Bool@ --- * @fmt@ outputs the internal type @PP fmt (PP ip i) ~ i@ (not stored anywhere but created on demand) --- * @i@ is the input type --- --- * @PP fmt (PP ip i)@ should be valid as input for Refined1 --- --- Setting @ip@ to @Id@ and @fmt@ to @Id@ makes it equivalent to 'Refined.Refined': see 'RefinedEmulate' --- --- Setting the input type @i@ to 'GHC.Base.String' resembles the corresponding Read/Show instances but with an additional predicate on the read value --- --- * __read__ a string using /ip/ into an internal type and store in 'unRefined1' --- * __validate__ 'unRefined1' using the predicate /op/ --- * __show__ 'unRefined1' using /fmt/ (does not store the formatted result unlike 'Predicate.Refined3.Refined3') --- --- 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" --- Right (Refined1 254) --- --- >>> 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" --- 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" --- 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" --- 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" --- 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) --- 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) --- 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) --- 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) --- >>> newRefined1P (Proxy @(T4 _)) (2019,10,12) --- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" --- --- >>> newRefined1P (Proxy @(T4 _)) (2019,10,13) --- Right (Refined1 (2019-10-13,41,7)) --- -newtype Refined1 (opts :: OptT) ip op fmt i = Refined1 (PP ip i) - -unRefined1 :: forall (opts :: OptT) ip op fmt i. Refined1 opts ip op fmt i -> PP ip i -unRefined1 (Refined1 a) = a - -type role Refined1 nominal nominal nominal nominal nominal - --- | directly load values into 'Refined1'. It still checks to see that those values are valid -unsafeRefined1' :: forall opts ip op fmt i - . ( HasCallStack - , Show i - , Show (PP ip i) - , Refined1C opts ip op fmt i - ) - => i - -> Refined1 opts ip op fmt i -unsafeRefined1' i = - let (ret,mr) = eval1 @opts @ip @op @fmt i - in fromMaybe (error $ show (prt1Impl (getOptT @opts) ret)) mr - --- | directly load values into 'Refined1' without any checking -unsafeRefined1 :: forall opts ip op fmt i . PP ip i -> Refined1 opts ip op fmt i -unsafeRefined1 = Refined1 - --- | Provides the constraints on Refined1 -type Refined1C opts ip op fmt i = - ( OptTC opts - , P ip i - , P op (PP ip i) - , PP op (PP ip i) ~ Bool -- the internal value needs to pass the predicate check - , P fmt (PP ip i) - , 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) - --- | 'IsString' instance for Refined1 --- --- >>> 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" --- Left () --- -instance (Refined1C opts ip op fmt String, Show (PP ip String)) => IsString (Refined1 opts ip op fmt String) where - fromString s = - let (ret,mr) = eval1 @opts @ip @op @fmt s - in fromMaybe (error $ "Refined1(fromString):" ++ show (prt1Impl (getOptT @opts) ret)) mr - --- 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" --- [(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) (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]" --- [(Refined1 [192,168,0,1],"")] --- --- >>> reads @(Refined1 OZ Id 'True Id Int) "Refined1 (-123)xyz" --- [(Refined1 (-123),"xyz")] --- - - -instance ( Eq i - , Show i - , Eq (PP ip i) - , Show (PP ip i) - , Refined1C opts ip op fmt i - , Read (PP ip i) - , Read (PP fmt (PP ip i)) - ) => Read (Refined1 opts ip op fmt i) where - readPrec - = GR.parens - (PCR.prec - 11 - (do GR.expectP (RL.Ident "Refined1") - fld1 <- PCR.reset GR.readPrec - - let (_ret,mr) = runIdentity $ eval1MSkip @opts @ip @op @fmt fld1 - case mr of - Nothing -> fail "" - Just (Refined1 r1) - | r1 == fld1 -> pure (Refined1 r1) - | otherwise -> fail "" -- cant display a decent failure message - )) - readList = GR.readListDefault - readListPrec = GR.readListPrecDefault - --- | '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) --- "\"fe\"" --- --- >>> A.encode (unsafeRefined1 @OZ @Id @'True @Id 123) --- "123" --- -instance ( OptTC opts - , Show (PP fmt (PP ip i)) - , ToJSON (PP fmt (PP ip i)) - , P fmt (PP ip i) - ) => ToJSON (Refined1 opts ip op fmt i) where - toJSON (Refined1 x) = - let ss = runIdentity $ eval (Proxy @fmt) (getOptT @opts) x - in case getValAndPE ss of - (Right b,_) -> toJSON b - (Left e,t3) -> error $ "oops tojson failed " ++ show e ++ " t3=" ++ show t3 - - --- | '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\"" --- Right (Refined1 254) --- --- >>> 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)} --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) (16663610) *** --- <BLANKLINE> --- P ReadBase(Int,16) 16663610 --- | --- `- P Id "00fe443a" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False True && False | (16663610 < 256) --- | --- +- True 16663610 > 10 --- | | --- | +- P Id 16663610 --- | | --- | `- P '10 --- | --- `- False 16663610 < 256 --- | --- +- P Id 16663610 --- | --- `- P '256 --- <BLANKLINE> --- -instance (Show ( PP fmt (PP ip i)) - , Show (PP ip i) - , Refined1C opts ip op fmt i - , FromJSON i - ) => FromJSON (Refined1 opts ip op fmt i) where - parseJSON z = do - i <- parseJSON @i z - let (ret,mr) = eval1 @opts @ip @op @fmt i - case mr of - Nothing -> fail $ "Refined1:" ++ show (prt1Impl (getOptT @opts) ret) - Just r -> return r --- | 'Arbitrary' instance for 'Refined1' --- --- >>> 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))) --- >>> all (isPrime . unRefined1) xs --- True --- -instance (Arbitrary (PP ip i) - , Refined1C opts ip op fmt i - ) => Arbitrary (Refined1 opts ip op fmt i) where - arbitrary = genRefined1 arbitrary - --- | create a 'Refined1' generator --- --- >>> 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 --- -genRefined1 :: - forall opts ip op fmt i - . Refined1C opts ip op fmt i - => Gen (PP ip i) - -> Gen (Refined1 opts ip op fmt i) -genRefined1 = genRefined1P Proxy - --- | create a 'Refined1' generator with a Proxy -genRefined1P :: - forall opts ip op fmt i - . Refined1C opts ip op fmt i - => Proxy '(opts,ip,op,fmt,i) - -> Gen (PP ip i) - -> Gen (Refined1 opts ip op fmt i) -genRefined1P _ g = - let o = getOptT @opts - f !cnt = do - mppi <- suchThatMaybe g (\a -> getValLRFromTT (runIdentity (eval @_ (Proxy @op) o a)) == Right True) - case mppi of - Nothing -> - if cnt >= oRecursion o - then error $ setOtherEffects o ("genRefined1 recursion exceeded(" ++ show (oRecursion o) ++ ")") - else f (cnt+1) - Just ppi -> - pure $ unsafeRefined1 ppi - in f 0 - --- | 'Binary' instance for 'Refined1' --- --- >>> 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) --- >>> r = unsafeRefined1' "2019-04-23" :: K1 --- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) --- Refined1 2019-04-23 --- --- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) --- Refined1:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** --- <BLANKLINE> --- P ReadP Day 2019-04-23 --- | --- `- P Id "2019-04-23" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False 2019-05-30 <= 2019-04-23 --- | --- +- P Id 2019-04-23 --- | --- +- P ReadP Day 2019-05-30 --- | | --- | `- P '"2019-05-30" --- | --- `- P ReadP Day 2019-06-01 --- | --- `- P '"2019-06-01" --- <BLANKLINE> --- - -instance ( Show (PP fmt (PP ip i)) - , Show (PP ip i) - , Refined1C opts ip op fmt i - , Binary i - ) => Binary (Refined1 opts ip op fmt i) where - get = do - i <- B.get @i - let (ret,mr) = eval1 @opts @ip @op @fmt i - case mr of - Nothing -> fail $ "Refined1:" ++ show (prt1Impl (getOptT @opts) ret) - Just r -> return r - put (Refined1 x) = - let ss = runIdentity $ eval (Proxy @fmt) (getOptT @opts) x - in case getValAndPE ss of - (Right b,_) -> B.put @i b - (Left e,t3) -> error $ "oops tojson failed " ++ show e ++ " t3=" ++ show t3 - --- | 'Hashable' instance for 'Refined1' -instance (Refined1C opts ip op fmt i - , Hashable (PP ip i) - ) => Hashable (Refined1 opts ip op fmt i) where - hashWithSalt s (Refined1 a) = s + hash a - --- | creates a 5-tuple proxy (see 'withRefined1TP' 'newRefined1TP' 'eval1P' 'prtEval1P') --- --- use type application to set the 5-tuple or set the individual parameters directly --- --- set the 5-tuple directly --- --- >>> 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) --- >>> 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 = Proxy - --- | same as 'mkProxy1' but checks to make sure the proxy is consistent with the 'Refined1C' constraint -mkProxy1' :: forall z opts ip op fmt i - . ( z ~ '(opts,ip,op,fmt,i) - , Refined1C opts ip op fmt i - ) => Proxy '(opts,ip,op,fmt,i) -mkProxy1' = Proxy - --- | type family for converting from a 5-tuple '(ip,op,fmt,i) to a 'Refined1' type -type family MakeR1 p where - MakeR1 '(opts,ip,op,fmt,i) = Refined1 opts ip op fmt i - -withRefined1TIO :: forall opts ip op fmt i m b - . ( MonadIO m - , Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => i - -> (Refined1 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined1TIO = (>>=) . newRefined1TPIO (Proxy @'(opts,ip,op,fmt,i)) - --- | create a 'Refined1' value using a continuation --- --- This first example reads a hex string and makes sure it is between 100 and 200 and then --- reads a binary string and adds the values together --- --- >>> :set -XPolyKinds --- >>> :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) --- 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) --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) (41864) *** --- <BLANKLINE> --- P ReadBase(Int,16) 41864 --- | --- `- P Id "a388" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False 41864 <= 200 --- | --- +- P Id 41864 --- | --- +- P '100 --- | --- `- P '200 --- <BLANKLINE> --- failure msg[Step 2. False Boolean Check(op) | {41864 <= 200}] --- -withRefined1T :: forall opts ip op fmt i m b - . ( Monad m - , Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i) - => i - -> (Refined1 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined1T = (>>=) . newRefined1TP (Proxy @'(opts,ip,op,fmt,i)) - -withRefined1TP :: forall opts ip op fmt i b proxy m - . ( Monad m - , Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => proxy '(opts,ip,op,fmt,i) - -> i - -> (Refined1 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined1TP p = (>>=) . newRefined1TP p - --- | pure version for extracting Refined1 --- --- >>> 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" --- 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" --- Right (Refined1 [1,2,3]) --- -newRefined1 :: forall opts ip op fmt i - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => i - -> Either String (Refined1 opts ip op fmt i) -newRefined1 = newRefined1P Proxy - -newRefined1P :: forall opts ip op fmt i proxy - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => proxy '(opts,ip,op,fmt,i) - -> i - -> Either String (Refined1 opts ip op fmt i) -newRefined1P _ x = - let (lr,xs) = runIdentity $ unRavelT $ newRefined1T @opts @ip @op @fmt x - in left (\e -> e ++ (if all null xs then "" else "\n" ++ unlines xs)) lr - -newRefined1T :: forall opts ip op fmt i m - . ( Refined1C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i - ) - => i - -> RefinedT m (Refined1 opts ip op fmt i) -newRefined1T = newRefined1TP (Proxy @'(opts,ip,op,fmt,i)) - --- | 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) --- 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) --- 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) --- failure msg[Step 2. False Boolean Check(op) | {wrong day: 6 == 5}] --- -newRefined1TP :: forall opts ip op fmt i proxy m - . ( Refined1C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i - ) - => proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined1 opts ip op fmt i) -newRefined1TP = newRefined1TPImpl (return . runIdentity) - -newRefined1TPIO :: forall opts ip op fmt i proxy m - . ( Refined1C opts ip op fmt i - , MonadIO m - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined1 opts ip op fmt i) -newRefined1TPIO = newRefined1TPImpl liftIO - -newRefined1TPImpl :: forall n m opts ip op fmt i proxy - . ( Refined1C opts ip op fmt i - , Monad m - , MonadEval n - , Show (PP ip i) - , Show (PP fmt (PP ip i))) - => (forall x . n x -> RefinedT m x) - -> proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined1 opts ip op fmt i) -newRefined1TPImpl f _ i = do - (ret,mr) <- f $ eval1M i - let m1 = prt1Impl (getOptT @opts) ret - tell [m1Long m1] - case mr of - Nothing -> throwError $ m1Desc m1 <> " | " <> m1Short m1 - Just r -> return r - -newRefined1TPSkipIPImpl :: forall n m opts ip op fmt i proxy - . ( Refined1C opts ip op fmt i - , Monad m - , MonadEval n - , Show (PP ip i) - , Show (PP fmt (PP ip i))) - => (forall x . n x -> RefinedT m x) - -> proxy '(opts,ip,op,fmt,i) - -> PP ip i - -> RefinedT m (Refined1 opts ip op fmt i) -newRefined1TPSkipIPImpl f _ a = do - (ret,mr) <- f $ eval1MSkip a - let m1 = prt1Impl (getOptT @opts) ret - tell [m1Long m1] - case mr of - Nothing -> throwError $ m1Desc m1 <> " | " <> m1Short m1 - Just r -> return r - --- | attempts to cast a wrapped 'Refined1' to another 'Refined1' with different predicates -convertRefined1TP :: forall opts ip op fmt i ip1 op1 fmt1 i1 m . - ( Refined1C opts ip1 op1 fmt1 i1 - , Monad m - , Show (PP ip i) - , PP ip i ~ PP ip1 i1 - , Show i1) - => Proxy '(opts, ip, op, fmt, i) - -> Proxy '(opts, ip1, op1, fmt1, i1) - -> RefinedT m (Refined1 opts ip op fmt i) - -> RefinedT m (Refined1 opts ip1 op1 fmt1 i1) -convertRefined1TP _ _ ma = do - Refined1 x <- ma - -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call - Refined1 a <- newRefined1TPSkipIPImpl (return . runIdentity) (Proxy @'(opts, ip1, op1, fmt1, i1)) x - return (Refined1 a) - --- | applies a binary operation to two wrapped 'Refined1' parameters -rapply1 :: forall opts ip op fmt i m . - ( Refined1C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined1 opts ip op fmt i) - -> RefinedT m (Refined1 opts ip op fmt i) - -> RefinedT m (Refined1 opts ip op fmt i) -rapply1 = rapply1P (Proxy @'(opts,ip,op,fmt,i)) - --- prtRefinedTIO $ rapply1P base16 (+) (newRefined1TP Proxy "ff") (newRefined1TP Proxy "22") - --- | same as 'rapply1' but uses a 5-tuple proxy instead -rapply1P :: forall opts ip op fmt i proxy m . - ( Refined1C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined1 opts ip op fmt i) - -> RefinedT m (Refined1 opts ip op fmt i) - -> RefinedT m (Refined1 opts ip op fmt i) -rapply1P p f ma mb = do - let opts = getOptT @opts - tell [setOtherEffects opts "=== a ==="] - Refined1 x <- ma - tell [setOtherEffects opts "=== b ==="] - 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 ==="] - newRefined1TPSkipIPImpl (return . runIdentity) p (f x y) - --- | An ADT that summarises the results of evaluating Refined1 representing all possible states -data RResults1 a b = - RF !String !(Tree PE) -- Left e - | RTF !a !(Tree PE) !String !(Tree PE) -- Right a + Left e - | RTFalse !a !(Tree PE) !(Tree PE) -- Right a + Right False - | RTTrueF !a !(Tree PE) !(Tree PE) !String !(Tree PE) -- Right a + Right True + Left e - | RTTrueT !a !(Tree PE) !(Tree PE) !b !(Tree PE) -- Right a + Right True + Right b - deriving Show - --- | same as 'prtEval1PIO' but passes in the proxy -prtEval1IO :: forall opts ip op fmt i - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i) - => i - -> IO (Either String (Refined1 opts ip op fmt i)) -prtEval1IO = prtEval1PIO Proxy - --- | same as 'prtEval1P' but runs in IO -prtEval1PIO :: forall opts ip op fmt i proxy - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> i - -> IO (Either String (Refined1 opts ip op fmt i)) -prtEval1PIO _ i = do - x <- eval1M i - prt1IO @opts x - --- | same as 'prtEval1P' but skips the proxy and allows you to set each parameter individually using type application -prtEval1 :: forall opts ip op fmt i - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i) - => i - -> Either Msg1 (Refined1 opts ip op fmt i) -prtEval1 = prtEval1P Proxy - --- | create a Refined1 using a 5-tuple proxy and aggregate the results on failure -prtEval1P :: forall opts ip op fmt i proxy - . ( Refined1C opts ip op fmt i - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> i - -> Either Msg1 (Refined1 opts ip op fmt i) -prtEval1P _ i = - let (ret,mr) = eval1 i - in maybe (Left $ prt1Impl (getOptT @opts) ret) Right mr - --- | create a Refined1 value using a 5-tuple proxy (see 'mkProxy1') --- --- use 'mkProxy1' to package all the types together as a 5-tuple --- -eval1P :: forall opts ip op fmt i proxy . Refined1C opts ip op fmt i - => proxy '(opts,ip,op,fmt,i) - -> i - -> (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined1 opts ip op fmt i)) -eval1P _ = runIdentity . eval1M - --- | same as 'eval1P' but can pass the parameters individually using type application -eval1 :: forall opts ip op fmt i . Refined1C opts ip op fmt i - => i - -> (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined1 opts ip op fmt i)) -eval1 = eval1P Proxy - -eval1M :: forall opts ip op fmt i m . (MonadEval m, Refined1C opts ip op fmt i) - => i - -> m (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined1 opts ip op fmt i)) -eval1M i = do - let o = getOptT @opts - ll <- eval (Proxy @ip) o i - case getValAndPE ll of - (Right a, t1) -> do - rr <- evalBool (Proxy @op) o a - case getValAndPE rr of - (Right True,t2) -> do - ss <- eval (Proxy @fmt) o a - pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a t1 t2 b t3, Just (Refined1 a)) - (Left e,t3) -> (RTTrueF a t1 t2 e t3, Nothing) - (Right False,t2) -> pure (RTFalse a t1 t2, Nothing) - (Left e,t2) -> pure (RTF a t1 e t2, Nothing) - (Left e,t1) -> pure (RF e t1, Nothing) - --- | creates Refined1 value but skips the initial conversion -eval1MSkip :: forall opts ip op fmt i m . (MonadEval m, Refined1C opts ip op fmt i) - => PP ip i - -> m (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined1 opts ip op fmt i)) -eval1MSkip a = do - let o = getOptT @opts - rr <- evalBool (Proxy @op) o a - case getValAndPE rr of - (Right True,t2) -> do - ss <- eval (Proxy @fmt) o a - pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a mkNodeSkipP t2 b t3, Just (Refined1 a)) - (Left e,t3) -> (RTTrueF a mkNodeSkipP t2 e t3, Nothing) - (Right False,t2) -> pure (RTFalse a mkNodeSkipP t2, Nothing) - (Left e,t2) -> pure (RTF a mkNodeSkipP e t2, Nothing) - -prt1IO :: forall opts a b r . (OptTC opts, Show a, Show b) => (RResults1 a b, Maybe r) -> IO (Either String r) -prt1IO (ret,mr) = do - let o = getOptT @opts - let m1 = prt1Impl o ret - unless (hasNoTree o) $ putStrLn $ m1Long m1 - return $ maybe (Left (m1Desc m1 <> " | " <> m1Short m1)) Right mr - -data Msg1 = Msg1 { m1Desc :: !String - , m1Short :: !String - , m1Long :: !String - } deriving Eq - -instance Show Msg1 where - show (Msg1 a b c) = a <> " | " <> b <> (if null c then "" else "\n" <> c) - -prt1Impl :: forall a b . (Show a, Show b) - => POpts - -> RResults1 a b - -> Msg1 -prt1Impl opts v = - let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - 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 - RF e t1 -> - let (m,n) = ("Step 1. Initial Conversion(ip) Failed", e) - r = outmsg m - <> prtTreePure opts t1 - in mkMsg1 m n r - RTF a t1 e t2 -> - let (m,n) = ("Step 2. Failed Boolean Check(op)", e) - r = msg1 a - <> fixLite opts a t1 - <> outmsg m - <> prtTreePure opts t2 - in mkMsg1 m n r - RTFalse a t1 t2 -> - let (m,n) = ("Step 2. False Boolean Check(op)", z) - z = let w = t2 ^. root . pString - in if all isSpace w then "FalseP" else "{" <> w <> "}" - r = msg1 a - <> fixLite opts a t1 - <> outmsg m - <> prtTreePure opts t2 - in mkMsg1 m n r - RTTrueF a t1 t2 e t3 -> - let (m,n) = ("Step 3. Failed Output Conversion(fmt)", e) - r = msg1 a - <> fixLite opts a t1 - <> outmsg "Step 2. Success Boolean Check(op)" - <> prtTreePure opts t2 - <> outmsg m - <> prtTreePure opts t3 - in mkMsg1 m n r - RTTrueT a t1 t2 b t3 -> - let (m,n) = ("Step 3. Success Output Conversion(fmt)", show b) - r = msg1 a - <> fixLite opts a t1 - <> outmsg "Step 2. Success Boolean Check(op)" - <> prtTreePure opts t2 - <> outmsg m - <> fixLite opts b t3 - in mkMsg1 m n r - --- | similar to 'eval1P' but it emulates 'Refined1' but using 'Refined' --- --- takes a 5-tuple proxy as input but outputs the Refined value and the result separately --- --- * initial conversion using \'ip\' and stores that in 'Refined' --- * runs the boolean predicate \'op\' to make sure to validate the converted value from 1. --- * runs \'fmt\' against the converted value from 1. --- * returns both the 'Refined' and the output from 3. --- * if any of the above steps fail the process stops it and dumps out 'RResults1' --- -eval1PX :: forall opts ip op fmt i proxy . Refined1C opts ip op fmt i - => proxy '(opts,ip,op,fmt,i) - -> i - -> (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined opts op (PP ip i), PP fmt (PP ip i))) -eval1PX _ i = runIdentity $ do - let o = getOptT @opts - ll <- eval (Proxy @ip) o i - case getValAndPE ll of - (Right a,t1) -> do - rr <- evalBool (Proxy @op) o a - case getValAndPE rr of - (Right True,t2) -> do - ss <- eval (Proxy @fmt) o a - pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a t1 t2 b t3, Just (unsafeRefined a, b)) - (Left e,t3) -> (RTTrueF a t1 t2 e t3, Nothing) - (Right False,t2) -> pure (RTFalse a t1 t2, Nothing) - (Left e,t2) -> pure (RTF a t1 e t2, Nothing) - (Left e,t1) -> pure (RF e t1, Nothing) - --- | same as 'eval1PX' but allows you to set the parameters individually using type application -eval1X :: forall opts ip op fmt i . Refined1C opts ip op fmt i - => i - -> (RResults1 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined opts op (PP ip i), PP fmt (PP ip i))) -eval1X = eval1PX (Proxy @'(opts,ip,op,fmt,i)) - --- | emulates 'Refined' using 'Refined1' by setting the input conversion and output formatting as noops -type RefinedEmulate (opts :: OptT) p a = Refined1 opts Id p Id a - --- | replace the opts type -type family ReplaceOptT1 (o :: OptT) t where - ReplaceOptT1 o (Refined1 _ ip op fmt i) = Refined1 o ip op fmt i - --- | change the opts type -type family AppendOptT1 (o :: OptT) t where - AppendOptT1 o (Refined1 o' ip op fmt i) = Refined1 (o' ':# o) ip op fmt i
src/Predicate/Refined2.hs view
@@ -1,13 +1,11 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} +-- tojson binary hash arbitrary all use i not PP ip i +-- all instances work with the original input [ie not the internal values] +-- we have no way to get back to i from PP ip i (unlike Refined3) {-# OPTIONS -Wno-redundant-constraints #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -23,40 +21,27 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE NoStarIsType #-} -{- | - Refinement type allowing the external type to differ from the internal type - see 'Refined2' --} +-- | a refinement type allowing the external type to differ from the internal type module Predicate.Refined2 ( -- ** Refined2 - Refined2(r2In,r2Out) + Refined2 + , r2In + , r2Out , Refined2C -- ** display results - , prtEval2 - , prtEval2P - , prtEval2IO - , prtEval2PIO - , prt2IO - , prt2Impl , Msg2 (..) , RResults2 (..) + , prt2Impl -- ** evaluation methods - , eval2 , eval2P , eval2M , newRefined2 + , newRefined2' , newRefined2P - - -- ** create a wrapped Refined2 value - , newRefined2T - , newRefined2TP - , newRefined2TIO - , withRefined2T - , withRefined2TP - , withRefined2TIO + , newRefined2P' -- ** proxy methods , MakeR2 @@ -71,19 +56,12 @@ , unsafeRefined2 , unsafeRefined2' - , type ReplaceOptT2 - , type AppendOptT2 - ) where -import Predicate.Refined import Predicate.Core +import Predicate.Misc import Predicate.Util -import Data.Functor.Identity (Identity(..)) -import Data.Tree -import Data.Proxy -import Control.Arrow (left) -import Control.Monad.Except -import Control.Monad.Writer (tell) +import Data.Tree (Tree) +import Data.Proxy (Proxy(..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import qualified Language.Haskell.TH.Syntax as TH import qualified GHC.Read as GR @@ -91,15 +69,15 @@ import qualified Text.Read.Lex as RL import qualified Data.Binary as B import Data.Binary (Binary) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Control.Lens import Data.Tree.Lens (root) import Data.Char (isSpace) -import Data.String +import Data.String (IsString(..)) import Data.Hashable (Hashable(..)) -import GHC.Stack +import GHC.Stack (HasCallStack) import Test.QuickCheck - +import Control.DeepSeq (rnf, rnf2, NFData) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications @@ -117,38 +95,16 @@ -- -- 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" --- Right (Refined2 {r2In = 254, r2Out = "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" --- 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" --- 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" --- 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" --- 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) --- 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) --- 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) --- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" --- -data Refined2 (opts :: OptT) ip op i = Refined2 { r2In :: !(PP ip i), r2Out :: !i } +data Refined2 (opts :: Opt) ip op i = Refined2 !(PP ip i) !i -type role Refined2 nominal nominal nominal nominal +r2In :: Refined2 (opts :: Opt) ip op i -> PP ip i +r2In (Refined2 ppi _) = ppi +r2Out :: Refined2 (opts :: Opt) ip op i -> i +r2Out (Refined2 _ i) = i + +type role Refined2 phantom nominal nominal nominal + -- | directly load values into 'Refined2'. It still checks to see that those values are valid unsafeRefined2' :: forall opts ip op i . ( Show (PP ip i) @@ -157,119 +113,129 @@ ) => i -> Refined2 opts ip op i -unsafeRefined2' i = - let (ret,mr) = eval2 @opts @ip @op i - in fromMaybe (error $ show (prt2Impl (getOptT @opts) ret)) mr +unsafeRefined2' = either (error . show) id . newRefined2 -- | directly load values into 'Refined2' without any checking unsafeRefined2 :: forall opts ip op i - . PP ip i + . Refined2C opts ip op i + => PP ip i -> i -> Refined2 opts ip op i unsafeRefined2 = Refined2 -- | Provides the constraints on Refined2 type Refined2C opts ip op i = - ( OptTC opts + ( OptC opts , P ip i , P op (PP ip i) , PP op (PP ip i) ~ Bool -- the internal value needs to pass the predicate check ) -deriving instance (Show i, Show (PP ip i)) => Show (Refined2 opts ip op i) -deriving instance (Eq i, Eq (PP ip i)) => Eq (Refined2 opts ip op i) -deriving instance (TH.Lift (PP ip i), TH.Lift i) => TH.Lift (Refined2 opts ip op i) +deriving instance ( Refined2C opts ip op i + , Show i + , Show (PP ip i) + ) => Show (Refined2 opts ip op i) +deriving instance ( Refined2C opts ip op i + , Eq i + , Eq (PP ip i) + ) => Eq (Refined2 opts ip op i) +deriving instance ( Refined2C opts ip op i + , Ord i + , Ord (PP ip i) + ) => Ord (Refined2 opts ip op i) +deriving instance ( Refined2C opts ip op i + , TH.Lift (PP ip i) + , TH.Lift i + ) => TH.Lift (Refined2 opts ip op i) +instance ( Refined2C opts ip op i + , NFData i + , NFData (PP ip i) + ) => NFData (Refined2 opts ip op i) where + rnf (Refined2 a b) = rnf2 (a,b) + -- | 'IsString' instance for Refined2 -- -- >>> pureTryTest $ fromString @(Refined2 OL (ReadP Int Id) (Id > 12) String) "523" --- Right (Refined2 {r2In = 523, r2Out = "523"}) +-- Right (Refined2 523 "523") -- -- >>> pureTryTest $ fromString @(Refined2 OL (ReadP Int Id) (Id > 12) String) "2" -- Left () -- -instance ( s ~ String - , Refined2C opts ip op s - , Show (PP ip s) - ) => IsString (Refined2 opts ip op s) where - fromString s = - let (ret,mr) = eval2 @opts @ip @op s - in fromMaybe (error $ "Refined2(fromString):" ++ show (prt2Impl (getOptT @opts) ret)) mr +instance ( i ~ String + , Refined2C opts ip op i + , Show (PP ip i) + ) => IsString (Refined2 opts ip op i) where + fromString i = + case newRefined2 i of + Left e -> error $ "Refined2(fromString):" ++ show e + Right r -> r -- 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\"}" --- [(Refined2 {r2In = 254, r2Out = "fe"},"")] +-- >>> reads @(Refined2 OZ (ReadBase Int 16) (0 <..> 0xff) String) "Refined2 254 \"fe\"" +-- [(Refined2 254 "fe","")] -- --- >>> reads @(Refined2 OZ (ReadBase Int 16 Id) (Between 0 255 Id) String) "Refined2 {r2In = 300, r2Out = \"12c\"}" +-- >>> reads @(Refined2 OZ (ReadBase Int 16) (0 <..> 0xff) String) "Refined2 300 \"12c\"" -- [] -- --- >>> reads @(Refined2 OZ (ReadBase Int 16 Id) (Id < 0) String) "Refined2 {r2In = -1234, r2Out = \"-4d2\"}" --- [(Refined2 {r2In = -1234, r2Out = "-4d2"},"")] +-- >>> reads @(Refined2 OZ (ReadBase Int 16) (Id < 0) String) "Refined2 (-1234) \"-4d2\"" +-- [(Refined2 (-1234) "-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\"}" --- [(Refined2 {r2In = [192,168,0,1], r2Out = "192.168.0.1"},"")] +-- >>> reads @(Refined2 OZ (Map' (ReadP Int Id) (Resplit "\\.")) (GuardBool "len/=4" (Len == 4)) String) "Refined2 [192,168,0,1] \"192.168.0.1\"" +-- [(Refined2 [192,168,0,1] "192.168.0.1","")] -- -instance ( Eq i - , Show i - , Show (PP ip i) - , Refined2C opts ip op i +instance ( Refined2C opts ip op i , Read (PP ip i) , Read i ) => Read (Refined2 opts ip op i) where readPrec = GR.parens (PCR.prec - 11 + 10 (do GR.expectP (RL.Ident "Refined2") - GR.expectP (RL.Punc "{") - fld1 <- readField - "r2In" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc ",") - fld2 <- readField - "r2Out" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc "}") + fld1 <- PCR.step GR.readPrec + fld2 <- PCR.step GR.readPrec + let lr = evalQuick @opts @op fld1 - let lr = getValLRFromTT $ runIdentity $ evalBool (Proxy @op) (getOptT @opts) fld1 case lr of Left {} -> fail "" Right True -> pure (Refined2 fld1 fld2) Right False -> fail "" - )) + ) + ) readList = GR.readListDefault readListPrec = GR.readListPrecDefault -- | '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) @(0 <..> 0xff) 254 "fe") -- "\"fe\"" -- -- >>> A.encode (unsafeRefined2 @OZ @Id @'True @Int 123 123) -- "123" -- -instance ToJSON i => ToJSON (Refined2 opts ip op i) where +instance ( Refined2C opts ip op i + , ToJSON i + ) => ToJSON (Refined2 opts ip op i) where toJSON = toJSON . r2Out -- | 'FromJSON' instance for 'Refined2' -- -- >>> import qualified Data.Aeson as A --- >>> A.eitherDecode' @(Refined2 OZ (ReadBase Int 16 Id) (Id > 10 && Id < 256) String) "\"00fe\"" --- Right (Refined2 {r2In = 254, r2Out = "00fe"}) +-- >>> A.eitherDecode' @(Refined2 OZ (ReadBase Int 16) (Id > 10 && Id < 256) String) "\"00fe\"" +-- Right (Refined2 254 "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 > 10 && Id < 256) String) "\"00fe443a\"" -- Error in $: Refined2:Step 2. False Boolean Check(op) | {True && False | (16663610 < 256)} --- <BLANKLINE> -- *** Step 1. Success Initial Conversion(ip) (16663610) *** --- <BLANKLINE> -- P ReadBase(Int,16) 16663610 -- | -- `- P Id "00fe443a" --- <BLANKLINE> -- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> -- False True && False | (16663610 < 256) -- | -- +- True 16663610 > 10 @@ -283,24 +249,21 @@ -- +- P Id 16663610 -- | -- `- P '256 --- <BLANKLINE> -- -instance ( Show i +instance ( Refined2C opts ip op i , Show (PP ip i) - , Refined2C opts ip op i , FromJSON i ) => FromJSON (Refined2 opts ip op i) where parseJSON z = do i <- parseJSON @i z - let (ret,mr) = eval2 @opts @ip @op i - case mr of - Nothing -> fail $ "Refined2:" ++ show (prt2Impl (getOptT @opts) ret) - Just r -> return r + case newRefined2 i of + Left e -> fail $ "Refined2:" ++ show e + Right r -> return r -- | '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 OAN (ToEnum Day) (L2 (ToWeekDate Id) == "Tuesday") Int))) -- >>> all (\x -> let y = toEnum @Day (r2Out x) in view _3 (toWeekDate y) == 2 && r2In x == y) xs -- True -- @@ -312,7 +275,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 @OAN @(ToEnum Day) @(UnMkDay Id >> Snd == 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 @@ -320,6 +283,7 @@ genRefined2 :: forall opts ip op i . ( Refined2C opts ip op i + , HasCallStack , Show (PP ip i) ) => Gen i @@ -331,24 +295,24 @@ genRefined2P :: forall opts ip op i . ( Refined2C opts ip op i + , HasCallStack , Show (PP ip i) ) => Proxy '(opts,ip,op,i) -> Gen i -> Gen (Refined2 opts ip op i) genRefined2P _ g = - let o = getOptT @opts + let o = getOpt @opts f !cnt = do - mi <- suchThatMaybe g (isJust . snd . eval2 @opts @ip @op) + mi <- suchThatMaybe g (isJust . snd . runIdentity . eval2M @opts @ip @op) case mi of Nothing -> if cnt >= oRecursion o then error $ setOtherEffects o ("genRefined2P recursion exceeded(" ++ show (oRecursion o) ++ ")") else f (cnt+1) - Just i -> do - let lr = newRefined2 @opts @ip @op i - case lr of - Left e -> error $ "conversion failed: programming error failed!! " ++ e + Just i -> + case newRefined2 i of + Left e -> errorInProgram $ "conversion failed:" ++ show e Right r -> pure r in f 0 @@ -360,19 +324,15 @@ -- >>> 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"} +-- Refined2 2019-04-23 "2019-04-23" -- -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) -- Refined2:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} --- <BLANKLINE> -- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** --- <BLANKLINE> -- P ReadP Day 2019-04-23 -- | -- `- P Id "2019-04-23" --- <BLANKLINE> -- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> -- False 2019-05-30 <= 2019-04-23 -- | -- +- P Id 2019-04-23 @@ -384,233 +344,118 @@ -- `- P ReadP Day 2019-06-01 -- | -- `- P '"2019-06-01" --- <BLANKLINE> -- -instance ( Show i +instance ( Refined2C opts ip op i , Show (PP ip i) - , Refined2C opts ip op i , Binary i ) => Binary (Refined2 opts ip op i) where get = do i <- B.get @i - let (ret,mr) = eval2 @opts @ip @op i - case mr of - Nothing -> fail $ "Refined2:" ++ show (prt2Impl (getOptT @opts) ret) - Just r -> return r + case newRefined2 i of + Left e -> fail $ "Refined2:" ++ show e + Right r -> return r put (Refined2 _ r) = B.put @i r -- | 'Hashable' instance for 'Refined2' -instance (Refined2C opts ip op i - , Hashable i - ) => Hashable (Refined2 opts ip op i) where +instance ( Refined2C opts ip op i + , Hashable i + ) => Hashable (Refined2 opts ip op i) where hashWithSalt s (Refined2 _ b) = s + hash b --- | same as 'withRefined2T' for IO -withRefined2TIO :: forall opts ip op i m b - . ( MonadIO m - , Refined2C opts ip op i - , Show (PP ip i) - ) - => i - -> (Refined2 opts ip op i -> RefinedT m b) - -> RefinedT m b -withRefined2TIO = (>>=) . newRefined2TIO @opts @ip @op @i +-- | An ADT that summarises the results of evaluating Refined2 representing all possible states +data RResults2 a = + RF !String !(Tree PE) -- fails initial conversion + | RTF !a !(Tree PE) !String !(Tree PE) -- op fails + | RTFalse !a !(Tree PE) !(Tree PE) -- op false + | RTTrue !a !(Tree PE) !(Tree PE) -- op true + deriving Show --- | create a 'Refined2' value using a continuation --- --- This first example reads a hex string and makes sure it is between 100 and 200 and then --- 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) --- 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) --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) (41864) *** --- <BLANKLINE> --- P ReadBase(Int,16) 41864 --- | --- `- P Id "a388" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False 41864 <= 200 --- | --- +- P Id 41864 --- | --- +- P '100 --- | --- `- P '200 --- <BLANKLINE> --- failure msg[Step 2. False Boolean Check(op) | {41864 <= 200}] --- -withRefined2T :: forall opts ip op i m b - . ( Monad m +newRefined2' :: forall opts ip op i m + . ( MonadEval m , Refined2C opts ip op i , Show (PP ip i) ) => i - -> (Refined2 opts ip op i -> RefinedT m b) - -> RefinedT m b -withRefined2T = (>>=) . newRefined2TP (Proxy @'(opts,ip,op,i)) + -> m (Either Msg2 (Refined2 opts ip op i)) +newRefined2' = newRefined2P' Proxy -withRefined2TP :: forall opts ip op i b proxy m - . ( Monad m +-- | same as 'newRefined2P' but runs in IO +newRefined2P' :: forall opts ip op i proxy m + . ( MonadEval m , Refined2C opts ip op i , Show (PP ip i) ) => proxy '(opts,ip,op,i) -> i - -> (Refined2 opts ip op i -> RefinedT m b) - -> RefinedT m b -withRefined2TP p = (>>=) . newRefined2TP p + -> m (Either Msg2 (Refined2 opts ip op i)) +newRefined2P' _ i = do + (ret,mr) <- eval2M i + return $ maybe (Left $ prt2Impl (getOpt @opts) ret) Right mr -- | pure version for extracting Refined2 -- --- >>> newRefined2 @OL @Id @'True 22 --- Right (Refined2 {r2In = 22, r2Out = 22}) +-- >>> newRefined2 @OZ @(ReadBase Int 16) @(Lt 255) "00fe" +-- Right (Refined2 254 "00fe") -- --- >>> 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 @OZ @(ReadBase Int 16) @(GuardBool (PrintF "0x%X is too large" Id) (Lt 253)) "00fe" +-- Left Step 2. Failed Boolean Check(op) | 0xFE is too large -- --- >>> 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 @OZ @(ReadBase Int 16) @(Lt 255) "00fg" +-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16 -- -newRefined2 :: forall opts ip op i - . ( Refined2C opts ip op i - , Show (PP ip i) - ) => i - -> Either String (Refined2 opts ip op i) -newRefined2 = newRefined2P Proxy - -newRefined2P :: forall opts ip op i proxy - . ( Refined2C opts ip op i - , Show (PP ip i) - ) => proxy '(opts,ip,op,i) - -> i - -> Either String (Refined2 opts ip op i) -newRefined2P _ x = - let (lr,xs) = runIdentity $ unRavelT $ newRefined2T @opts @ip @op x - in left (\e -> e ++ (if all null xs then "" else "\n" ++ unlines xs)) lr - --- | create a wrapped 'Refined2' type +-- >>> newRefined2 @OL @(Map' (ReadP Int Id) (Resplit "\\.")) @(Msg "length invalid:" (Len == 4)) "198.162.3.1.5" +-- Left Step 2. False Boolean Check(op) | {length invalid: 5 == 4} -- --- >>> prtRefinedTIO $ newRefined2T @OL @(MkDayExtra Id >> 'Just Id) @(Thd Id == 5) (2019,11,1) --- Refined2 {r2In = (2019-11-01,44,5), r2Out = (2019,11,1)} +-- >>> newRefined2 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) "198.162.3.1.5" +-- Left Step 2. Failed Boolean Check(op) | found length=5 -- --- >>> prtRefinedTIO $ newRefined2T @OL @(MkDayExtra Id >> 'Just Id) @(Thd Id == 5) (2019,11,2) --- failure msg[Step 2. False Boolean Check(op) | {6 == 5}] +-- >>> newRefined2 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) "198.162.3.1" +-- Right (Refined2 [198,162,3,1] "198.162.3.1") -- --- >>> 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}] +-- >>> :m + Data.Time.Calendar.WeekDate +-- >>> newRefined2 @OZ @(MkDayExtra Id >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) (2019,10,13) +-- Right (Refined2 (2019-10-13,41,7) (2019,10,13)) -- --- >>> prtRefinedTIO $ newRefined2TIO @OL @(Hide (Rescan "(\\d+)" Id >> ConcatMap (Snd Id) Id) >> Map (ReadP Int Id) Id) @(Len > 0 && All (0 <..> 0xff) Id) "|23|99|255|254.911." --- failure msg[Step 2. False Boolean Check(op) | {True && False | (All(5) i=4 (911 <= 255))}] +-- >>> newRefined2 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd == 7)) (2019,10,12) +-- Left Step 2. False Boolean Check(op) | {expected a Sunday: 6 == 7} -- -newRefined2T :: forall opts ip op i m - . ( Refined2C opts ip op i - , Monad m - , Show (PP ip i) - ) => i - -> RefinedT m (Refined2 opts ip op i) -newRefined2T = newRefined2TImpl (return . runIdentity) - --- | create a wrapped 'Refined2' type with an explicit proxy -newRefined2TP :: forall opts ip op i proxy m - . ( Refined2C opts ip op i - , Monad m - , Show (PP ip i) - ) => proxy '(opts,ip,op,i) - -> i - -> RefinedT m (Refined2 opts ip op i) -newRefined2TP _ = newRefined2TImpl (return . runIdentity) - --- | create a wrapped 'Refined2' type in IO -newRefined2TIO :: forall opts ip op i m - . ( Refined2C opts ip op i - , MonadIO m - , Show (PP ip i) - ) => i - -> RefinedT m (Refined2 opts ip op i) -newRefined2TIO = newRefined2TImpl @IO @m liftIO - -newRefined2TImpl :: forall n m opts ip op i - . ( Refined2C opts ip op i - , Monad m - , MonadEval n - , Show (PP ip i) - ) => (forall x . n x -> RefinedT m x) - -> i - -> RefinedT m (Refined2 opts ip op i) -newRefined2TImpl f i = do - (ret,mr) <- f $ eval2M i - let m2 = prt2Impl (getOptT @opts) ret - tell [m2Long m2] - case mr of - Nothing -> throwError $ m2Desc m2 <> " | " <> m2Short m2 - Just r -> return r - --- | An ADT that summarises the results of evaluating Refined2 representing all possible states -data RResults2 a = - RF !String !(Tree PE) -- fails initial conversion - | RTF !a !(Tree PE) !String !(Tree PE) -- op fails - | RTFalse !a !(Tree PE) !(Tree PE) -- op false - | RTTrue !a !(Tree PE) !(Tree PE) -- op true - deriving Show - --- | same as 'prtEval2PIO' without a proxy for used with TypeApplications -prtEval2IO :: forall opts ip op i - . ( Refined2C opts ip op i - , Show (PP ip i) - ) => i - -> IO (Either String (Refined2 opts ip op i)) -prtEval2IO = prtEval2PIO Proxy - --- | same as 'prtEval2P' but runs in IO -prtEval2PIO :: forall opts ip op i proxy - . ( Refined2C opts ip op i - , Show (PP ip i) - ) => proxy '(opts,ip,op,i) - -> i - -> IO (Either String (Refined2 opts ip op i)) -prtEval2PIO _ i = do - x <- eval2M @opts @ip @op i - prt2IO @opts x - -prtEval2 :: forall opts ip op i +-- >>> newRefined2 @OZ @(MkDayExtra' Fst Snd Thd >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday +-- +-- >>> newRefined2 @OL @Id @'True 22 +-- Right (Refined2 22 22) +-- +-- >>> newRefined2 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust ToDay)) "2020-05-04 12:13:14Z" +-- Right (Refined2 2020-05-04 12:13:14 UTC "2020-05-04 12:13:14Z") +-- +-- >>> newRefined2 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust ToDay)) "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 . ( Refined2C opts ip op i , Show (PP ip i) ) => i -> Either Msg2 (Refined2 opts ip op i) -prtEval2 = prtEval2P Proxy +newRefined2 = newRefined2P Proxy -prtEval2P :: forall opts ip op i +newRefined2P :: forall opts ip op i . ( Refined2C opts ip op i , Show (PP ip i) ) => Proxy '(opts,ip,op,i) -> i -> Either Msg2 (Refined2 opts ip op i) -prtEval2P _ i = - let (ret,mr) = eval2 i - in maybe (Left $ prt2Impl (getOptT @opts) ret) Right mr +newRefined2P _ i = + let (ret,mr) = runIdentity $ eval2M i + in maybe (Left $ prt2Impl (getOpt @opts) ret) Right mr -eval2P :: forall opts ip op i +eval2P :: forall opts ip op i m . ( Refined2C opts ip op i + , MonadEval m ) => Proxy '(opts,ip,op,i) -> i - -> (RResults2 (PP ip i), Maybe (Refined2 opts ip op i)) -eval2P _ = runIdentity . eval2M - -eval2 :: forall opts ip op i - . ( Refined2C opts ip op i - ) - => i - -> (RResults2 (PP ip i), Maybe (Refined2 opts ip op i)) -eval2 = runIdentity . eval2M + -> m (RResults2 (PP ip i), Maybe (Refined2 opts ip op i)) +eval2P _ = eval2M eval2M :: forall opts ip op i m . ( MonadEval m @@ -619,7 +464,7 @@ => i -> m (RResults2 (PP ip i), Maybe (Refined2 opts ip op i)) eval2M i = do - let o = getOptT @opts + let o = getOpt @opts ll <- eval (Proxy @ip) o i case getValAndPE ll of (Right a, t1) -> do @@ -630,79 +475,76 @@ (Left e,t2) -> (RTF a t1 e t2, Nothing) (Left e,t1) -> pure (RF e t1, Nothing) -prt2IO :: forall opts a r . (OptTC opts, Show a) => (RResults2 a, Maybe r) -> IO (Either String r) -prt2IO (ret,mr) = do - let m2 = prt2Impl o ret - o = getOptT @opts - unless (hasNoTree o) $ putStrLn $ m2Long m2 - return $ maybe (Left (m2Desc m2 <> " | " <> m2Short m2)) Right mr - data Msg2 = Msg2 { m2Desc :: !String , m2Short :: !String , m2Long :: !String + , m2ValP :: !ValP } deriving Eq instance Show Msg2 where - show (Msg2 a b c) = a <> " | " <> b <> (if null c then "" else "\n" <> c) + show (Msg2 a b c _d) = a <> nullIf " | " b <> nullIf "\n" c prt2Impl :: forall a . Show a => POpts -> RResults2 a -> Msg2 prt2Impl opts v = - let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - 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 + let outmsg msg = "*** " <> formatOMsg opts " " <> msg <> " ***\n" + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) (" ++ showL opts a ++ ")") + mkMsg2 m n r bp | hasNoTree opts = Msg2 m n "" bp + | otherwise = Msg2 m n r bp in case v of RF e t1 -> - let (m,n) = ("Step 1. Initial Conversion(ip) Failed", e) + let (m,n) = ("Step 1. " <> colorValP Short opts (FailP e) <> " Initial Conversion(ip)", e) r = outmsg m <> prtTreePure opts t1 - in mkMsg2 m n r + in mkMsg2 m n r (t1 ^. root . peValP) RTF a t1 e t2 -> - let (m,n) = ("Step 2. Failed Boolean Check(op)", e) + let (m,n) = ("Step 2. " <> colorValP Short opts (FailP e) <> " Boolean Check(op)", e) r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg m <> prtTreePure opts t2 - in mkMsg2 m n r + in mkMsg2 m n r (t2 ^. root . peValP) RTFalse a t1 t2 -> - let (m,n) = ("Step 2. False Boolean Check(op)", z) - z = let w = t2 ^. root . pString + let (m,n) = ("Step 2. " <> colorValP Short opts FalseP <> " Boolean Check(op)", z) + z = let w = t2 ^. root . peString in if all isSpace w then "FalseP" else "{" <> w <> "}" r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg m <> prtTreePure opts t2 - in mkMsg2 m n r + in mkMsg2 m n r FalseP RTTrue a t1 t2 -> let (m,n) = ("Step 2. True Boolean Check(op)", "") r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg m <> prtTreePure opts t2 - in mkMsg2 m n r + in mkMsg2 m n r (t2 ^. root . peValP) --- | creates a 4-tuple proxy (see 'withRefined2TP' 'newRefined2TP' 'eval2P' 'prtEval2P') +-- | creates a 4-tuple proxy (see 'eval2P' 'newRefined2P') -- -- use type application to set the 4-tuple or set the individual parameters directly -- -- 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"}) +-- Right (Refined2 24 "24") -- -- skip the 4-tuple and set each parameter individually using type application -- -- >>> eg2 = mkProxy2 @_ @OL @(ReadP Int Id) @(Gt 10) -- >>> newRefined2P eg2 "24" --- Right (Refined2 {r2In = 24, r2Out = "24"}) +-- Right (Refined2 24 "24") -- mkProxy2 :: forall z opts ip op i - . ( z ~ '(opts,ip,op,i) - ) => Proxy '(opts,ip,op,i) + . z ~ '(opts,ip,op,i) + => Proxy '(opts,ip,op,i) mkProxy2 = Proxy -- | same as 'mkProxy2' but checks to make sure the proxy is consistent with the 'Refined2C' constraint @@ -715,9 +557,3 @@ -- | type family for converting from a 4-tuple '(opts,ip,op,i) to a 'Refined2' type type family MakeR2 p where MakeR2 '(opts,ip,op,i) = Refined2 opts ip op i - -type family ReplaceOptT2 (o :: OptT) t where - ReplaceOptT2 o (Refined2 _ ip op i) = Refined2 o ip op i - -type family AppendOptT2 (o :: OptT) t where - AppendOptT2 o (Refined2 o' ip op i) = Refined2 (o' ':# o) ip op i
src/Predicate/Refined3.hs view
@@ -1,13 +1,10 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} +-- arbitrary and hash use the internal value! +-- binary and json use the external value {-# OPTIONS -Wno-redundant-constraints #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} @@ -30,41 +27,28 @@ -- @ -- similar to 'Predicate.Refined2.Refined2' but also provides: -- * quickCheck methods --- * ability to combine refinement types -- * a canonical output value using the \'fmt\' parameter -- @ -- module Predicate.Refined3 ( -- ** Refined3 - Refined3(r3In,r3Out) + Refined3 + , r3In + , r3Out , Refined3C -- ** display results - , prtEval3 - , prtEval3P - , prtEval3IO - , prtEval3PIO - , prt3IO - , prt3Impl , Msg3 (..) , RResults3 (..) -- ** evaluation methods - , eval3 , eval3P , eval3M , newRefined3 + , newRefined3' , newRefined3P - - -- ** create a wrapped Refined3 value - , newRefined3T - , newRefined3TP - , newRefined3TPIO - , newRefined3TIO - , withRefined3T - , withRefined3TIO - , withRefined3TP + , newRefined3P' -- ** proxy methods , mkProxy3 @@ -76,33 +60,17 @@ , unsafeRefined3 , unsafeRefined3' - -- ** combine Refined3 values - , convertRefined3TP - , rapply3 - , rapply3P - -- ** QuickCheck methods , genRefined3 , genRefined3P - -- ** emulate Refined3 using Refined - , RefinedEmulate - , eval3PX - , eval3X - - , type ReplaceOptT3 - , type AppendOptT3 - ) where -import Predicate.Refined import Predicate.Core +import Predicate.Misc import Predicate.Util import Data.Functor.Identity (Identity(..)) -import Data.Tree -import Data.Proxy -import Control.Arrow (left) -import Control.Monad.Except -import Control.Monad.Writer (tell) +import Data.Tree (Tree(..)) +import Data.Proxy (Proxy(..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import qualified Language.Haskell.TH.Syntax as TH import Test.QuickCheck @@ -114,10 +82,10 @@ import Control.Lens ((^.)) import Data.Tree.Lens (root) import Data.Char (isSpace) -import Data.String +import Data.String (IsString(..)) import Data.Hashable (Hashable(..)) -import GHC.Stack - +import GHC.Stack (HasCallStack) +import Control.DeepSeq (rnf, rnf2, NFData) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications @@ -136,7 +104,7 @@ -- -- * @PP fmt (PP ip i)@ should be valid as input for Refined3 -- --- Setting @ip@ to @Id@ and @fmt@ to @Id@ is equivalent to 'Refined.Refined': see 'RefinedEmulate' +-- Setting @ip@ to @Id@ and @fmt@ to @Id@ is equivalent to 'Refined.Refined' -- -- Setting the input type @i@ to 'GHC.Base.String' resembles the corresponding Read/Show instances but with an additional predicate on the read value -- @@ -146,71 +114,39 @@ -- -- 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" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) --- --- >>> 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" --- 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" --- 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" --- 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" --- 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) --- 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) --- 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) --- 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) --- >>> newRefined3P (Proxy @(T4 _)) (2019,10,12) --- Left "Step 2. Failed Boolean Check(op) | expected a Sunday" --- --- >>> newRefined3P (Proxy @(T4 _)) (2019,10,13) --- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) --- -data Refined3 (opts :: OptT) ip op fmt i = Refined3 { r3In :: !(PP ip i), r3Out :: !(PP fmt (PP ip i)) } +data Refined3 (opts :: Opt) ip op fmt i = Refined3 !(PP ip i) !i -type role Refined3 nominal nominal nominal nominal nominal +type role Refined3 phantom nominal nominal nominal nominal +r3In :: Refined3 opts ip op fmt i -> PP ip i +r3In (Refined3 ppi _) = ppi + +r3Out :: Refined3 opts ip op fmt i -> i +r3Out (Refined3 _ i) = i + + -- | directly load values into 'Refined3'. It still checks to see that those values are valid unsafeRefined3' :: forall opts ip op fmt i . ( HasCallStack - , Show i , Show (PP ip i) - , Refined3C opts ip op fmt i) - => i - -> Refined3 opts ip op fmt i -unsafeRefined3' i = - let (ret,mr) = eval3 @opts @ip @op @fmt i - in case mr of - Nothing -> error $ show (prt3Impl (getOptT @opts) ret) - Just r -> r + , Refined3C opts ip op fmt i + ) => i + -> Refined3 opts ip op fmt i +unsafeRefined3' = either (error . show) id . newRefined3 -- | directly load values into 'Refined3' without any checking unsafeRefined3 :: forall opts ip op fmt i - . PP ip i - -> PP fmt (PP ip i) + . Refined3C opts ip op fmt i + => PP ip i + -> i -> Refined3 opts ip op fmt i unsafeRefined3 = Refined3 -- | Provides the constraints on Refined3 type Refined3C opts ip op fmt i = - ( OptTC opts + ( OptC opts , P ip i , P op (PP ip i) , PP op (PP ip i) ~ Bool -- the internal value needs to pass the predicate check @@ -218,109 +154,111 @@ , PP fmt (PP ip i) ~ i -- the output type must match the original input type ) -deriving instance ( Show i +deriving instance ( Refined3C opts ip op fmt i , Show (PP ip i) - , Show (PP fmt (PP ip i)) + , Show i ) => Show (Refined3 opts ip op fmt i) -deriving instance ( Eq i +deriving instance ( Refined3C opts ip op fmt i , Eq (PP ip i) - , Eq (PP fmt (PP ip i)) + , Eq i ) => Eq (Refined3 opts ip op fmt i) -deriving instance ( TH.Lift (PP ip i) - , TH.Lift (PP fmt (PP ip i)) +deriving instance ( Refined3C opts ip op fmt i + , Ord (PP ip i) + , Ord i + ) => Ord (Refined3 opts ip op fmt i) +deriving instance ( Refined3C opts ip op fmt i + , TH.Lift (PP ip i) + , TH.Lift i ) => TH.Lift (Refined3 opts ip op fmt i) +instance ( Refined3C opts ip op fmt i + , NFData i + , NFData (PP ip i) + ) => NFData (Refined3 opts ip op fmt i) where + rnf (Refined3 a b) = rnf2 (a,b) + -- | 'IsString' instance for Refined3 -- -- >>> pureTryTest $ fromString @(Refined3 OL (ReadP Int Id) (Id > 12) (ShowP Id) String) "523" --- Right (Refined3 {r3In = 523, r3Out = "523"}) +-- Right (Refined3 523 "523") -- -- >>> 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)) - => IsString (Refined3 opts ip op fmt String) where +instance ( Refined3C opts ip op fmt String + , Show (PP ip String) + ) => IsString (Refined3 opts ip op fmt String) where fromString s = - let (ret,mr) = eval3 @opts @ip @op @fmt s - in case mr of - Nothing -> error $ "Refined3(fromString):" ++ show (prt3Impl (getOptT @opts) ret) - Just r -> r + case newRefined3 s of + Left e -> error $ "Refined3(fromString):" ++ show e + Right r -> r -- 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\"}" --- [(Refined3 {r3In = 254, r3Out = "fe"},"")] +-- >>> reads @(Refined3 OZ (ReadBase Int 16) (0 <..> 0xff) (ShowBase 16) String) "Refined3 254 \"fe\"" +-- [(Refined3 254 "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) (0 <..> 0xff) (ShowBase 16) String) "Refined3 300 \"12c\"" -- [] -- --- >>> 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 (ReadBase Int 16) (Id < 0) (ShowBase 16) String) "Refined3 (-1234) \"-4d2\"" +-- [(Refined3 (-1234) "-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\"}" --- [(Refined3 {r3In = [192,168,0,1], r3Out = "192.168.0.1"},"")] +-- >>> reads @(Refined3 OZ (Map' (ReadP Int Id) (Resplit "\\.")) (GuardBool "len/=4" (Len == 4)) (PrintL 4 "%d.%d.%d.%d" Id) String) "Refined3 [192,168,0,1] \"192.168.0.1\"" +-- [(Refined3 [192,168,0,1] "192.168.0.1","")] -- instance ( Eq i - , Show i - , Show (PP ip i) , Refined3C opts ip op fmt i , Read (PP ip i) - , Read (PP fmt (PP ip i)) + , Read i ) => Read (Refined3 opts ip op fmt i) where readPrec = GR.parens (PCR.prec - 11 + 10 (do GR.expectP (RL.Ident "Refined3") - GR.expectP (RL.Punc "{") - fld1 <- readField - "r3In" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc ",") - fld2 <- readField - "r3Out" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc "}") - + fld1 <- PCR.step GR.readPrec + fld2 <- PCR.step GR.readPrec let (_ret,mr) = runIdentity $ eval3MSkip @opts @ip @op @fmt fld1 case mr of Nothing -> fail "" Just (Refined3 _r1 r2) | r2 == fld2 -> pure (Refined3 fld1 fld2) | otherwise -> fail "" -- cant display a decent failure message - )) + ) + ) readList = GR.readListDefault readListPrec = GR.readListPrecDefault -- | '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) @(0 <..> 0xff) @(ShowBase 16) "fe") -- "\"fe\"" -- --- >>> A.encode (unsafeRefined3 @OZ @Id @'True @Id 123 123) +-- >>> A.encode (unsafeRefined3' @OZ @Id @'True @Id 123) -- "123" -- -instance ToJSON (PP fmt (PP ip i)) => ToJSON (Refined3 opts ip op fmt i) where +instance ( Refined3C opts ip op fmt i + , ToJSON i + ) => ToJSON (Refined3 opts ip op fmt i) where toJSON = toJSON . r3Out -- | '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\"" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- >>> A.eitherDecode' @(Refined3 OZ (ReadBase Int 16) (Id > 10 && Id < 256) (ShowBase 16) String) "\"00fe\"" +-- Right (Refined3 254 "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 > 10 && Id < 256) (ShowBase 16) String) "\"00fe443a\"" -- Error in $: Refined3:Step 2. False Boolean Check(op) | {True && False | (16663610 < 256)} --- <BLANKLINE> -- *** Step 1. Success Initial Conversion(ip) (16663610) *** --- <BLANKLINE> -- P ReadBase(Int,16) 16663610 -- | -- `- P Id "00fe443a" --- <BLANKLINE> -- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> -- False True && False | (16663610 < 256) -- | -- +- True 16663610 > 10 @@ -334,23 +272,20 @@ -- +- P Id 16663610 -- | -- `- P '256 --- <BLANKLINE> -- -instance (Show (PP fmt (PP ip i)) - , Show (PP ip i) - , Refined3C opts ip op fmt i - , FromJSON i - ) => FromJSON (Refined3 opts ip op fmt i) where +instance ( Refined3C opts ip op fmt i + , Show (PP ip i) + , FromJSON i + ) => FromJSON (Refined3 opts ip op fmt i) where parseJSON z = do i <- parseJSON @i z - let (ret,mr) = eval3 @opts @ip @op @fmt i - case mr of - Nothing -> fail $ "Refined3:" ++ show (prt3Impl (getOptT @opts) ret) - Just r -> return r + case newRefined3 i of + Left e -> fail $ "Refined3:" ++ show e + Right r -> return r -- | '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 OAN (ReadP Int Id) (1 <..> 120 && Even) (ShowP Id) String))) -- >>> all (\x -> let y = r3In x in y /= 0 && r3Out x == show y) xs -- True -- @@ -361,14 +296,16 @@ -- | 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 @OAN @(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 -- genRefined3 :: forall opts ip op fmt i - . Refined3C opts ip op fmt i + . ( Refined3C opts ip op fmt i + , HasCallStack + ) => Gen (PP ip i) -> Gen (Refined3 opts ip op fmt i) genRefined3 = genRefined3P Proxy @@ -376,22 +313,23 @@ -- | create a 'Refined3' generator using a proxy genRefined3P :: forall opts ip op fmt i - . Refined3C opts ip op fmt i + . ( Refined3C opts ip op fmt i + , HasCallStack + ) => Proxy '(opts,ip,op,fmt,i) -> Gen (PP ip i) -> Gen (Refined3 opts ip op fmt i) genRefined3P _ g = - let o = getOptT @opts - f !cnt = do - mppi <- suchThatMaybe g (\a -> getValLRFromTT (runIdentity (eval @_ (Proxy @op) o a)) == Right True) + let f !cnt = do + mppi <- suchThatMaybe g $ \a -> evalQuick @opts @op a == Right True case mppi of Nothing -> - if cnt >= oRecursion o - then error $ setOtherEffects o ("genRefined3P recursion exceeded(" ++ show (oRecursion o) ++ ")") - else f (cnt+1) - Just ppi -> do - let lr = getValLRFromTT (runIdentity (eval @_ (Proxy @fmt) o ppi)) - case lr of + let o = getOpt @opts + in if cnt >= oRecursion o + then error $ setOtherEffects o ("genRefined3P recursion exceeded(" ++ show (oRecursion o) ++ ")") + else f (cnt+1) + Just ppi -> + case evalQuick @opts @fmt ppi of Left e -> error $ "genRefined3P: formatting failed!! " ++ e Right r -> pure $ unsafeRefined3 ppi r in f 0 @@ -401,23 +339,19 @@ -- >>> 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"} +-- Refined3 2019-04-23 "2019-04-23" -- -- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) -- Refined3:Step 2. False Boolean Check(op) | {2019-05-30 <= 2019-04-23} --- <BLANKLINE> -- *** Step 1. Success Initial Conversion(ip) (2019-04-23) *** --- <BLANKLINE> -- P ReadP Day 2019-04-23 -- | -- `- P Id "2019-04-23" --- <BLANKLINE> -- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> -- False 2019-05-30 <= 2019-04-23 -- | -- +- P Id 2019-04-23 @@ -429,42 +363,39 @@ -- `- P ReadP Day 2019-06-01 -- | -- `- P '"2019-06-01" --- <BLANKLINE> -- -instance ( Show (PP fmt (PP ip i)) +instance ( Refined3C opts ip op fmt i , Show (PP ip i) - , Refined3C opts ip op fmt i , Binary i ) => Binary (Refined3 opts ip op fmt i) where get = do i <- B.get @i - let (ret,mr) = eval3 @opts @ip @op @fmt i - case mr of - Nothing -> fail $ "Refined3:" ++ show (prt3Impl (getOptT @opts) ret) - Just r -> return r + case newRefined3 i of + Left e -> fail $ "Refined3:" ++ show e + Right r -> return r put (Refined3 _ r) = B.put @i r -- | 'Hashable' instance for 'Refined3' -instance (Refined3C opts ip op fmt i - , Hashable (PP ip i) - ) => Hashable (Refined3 opts ip op fmt i) where +instance ( Refined3C opts ip op fmt i + , Hashable (PP ip i) + ) => Hashable (Refined3 opts ip op fmt i) where hashWithSalt s (Refined3 a _) = s + hash a --- | creates a 5-tuple proxy (see 'withRefined3TP' 'newRefined3TP' 'eval3P' 'prtEval3P') +-- | creates a 5-tuple proxy (see 'eval3P' 'newRefined3P') -- -- use type application to set the 5-tuple or set the individual parameters directly -- -- 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"}) +-- Right (Refined3 24 "24") -- -- skip the 5-tuple and set each parameter individually using type application -- -- >>> eg2 = mkProxy3 @_ @OL @(ReadP Int Id) @(Gt 10) @(ShowP Id) -- >>> newRefined3P eg2 "24" --- Right (Refined3 {r3In = 24, r3Out = "24"}) +-- Right (Refined3 24 "24") -- mkProxy3 :: forall z opts ip op fmt i @@ -473,7 +404,10 @@ mkProxy3 = Proxy -- | same as 'mkProxy3' but checks to make sure the proxy is consistent with the 'Refined3C' constraint -mkProxy3' :: forall z opts ip op fmt i . (z ~ '(opts,ip,op,fmt,i), Refined3C 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) + , Refined3C opts ip op fmt i + ) => Proxy '(opts,ip,op,fmt,i) mkProxy3' = Proxy -- | type family for converting from a 5-tuple '(opts,ip,op,fmt,i) to a 'Refined3' type @@ -483,345 +417,133 @@ type family MakeR3' opts p where MakeR3' opts '(ip,op,fmt,i) = Refined3 opts ip op fmt i -withRefined3TIO :: forall opts ip op fmt i m b - . ( MonadIO m - , Refined3C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => i - -> (Refined3 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3TIO = (>>=) . newRefined3TPIO (Proxy @'(opts,ip,op,fmt,i)) +-- | An ADT that summarises the results of evaluating Refined3 representing all possible states +data RResults3 a = + RF !String !(Tree PE) -- Left e + | RTF !a !(Tree PE) !String !(Tree PE) -- Right a + Left e + | RTFalse !a !(Tree PE) !(Tree PE) -- Right a + Right False + | RTTrueF !a !(Tree PE) !(Tree PE) !String !(Tree PE) -- Right a + Right True + Left e + | RTTrueT !a !(Tree PE) !(Tree PE) !(Tree PE) -- Right a + Right True + Right b + deriving Show --- | create a 'Refined3' value using a continuation --- --- This first example reads a hex string and makes sure it is between 100 and 200 and then --- reads a binary string and adds the values together --- --- >>> :set -XPolyKinds --- >>> :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) --- 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) --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) (41864) *** --- <BLANKLINE> --- P ReadBase(Int,16) 41864 --- | --- `- P Id "a388" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False 41864 <= 200 --- | --- +- P Id 41864 --- | --- +- P '100 --- | --- `- P '200 --- <BLANKLINE> --- failure msg[Step 2. False Boolean Check(op) | {41864 <= 200}] --- -withRefined3T :: forall opts ip op fmt i m b - . ( Monad m +-- | same as 'newRefined3P'' but passes in the proxy +newRefined3' :: forall opts ip op fmt i m + . ( MonadEval m , Refined3C opts ip op fmt i , Show (PP ip i) - , Show i ) => i - -> (Refined3 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3T = (>>=) . newRefined3TP (Proxy @'(opts,ip,op,fmt,i)) + -> m (Either Msg3 (Refined3 opts ip op fmt i)) +newRefined3' = newRefined3P' Proxy -withRefined3TP :: forall opts ip op fmt i b proxy m - . ( Monad m +-- | same as 'newRefined3P' but runs in IO +newRefined3P' :: forall opts ip op fmt i proxy m + . ( MonadEval m , Refined3C opts ip op fmt i , Show (PP ip i) - , Show i ) => proxy '(opts,ip,op,fmt,i) -> i - -> (Refined3 opts ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3TP p = (>>=) . newRefined3TP p + -> m (Either Msg3 (Refined3 opts ip op fmt i)) +newRefined3P' _ i = do + (ret,mr) <- eval3M i + return $ maybe (Left $ prt3Impl (getOpt @opts) ret) Right mr --- | pure version for extracting Refined3 +-- | same as 'newRefined3P' but skips the proxy and allows you to set each parameter individually using type application -- --- >>> 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 @OZ @(ReadBase Int 16) @(Lt 255) @(PrintF "%x" Id) "00fe" +-- Right (Refined3 254 "fe") -- --- >>> 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 @OZ @(ReadBase Int 16) @(GuardBool (PrintF "0x%X is too large" Id) (Lt 253)) @(PrintF "%x" Id) "00fe" +-- Left Step 2. Failed Boolean Check(op) | 0xFE is too large -- --- >>> 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 @OZ @(ReadBase Int 16) @(Lt 255) @(PrintF "%x" Id) "00fg" +-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16 -- -newRefined3 :: forall opts ip op fmt i - . ( Refined3C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => i - -> Either String (Refined3 opts ip op fmt i) -newRefined3 = newRefined3P Proxy - -newRefined3P :: forall opts ip op fmt i proxy - . ( Refined3C opts ip op fmt i - , Show (PP ip i) - , Show i - ) - => proxy '(opts,ip,op,fmt,i) - -> i - -> Either String (Refined3 opts ip op fmt i) -newRefined3P _ x = - let (lr,xs) = runIdentity $ unRavelT $ newRefined3T @opts @ip @op @fmt x - in left (\e -> e ++ (if all null xs then "" else "\n" ++ unlines xs)) lr - --- | create a wrapped 'Refined3' type +-- >>> newRefined3 @OL @(Map' (ReadP Int Id) (Resplit "\\.")) @(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} -- --- >>> 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)} +-- >>> newRefined3 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1.5" +-- Left Step 2. Failed Boolean Check(op) | found length=5 -- --- >>> 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}] +-- >>> newRefined3 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "198.162.3.1" +-- Right (Refined3 [198,162,3,1] "198.162.003.001") -- --- >>> 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}] +-- >>> :m + Data.Time.Calendar.WeekDate +-- >>> newRefined3 @OZ @(MkDayExtra Id >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) @(UnMkDay Fst) (2019,10,13) +-- Right (Refined3 (2019-10-13,41,7) (2019,10,13)) -- -newRefined3T :: forall opts ip op fmt i m - . ( Refined3C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i - ) - => i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3T = newRefined3TP (Proxy @'(opts,ip,op,fmt,i)) - --- | create a wrapped 'Refined3' type +-- >>> newRefined3 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd == 7)) @(UnMkDay Fst) (2019,10,12) +-- Left Step 2. False Boolean Check(op) | {expected a Sunday: 6 == 7} -- --- >>> 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)} +-- >>> newRefined3 @OZ @(MkDayExtra' Fst Snd Thd >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) @(UnMkDay Fst) (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday -- --- >>> 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}] +-- >>> newRefined3 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S") @'True @(FormatTimeP "%H:%M:%S") "1:15:7" +-- Right (Refined3 01:15:07 "01:15:07") -- --- >>> 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}] +-- >>> newRefined3 @OL @(ParseTimeP TimeOfDay "%-H:%-M:%-S") @'True @(FormatTimeP "%H:%M:%S") "1:2:x" +-- Left Step 1. Failed Initial Conversion(ip) | ParseTimeP TimeOfDay (%-H:%-M:%-S) failed to parse -- -newRefined3TP :: forall opts ip op fmt i proxy m - . ( Refined3C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i - ) - => proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3TP = newRefined3TPImpl (return . runIdentity) - --- | wrap a Refined3 type using RefinedT and IO +-- >>> newRefined3 @OL @(Rescan "^(\\d{1,2}):(\\d{1,2}):(\\d{1,2})$" >> L2 Head >> Map (ReadP Int Id)) @(All (0 <..> 59) && Len == 3) @(PrintL 3 "%02d:%02d:%02d" Id) "1:2:3" +-- Right (Refined3 [1,2,3] "01:02:03") -- --- >>> prtRefinedTIO $ newRefined3TIO @OL @(Hide (Rescan "(\\d+)" Id >> ConcatMap (Snd Id) Id) >> Map (ReadP Int Id) Id) @(Len > 0 && All (0 <..> 0xff) Id) @(ShowP Id) "|23|99|255|254.911." --- failure msg[Step 2. False Boolean Check(op) | {True && False | (All(5) i=4 (911 <= 255))}] +-- >>> newRefined3 @OL @(Resplit "\\." >> Map (ReadP Int Id)) @(BoolsN "oops" 4 (Between 0 255 Id)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "13.2.1.251" +-- Right (Refined3 [13,2,1,251] "013.002.001.251") -- --- >>> unRavelT $ newRefined3TIO @OL @(Hide (Rescan "(\\d+)" Id >> ConcatMap (Snd Id) Id) >> Map (ReadP Int Id) Id) @(Len > 0 && All (0 <..> 0xff) Id) @(ShowP Id) "|23|99|255|254.911." --- (Left "Step 2. False Boolean Check(op) | {True && False | (All(5) i=4 (911 <= 255))}",[""]) +-- >>> newRefined3 @OZ @(Resplit "\\." >> Map (ReadP Int Id)) @(BoolsN "oops" 4 (Between 0 255 Id)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "13.2.1.259" +-- Left Step 2. Failed Boolean Check(op) | Bool(3) [oops] -- -newRefined3TIO :: forall opts ip op fmt i m - . ( Refined3C opts ip op fmt i - , MonadIO m - , Show (PP ip i) - , Show i) - => i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3TIO = newRefined3TPImpl liftIO Proxy - -newRefined3TPIO :: forall opts ip op fmt i proxy m - . ( Refined3C opts ip op fmt i - , MonadIO m - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3TPIO = newRefined3TPImpl liftIO - -newRefined3TPImpl :: forall n m opts ip op fmt i proxy - . ( Refined3C opts ip op fmt i - , Monad m - , MonadEval n - , Show (PP ip i) - , Show (PP fmt (PP ip i))) - => (forall x . n x -> RefinedT m x) - -> proxy '(opts,ip,op,fmt,i) - -> i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3TPImpl f _ i = do - (ret,mr) <- f $ eval3M i - let m3 = prt3Impl (getOptT @opts) ret - tell [m3Long m3] - case mr of - Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 - Just r -> return r - -newRefined3TPSkipIPImpl :: forall n m opts ip op fmt i proxy - . ( Refined3C opts ip op fmt i - , Monad m - , MonadEval n - , Show (PP ip i) - , Show (PP fmt (PP ip i)) - ) - => (forall x . n x -> RefinedT m x) - -> proxy '(opts,ip,op,fmt,i) - -> PP ip i - -> RefinedT m (Refined3 opts ip op fmt i) -newRefined3TPSkipIPImpl f _ a = do - (ret,mr) <- f $ eval3MSkip a - let m3 = prt3Impl (getOptT @opts) ret - tell [m3Long m3] - case mr of - Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 - Just r -> return r - --- | attempts to cast a wrapped 'Refined3' to another 'Refined3' with different predicates -convertRefined3TP :: forall opts ip op fmt i ip1 op1 fmt1 i1 m . - ( Refined3C opts ip op fmt i - , Refined3C opts ip1 op1 fmt1 i1 - , Monad m - , Show (PP ip i) - , PP ip i ~ PP ip1 i1 - , Show i1) - => Proxy '(opts, ip, op, fmt, i) - -> Proxy '(opts, ip1, op1, fmt1, i1) - -> RefinedT m (Refined3 opts ip op fmt i) - -> RefinedT m (Refined3 opts ip1 op1 fmt1 i1) -convertRefined3TP _ _ ma = do - Refined3 x _ <- ma - -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call - Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) (Proxy @'(opts, ip1, op1, fmt1, i1)) x - return (Refined3 a b) - --- | applies a binary operation to two wrapped 'Refined3' parameters -rapply3 :: forall opts ip op fmt i m . - ( Refined3C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined3 opts ip op fmt i) - -> RefinedT m (Refined3 opts ip op fmt i) - -> RefinedT m (Refined3 opts ip op fmt i) -rapply3 = rapply3P (Proxy @'(opts,ip,op,fmt,i)) - --- prtRefinedTIO $ rapply3P base16 (+) (newRefined3TP Proxy "ff") (newRefined3TP Proxy "22") - --- | same as 'rapply3' but uses a 5-tuple proxy instead -rapply3P :: forall opts ip op fmt i proxy m . - ( Refined3C opts ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined3 opts ip op fmt i) - -> RefinedT m (Refined3 opts ip op fmt i) - -> RefinedT m (Refined3 opts ip op fmt i) -rapply3P p f ma mb = do - let opts = getOptT @opts - tell [setOtherEffects opts "=== a ==="] - Refined3 x _ <- ma - tell [setOtherEffects opts "=== b ==="] - 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 ==="] - newRefined3TPSkipIPImpl (return . runIdentity) p (f x y) - --- | An ADT that summarises the results of evaluating Refined3 representing all possible states -data RResults3 a b = - RF !String !(Tree PE) -- Left e - | RTF !a !(Tree PE) !String !(Tree PE) -- Right a + Left e - | RTFalse !a !(Tree PE) !(Tree PE) -- Right a + Right False - | RTTrueF !a !(Tree PE) !(Tree PE) !String !(Tree PE) -- Right a + Right True + Left e - | RTTrueT !a !(Tree PE) !(Tree PE) !b !(Tree PE) -- Right a + Right True + Right b - deriving Show - --- | same as 'prtEval3PIO' but passes in the proxy -prtEval3IO :: forall opts ip op fmt i - . ( Refined3C opts ip op fmt i - , Show (PP ip i) - , Show i) - => i - -> IO (Either String (Refined3 opts ip op fmt i)) -prtEval3IO = prtEval3PIO Proxy - --- | same as 'prtEval3P' but runs in IO -prtEval3PIO :: forall opts ip op fmt i proxy - . ( Refined3C opts ip op fmt i - , Show (PP ip i) - , Show i) - => proxy '(opts,ip,op,fmt,i) - -> i - -> IO (Either String (Refined3 opts ip op fmt i)) -prtEval3PIO _ i = do - x <- eval3M i - prt3IO @opts x - --- | same as 'prtEval3P' but skips the proxy and allows you to set each parameter individually using type application -prtEval3 :: forall opts ip op fmt i +-- >>> newRefined3 @OZ @(Resplit "\\." >> Map (ReadP Int Id)) @(BoolsN "oops" 4 (Between 0 255 Id)) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "13.2.1.253.1" +-- Left Step 2. Failed Boolean Check(op) | Bools:invalid length(5) expected 4 +-- +newRefined3 :: forall opts ip op fmt i . ( Refined3C opts ip op fmt i , Show (PP ip i) - , Show i) + ) => i -> Either Msg3 (Refined3 opts ip op fmt i) -prtEval3 = prtEval3P Proxy +newRefined3 = runIdentity . newRefined3' -- | create a Refined3 using a 5-tuple proxy and aggregate the results on failure -prtEval3P :: forall opts ip op fmt i proxy +-- +-- >>> type T4 k = '(OZ, MkDayExtra Id >> 'Just Id, GuardBool "expected a Sunday" (Thd == 7), UnMkDay Fst, k) +-- >>> newRefined3P (Proxy @(T4 _)) (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday +-- +-- >>> newRefined3P (Proxy @(T4 _)) (2019,10,13) +-- Right (Refined3 (2019-10-13,41,7) (2019,10,13)) +-- +newRefined3P :: forall opts ip op fmt i proxy . ( Refined3C opts ip op fmt i , Show (PP ip i) - , Show i) + ) => proxy '(opts,ip,op,fmt,i) -> i -> Either Msg3 (Refined3 opts ip op fmt i) -prtEval3P _ i = - let (ret,mr) = eval3 i - in maybe (Left $ prt3Impl (getOptT @opts) ret) Right mr - --- | same as 'eval3P' but can pass the parameters individually using type application -eval3 :: forall opts ip op fmt i - . ( Refined3C opts ip op fmt i - ) - => i - -> (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 opts ip op fmt i)) -eval3 = eval3P Proxy +newRefined3P p = runIdentity . newRefined3P' p -- | create a Refined3 value using a 5-tuple proxy (see 'mkProxy3') -- -- use 'mkProxy3' to package all the types together as a 5-tuple -- -eval3P :: forall opts ip op fmt i proxy - . ( Refined3C opts ip op fmt i - ) +eval3P :: forall opts ip op fmt i m proxy + . ( MonadEval m + , Refined3C opts ip op fmt i + ) => proxy '(opts,ip,op,fmt,i) -> i - -> (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 opts ip op fmt i)) -eval3P _ = runIdentity . eval3M + -> m (RResults3 (PP ip i), Maybe (Refined3 opts ip op fmt i)) +eval3P _ = eval3M eval3M :: forall opts ip op fmt i m . ( MonadEval m , Refined3C opts ip op fmt i ) => i - -> m (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 opts ip op fmt i)) + -> m (RResults3 (PP ip i), Maybe (Refined3 opts ip op fmt i)) eval3M i = do - let o = getOptT @opts + let o = getOpt @opts ll <- eval (Proxy @ip) o i case getValAndPE ll of (Right a, t1) -> do @@ -830,7 +552,7 @@ (Right True,t2) -> do ss <- eval (Proxy @fmt) o a pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a t1 t2 b t3, Just (Refined3 a b)) + (Right b,t3) -> (RTTrueT a t1 t2 t3, Just (Refined3 a b)) (Left e,t3) -> (RTTrueF a t1 t2 e t3, Nothing) (Right False,t2) -> pure (RTFalse a t1 t2, Nothing) (Left e,t2) -> pure (RTF a t1 e t2, Nothing) @@ -842,133 +564,83 @@ , Refined3C opts ip op fmt i ) => PP ip i - -> m (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 opts ip op fmt i)) + -> m (RResults3 (PP ip i), Maybe (Refined3 opts ip op fmt i)) eval3MSkip a = do - let o = getOptT @opts + let o = getOpt @opts rr <- evalBool (Proxy @op) o a case getValAndPE rr of (Right True,t2) -> do ss <- eval (Proxy @fmt) o a pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a mkNodeSkipP t2 b t3, Just (Refined3 a b)) + (Right b,t3) -> (RTTrueT a mkNodeSkipP t2 t3, Just (Refined3 a b)) (Left e,t3) -> (RTTrueF a mkNodeSkipP t2 e t3, Nothing) (Right False,t2) -> pure (RTFalse a mkNodeSkipP t2, Nothing) (Left e,t2) -> pure (RTF a mkNodeSkipP e t2, Nothing) -prt3IO :: forall opts a b r . - (OptTC opts, Show a, Show b) - => (RResults3 a b, Maybe r) - -> IO (Either String r) -prt3IO (ret,mr) = do - let m3 = prt3Impl (getOptT @opts) ret - unless (hasNoTree (getOptT @opts)) $ putStrLn $ m3Long m3 - return $ maybe (Left (m3Desc m3 <> " | " <> m3Short m3)) Right mr +mkNodeSkipP :: Tree PE +mkNodeSkipP = Node (PE TrueP "skipped PP ip i = Id") [] data Msg3 = Msg3 { m3Desc :: !String , m3Short :: !String , m3Long :: !String + , m3ValP :: !ValP } deriving Eq instance Show Msg3 where - show (Msg3 a b c) = a <> " | " <> b <> (if null c then "" else "\n" <> c) + show (Msg3 a b c _d) = a <> nullIf " | " b <> nullIf "\n" c -prt3Impl :: forall a b . (Show a, Show b) +prt3Impl :: forall a . Show a => POpts - -> RResults3 a b + -> RResults3 a -> Msg3 prt3Impl opts v = - let outmsg msg = "\n*** " <> formatOMsg opts " " <> msg <> " ***\n\n" - 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 + let outmsg msg = "*** " <> formatOMsg opts " " <> msg <> " ***\n" + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) (" ++ showL opts a ++ ")") + mkMsg3 m n r bp | hasNoTree opts = Msg3 m n "" bp + | otherwise = Msg3 m n r bp in case v of RF e t1 -> - let (m,n) = ("Step 1. Initial Conversion(ip) Failed", e) + let (m,n) = ("Step 1. " <> colorValP Short opts (FailP e) <> " Initial Conversion(ip)", e) r = outmsg m <> prtTreePure opts t1 - in mkMsg3 m n r + in mkMsg3 m n r (t1 ^. root . peValP) RTF a t1 e t2 -> - let (m,n) = ("Step 2. Failed Boolean Check(op)", e) + let (m,n) = ("Step 2. " <> colorValP Short opts (FailP e) <> " Boolean Check(op)", e) r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg m <> prtTreePure opts t2 - in mkMsg3 m n r + in mkMsg3 m n r (t2 ^. root . peValP) RTFalse a t1 t2 -> - let (m,n) = ("Step 2. False Boolean Check(op)", z) - z = let w = t2 ^. root . pString + let (m,n) = ("Step 2. " <> colorValP Short opts FalseP <> " Boolean Check(op)", z) + z = let w = t2 ^. root . peString in if all isSpace w then "FalseP" else "{" <> w <> "}" r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg m <> prtTreePure opts t2 - in mkMsg3 m n r + in mkMsg3 m n r FalseP RTTrueF a t1 t2 e t3 -> - let (m,n) = ("Step 3. Failed Output Conversion(fmt)", e) + let (m,n) = ("Step 3. " <> colorValP Short opts (FailP e) <> " Output Conversion(fmt)", e) r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg "Step 2. Success Boolean Check(op)" <> prtTreePure opts t2 + <> "\n" <> outmsg m <> prtTreePure opts t3 - in mkMsg3 m n r - RTTrueT a t1 t2 b t3 -> - let (m,n) = ("Step 3. Success Output Conversion(fmt)", show b) + in mkMsg3 m n r (t3 ^. root . peValP) + RTTrueT a t1 t2 t3 -> + let (m,n) = ("Step 3. Success Output Conversion(fmt)", "") r = msg1 a - <> fixLite opts a t1 + <> prtTreePure opts t1 + <> "\n" <> outmsg "Step 2. Success Boolean Check(op)" <> prtTreePure opts t2 + <> "\n" <> outmsg m - <> fixLite opts b t3 - in mkMsg3 m n r - --- | similar to 'eval3P' but it emulates 'Refined3' using 'Refined' --- --- takes a 5-tuple proxy as input but outputs the Refined value and the result separately --- --- * initial conversion using \'ip\' and stores that in 'Refined' --- * runs the boolean predicate \'op\' to make sure to validate the converted value from 1. --- * runs \'fmt\' against the converted value from 1. --- * returns both the 'Refined' and the output from 3. --- * if any of the above steps fail the process stops it and dumps out 'RResults3' --- -eval3PX :: forall opts ip op fmt i proxy - . Refined3C opts ip op fmt i - => proxy '(opts,ip,op,fmt,i) - -> i - -> (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined opts op (PP ip i), PP fmt (PP ip i))) -eval3PX _ i = runIdentity $ do - let o = getOptT @opts - ll <- eval (Proxy @ip) o i - case getValAndPE ll of - (Right a,t1) -> do - rr <- evalBool (Proxy @op) o a - case getValAndPE rr of - (Right True,t2) -> do - ss <- eval (Proxy @fmt) o a - pure $ case getValAndPE ss of - (Right b,t3) -> (RTTrueT a t1 t2 b t3, Just (unsafeRefined a, b)) - (Left e,t3) -> (RTTrueF a t1 t2 e t3, Nothing) - (Right False,t2) -> pure (RTFalse a t1 t2, Nothing) - (Left e,t2) -> pure (RTF a t1 e t2, Nothing) - (Left e,t1) -> pure (RF e t1, Nothing) - --- | same as 'eval3PX' but allows you to set the parameters individually using type application -eval3X :: forall opts ip op fmt i - . ( Refined3C opts ip op fmt i - ) - => i - -> (RResults3 (PP ip i) (PP fmt (PP ip i)), Maybe (Refined opts op (PP ip i), PP fmt (PP ip i))) -eval3X = eval3PX (Proxy @'(opts,ip,op,fmt,i)) - --- | emulates 'Refined' using 'Refined3' by setting the input conversion and output formatting as noops -type RefinedEmulate (opts :: OptT) p a = Refined3 opts Id p Id a - --- | replace the opts type -type family ReplaceOptT3 (o :: OptT) t where - ReplaceOptT3 o (Refined3 _ ip op fmt i) = Refined3 o ip op fmt i - --- | change the opts type -type family AppendOptT3 (o :: OptT) t where - AppendOptT3 o (Refined3 o' ip op fmt i) = Refined3 (o' ':# o) ip op fmt i - + <> prtTreePure opts t3 + in mkMsg3 m n r (t3 ^. root . peValP)
+ src/Predicate/Refined5.hs view
@@ -0,0 +1,447 @@+-- refined5 doesnt care about the input as it is thrown away so we have no choice but to use PP ip i +-- like Refined2 but discards the original input value +-- all instances uses the internal values except for IsString [internal value is less likely to be a string!] +-- but json/binary/hash use internal input (ie PP ip i) as they json and binary have to roundtrip +-- tojson only has access to PP ip i! so fromjson can only use this! +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE NoStarIsType #-} +-- | refinement type allowing the external type to differ from the internal type +module Predicate.Refined5 ( + + -- ** Refined5 + Refined5 + , unRefined5 + + -- ** evaluation methods + , eval5P + , eval5M + , newRefined5 + , newRefined5' + , newRefined5P + , newRefined5P' + + -- ** proxy methods + , MakeR5 + + -- ** QuickCheck methods + , genRefined5 + , genRefined5P + + -- ** unsafe methods for creating Refined5 + , unsafeRefined5 + , unsafeRefined5' + + ) where +import Predicate.Refined2 (Msg2(..), RResults2(..), prt2Impl, Refined2C) +import Predicate.Refined (RefinedC) +import Predicate.Core +import Predicate.Misc +import Predicate.Util +import Data.Proxy (Proxy(..)) +import Data.Aeson (ToJSON(..), FromJSON(..)) +import qualified Language.Haskell.TH.Syntax as TH +import qualified GHC.Read as GR +import qualified Text.ParserCombinators.ReadPrec as PCR +import qualified Text.Read.Lex as RL +import qualified Data.Binary as B +import Data.Binary (Binary) +import Control.Lens +import Data.String (IsString(..)) +import Data.Hashable (Hashable(..)) +import GHC.Stack (HasCallStack) +import Test.QuickCheck +import Data.Coerce (coerce) +import Data.Either (isRight) +import Data.Char (isSpace) +import Control.Arrow (left) +import Data.Tree.Lens (root) +import Control.DeepSeq (NFData) + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XOverloadedStrings +-- >>> :m + Predicate.Prelude +-- >>> :m + Predicate.Refined2 +-- >>> :m + Data.Time + +-- | Refinement type for specifying an input type that is different from the output type +-- +-- * @opts@ are the display options +-- * @ip@ converts @i@ to @PP ip i@ which is stored +-- * @op@ validates that internal type using @PP op (PP ip i) ~ Bool@ +-- * @i@ is the input type which is discarded after converting to PP ip i +-- +newtype Refined5 (opts :: Opt) ip op i = Refined5 (PP ip i) + +type role Refined5 phantom nominal nominal nominal + +-- | extract the value from 'Refined5' +unRefined5 :: forall k k1 (opts :: Opt) (ip :: k) (op :: k1) i + . Refined5 opts ip op i + -> PP ip i +unRefined5 = coerce + +-- | directly load values into 'Refined5'. It still checks to see that those values are valid +unsafeRefined5' :: forall opts ip op i + . ( Refined2C opts ip op i + , HasCallStack + ) + => PP ip i + -> Refined5 opts ip op i +unsafeRefined5' = either error Refined5 . evalBool5 @opts @op + +-- | directly load values into 'Refined5' without any checking +unsafeRefined5 :: forall opts ip op i + . PP ip i + -> Refined5 opts ip op i +unsafeRefined5 = Refined5 + +deriving newtype instance ( Refined2C opts ip op i + , NFData (PP ip i) + ) => NFData (Refined5 opts ip op i) +deriving stock instance ( Refined2C opts ip op i + , Show (PP ip i) + ) => Show (Refined5 opts ip op i) +deriving stock instance ( Refined2C opts ip op i + , Eq (PP ip i) + ) => Eq (Refined5 opts ip op i) +deriving stock instance ( Refined2C opts ip op i + , Ord (PP ip i) + ) => Ord (Refined5 opts ip op i) +deriving stock instance ( Refined2C opts ip op i + , TH.Lift (PP ip i) + ) => TH.Lift (Refined5 opts ip op i) + +-- | 'IsString' instance for Refined5 +-- +-- >>> pureTryTest $ fromString @(Refined5 OL (ReadP Int Id) (Id > 12) String) "523" +-- Right (Refined5 523) +-- +-- >>> pureTryTest $ fromString @(Refined5 OL (ReadP Int Id) (Id > 12) String) "2" +-- Left () +-- +instance ( i ~ String + , Refined2C opts ip op i + , Show (PP ip i) + ) => IsString (Refined5 opts ip op i) where + fromString i = + case newRefined5 i of + Left e -> error $ "Refined5(fromString):" ++ show e + Right r -> r + +-- read instance from -ddump-deriv +-- | 'Read' instance for 'Refined5' +-- +-- >>> reads @(Refined5 OZ (ReadBase Int 16) (0 <..> 0xff) String) "Refined5 254" +-- [(Refined5 254,"")] +-- +-- >>> reads @(Refined5 OZ (ReadBase Int 16) (0 <..> 0xff) String) "Refined5 300" +-- [] +-- +-- >>> reads @(Refined5 OZ (ReadBase Int 16) (Id < 0) String) "Refined5 -1234" +-- [(Refined5 (-1234),"")] +-- +-- >>> reads @(Refined5 OZ (Map' (ReadP Int Id) (Resplit "\\.")) (GuardBool "len/=4" (Len == 4)) String) "Refined5 [192,168,0,1]" +-- [(Refined5 [192,168,0,1],"")] +-- +-- >>> reads @(Refined5 OZ (ReadP Rational Id) (Id > Negate 4 % 3) String) "Refined5 (-10 % 9)" +-- [(Refined5 ((-10) % 9),"")] +-- +-- >>> reads @(Refined5 OZ (ReadP Rational Id) (Id > Negate 4 % 3) String) "Refined5 (-10 % 6)" +-- [] + +instance ( Refined2C opts ip op i + , Read (PP ip i) + ) => Read (Refined5 opts ip op i) where + readPrec + = GR.parens + (PCR.prec + 11 + (do GR.expectP (RL.Ident "Refined5") + fld0 <- PCR.reset GR.readPrec + case evalQuick @opts @op fld0 of + Left {} -> fail "" + Right True -> pure (Refined5 fld0) + Right False -> fail "" + )) + readList = GR.readListDefault + readListPrec = GR.readListPrecDefault + +-- | 'ToJSON' instance for 'Refined5' +-- +-- >>> import qualified Data.Aeson as A +-- >>> A.encode (unsafeRefined5' @OZ @(ReadBase Int 16) @(Between 0 255 Id) 254) +-- "254" +-- +-- >>> A.encode (unsafeRefined5 @OZ @Id @'True @Int 123) +-- "123" +-- +instance ( Refined2C opts ip op i + , ToJSON (PP ip i) + ) => ToJSON (Refined5 opts ip op i) where + toJSON (Refined5 x) = toJSON x + +-- | 'FromJSON' instance for 'Refined5' +-- +-- >>> import qualified Data.Aeson as A +-- >>> A.eitherDecode' @(Refined5 OZ (ReadBase Int 16) (Id > 10 && Id < 256) String) "123" +-- Right (Refined5 123) +-- +-- >>> removeAnsi $ A.eitherDecode' @(Refined5 OL (ReadBase Int 16) (Id > 10 && Id < 256) String) "9" +-- Error in $: Refined5:false boolean check | {False && True | (9 > 10)} +-- False +-- +-- >>> A.eitherDecode' @(Refined5 OZ (ReadBase Int 16) (Id > 10 && Id < 256) String) "254" +-- Right (Refined5 254) +-- +-- >>> removeAnsi $ A.eitherDecode' @(Refined5 OAN (ReadBase Int 16) (Id > 10 && Id < 256) String) "12345" +-- Error in $: Refined5:false boolean check | {True && False | (12345 < 256)} +-- False True && False | (12345 < 256) +-- | +-- +- True 12345 > 10 +-- | | +-- | +- P Id 12345 +-- | | +-- | `- P '10 +-- | +-- `- False 12345 < 256 +-- | +-- +- P Id 12345 +-- | +-- `- P '256 +-- +instance ( Refined2C opts ip op i + , FromJSON (PP ip i) + ) => FromJSON (Refined5 opts ip op i) where + parseJSON z = do + i <- parseJSON @(PP ip i) z + case evalBool5 @opts @op i of + Left e -> fail $ "Refined5:" ++ e + Right _ -> return (Refined5 i) + +-- | 'Arbitrary' instance for 'Refined5' +-- +-- >>> :m + Data.Time.Calendar.WeekDate +-- >>> xs <- generate (vectorOf 10 (arbitrary @(Refined5 OAN (ReadP Int Id) (Negate 10 <..> 10) String))) +-- >>> all (\x -> unRefined5 x `elem` [-10 .. 10]) xs +-- True +-- +instance ( Arbitrary (PP ip i) + , Refined2C opts ip op i + ) => Arbitrary (Refined5 opts ip op i) where + arbitrary = genRefined5 arbitrary + +-- | create a 'Refined5' generator using a generator to restrict the values (so it completes) +genRefined5 :: + forall opts ip op i + . ( Refined2C opts ip op i + , HasCallStack + ) + => Gen (PP ip i) + -> Gen (Refined5 opts ip op i) +genRefined5 = genRefined5P Proxy + +-- generates the external value unlike Refined3 as we dont have a way to recreate the output from the internal value +-- | create a 'Refined5' generator using a proxy +genRefined5P :: + forall opts ip op i + . ( Refined2C opts ip op i + , HasCallStack + ) + => Proxy '(opts,ip,op,i) + -> Gen (PP ip i) + -> Gen (Refined5 opts ip op i) +genRefined5P _ g = + let f !cnt = do + mi <- suchThatMaybe g (isRight . evalBool5 @opts @op) + case mi of + Nothing -> + let o = getOpt @opts + in if cnt >= oRecursion o + then error $ setOtherEffects o ("genRefined5P recursion exceeded(" ++ show (oRecursion o) ++ ")") + else f (cnt+1) + Just i -> pure $ unsafeRefined5 i + in f 0 + +-- | 'Binary' instance for 'Refined5' +-- +instance ( Refined2C opts ip op i + , Binary (PP ip i) + ) => Binary (Refined5 opts ip op i) where + get = do + i <- B.get @(PP ip i) + case evalBool5 @opts @op i of + Left e -> fail $ "Refined5:Binary:" ++ e + Right _ -> return $ Refined5 i + put (Refined5 r) = B.put @(PP ip i) r + +-- | 'Hashable' instance for 'Refined5' +instance ( Refined2C opts ip op i + , Hashable (PP ip i) + ) => Hashable (Refined5 opts ip op i) where + hashWithSalt s (Refined5 b) = s + hash b + +newRefined5' :: forall opts ip op i m + . ( MonadEval m + , Refined2C opts ip op i + , Show (PP ip i) + ) + => i + -> m (Either Msg2 (Refined5 opts ip op i)) +newRefined5' = newRefined5P' Proxy + +-- | same as 'newRefined5P' but runs in IO +newRefined5P' :: forall opts ip op i proxy m + . ( MonadEval m + , Refined2C opts ip op i + , Show (PP ip i) + ) + => proxy '(opts,ip,op,i) + -> i + -> m (Either Msg2 (Refined5 opts ip op i)) +newRefined5P' _ i = do + (ret,mr) <- eval5M i + return $ maybe (Left $ prt2Impl (getOpt @opts) ret) Right mr + +-- | pure version for extracting Refined5 +-- +-- >>> newRefined5 @OZ @(ReadBase Int 16) @(Lt 255) "00fe" +-- Right (Refined5 254) +-- +-- >>> newRefined5 @OZ @(ReadBase Int 16) @(GuardBool (PrintF "0x%X is too large" Id) (Lt 253)) "00fe" +-- Left Step 2. Failed Boolean Check(op) | 0xFE is too large +-- +-- >>> newRefined5 @OZ @(ReadBase Int 16) @(Lt 255) "00fg" +-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16 +-- +-- >>> newRefined5 @OL @(Map' (ReadP Int Id) (Resplit "\\.")) @(Msg "length invalid:" (Len == 4)) "198.162.3.1.5" +-- Left Step 2. False Boolean Check(op) | {length invalid: 5 == 4} +-- +-- >>> newRefined5 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) "198.162.3.1.5" +-- Left Step 2. Failed Boolean Check(op) | found length=5 +-- +-- >>> newRefined5 @OZ @(Map' (ReadP Int Id) (Resplit "\\.")) @(GuardBool (PrintF "found length=%d" Len) (Len == 4)) "198.162.3.1" +-- Right (Refined5 [198,162,3,1]) +-- +-- >>> :m + Data.Time.Calendar.WeekDate +-- >>> newRefined5 @OZ @(MkDayExtra Id >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) (2019,10,13) +-- Right (Refined5 (2019-10-13,41,7)) +-- +-- >>> newRefined5 @OL @(MkDayExtra Id >> 'Just Id) @(Msg "expected a Sunday:" (Thd == 7)) (2019,10,12) +-- Left Step 2. False Boolean Check(op) | {expected a Sunday: 6 == 7} +-- +-- >>> newRefined5 @OZ @(MkDayExtra' Fst Snd Thd >> 'Just Id) @(GuardBool "expected a Sunday" (Thd == 7)) (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday +-- +-- >>> newRefined5 @OL @Id @'True 22 +-- Right (Refined5 22) +-- +-- >>> newRefined5 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust ToDay)) "2020-05-04 12:13:14Z" +-- Right (Refined5 2020-05-04 12:13:14 UTC) +-- +-- >>> newRefined5 @OL @(ReadP UTCTime Id) @(Between (MkDay '(2020,5,2)) (MkDay '(2020,5,7)) (MkJust ToDay)) "2020-05-08 12:13:14Z" +-- Left Step 2. False Boolean Check(op) | {Just 2020-05-08 <= Just 2020-05-07} +-- +newRefined5 :: forall opts ip op i + . ( Refined2C opts ip op i + , Show (PP ip i) + ) => i + -> Either Msg2 (Refined5 opts ip op i) +newRefined5 = newRefined5P Proxy + +newRefined5P :: forall opts ip op i + . ( Refined2C opts ip op i + , Show (PP ip i) + ) => Proxy '(opts,ip,op,i) + -> i + -> Either Msg2 (Refined5 opts ip op i) +newRefined5P _ i = + let (ret,mr) = runIdentity $ eval5M i + in maybe (Left $ prt2Impl (getOpt @opts) ret) Right mr + +eval5P :: forall opts ip op i m + . ( Refined2C opts ip op i + , MonadEval m + ) + => Proxy '(opts,ip,op,i) + -> i + -> m (RResults2 (PP ip i), Maybe (Refined5 opts ip op i)) +eval5P _ = eval5M + +eval5M :: forall opts ip op i m + . ( MonadEval m + , Refined2C opts ip op i + ) + => i + -> m (RResults2 (PP ip i), Maybe (Refined5 opts ip op i)) +eval5M i = do + let o = getOpt @opts + ll <- eval (Proxy @ip) o i + case getValAndPE ll of + (Right a, t1) -> do + rr <- evalBool (Proxy @op) o a + pure $ case getValAndPE rr of + (Right True,t2) -> (RTTrue a t1 t2, Just (Refined5 a)) + (Right False,t2) -> (RTFalse a t1 t2, Nothing) + (Left e,t2) -> (RTF a t1 e t2, Nothing) + (Left e,t1) -> pure (RF e t1, Nothing) + +-- | creates a 4-tuple proxy (see 'eval5P' 'newRefined5P') +-- +-- use type application to set the 4-tuple or set the individual parameters directly +-- +-- set the 4-tuple directly +-- +-- >>> eg1 = mkProxy2 @'(OL, ReadP Int Id, Gt 10, String) +-- >>> newRefined5P eg1 "24" +-- Right (Refined5 24) +-- +-- skip the 4-tuple and set each parameter individually using type application +-- +-- >>> eg2 = mkProxy2 @_ @OL @(ReadP Int Id) @(Gt 10) +-- >>> newRefined5P eg2 "24" +-- Right (Refined5 24) +-- + +-- | type family for converting from a 4-tuple '(opts,ip,op,i) to a 'Refined5' type +type family MakeR5 p where + MakeR5 '(opts,ip,op,i) = Refined5 opts ip op i + +evalBool5 :: forall opts p a + . (PP p a ~ Bool, RefinedC opts p a) + => a + -> Either String a +evalBool5 i = + let pp = runIdentity $ evalBool (Proxy @p) (getOpt @opts) i + opts = getOpt @opts + (lr,p2) = getValAndPE pp + z = let zz = p2 ^. root . peString + in if all isSpace zz then "FalseP" else "{" <> zz <> "}" + w = case lr of + Right True -> Right i + Right False -> Left $ "false boolean check" ++ nullIf " | " z + Left e -> Left $ "failed boolean check " ++ nullIf " | " e + in left (++ ("\n" ++ prtTreePure opts p2)) w +
src/Predicate/TH_Orphans.hs view
@@ -1,17 +1,16 @@-{-# OPTIONS -Wall #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoStarIsType #-} -{- | - Mainly contains useful Template Haskell Lift instances for Date Time --} +{-# LANGUAGE PolyKinds #-} +-- | orphan Lift instances for Data.Time module Predicate.TH_Orphans () where -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax (Lift) import Data.Time -import Data.Fixed +import Data.Fixed (Fixed(..)) import qualified Language.Haskell.TH.Lift as TL +import System.Random +import Data.Proxy deriving instance Lift Day deriving instance Lift LocalTime @@ -21,9 +20,12 @@ deriving instance Lift (Fixed a) $(TL.deriveLift ''DiffTime) ---instance Lift DiffTime where --- lift x = return $ LitE (IntegerL $ diffTimeToPicoseconds x) deriving instance Lift UTCTime + +$(TL.deriveLift ''StdGen) + +$(TL.deriveLift ''Proxy) +
src/Predicate/Util.hs view
@@ -1,1787 +1,1291 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE FunctionalDependencies #-} -{- | - Utility methods for Predicate / methods for displaying the evaluation tree --} -module Predicate.Util ( - -- ** TT - TT(..) - , tBool - , tString - , tForest - , fixBoolT - , topMessage - , hasNoTree - - -- ** BoolT - , BoolT(..) - , GetBoolT(..) - , _FailT - , _PresentT - , _FalseT - , _TrueT - - -- ** PE - , PE - , pString - - -- ** create tree functions - , mkNode - , mkNodeB - , mkNodeSkipP - - -- ** tree manipulation - , getValAndPE - , getValLRFromTT - , fromTT - , getValueLR - , fixLite - , fixit - , prefixMsg - , splitAndAlign - - -- ** display options - , POptsL - , POpts - , Debug(..) - , Disp(..) - , Color(..) - , isVerbose - , colorBoolT - , colorBoolT' - , setOtherEffects - , type Color1 - , type Color2 - , type Color3 - , type Color4 - , 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(..) - , type OptTT - , getOptT - , subopts - --- ** formatting functions - , show01 - , show01' - , lit01 - , litVerbose - , showVerbose - , showL - , litL - , litBL - , litBS - - -- ** regular expressions - , ROpt(..) - , compileRegex - , GetROpts(..) - , RReplace(..) - , GetReplaceFnSub(..) - , ReplaceFnSub(..) - , displayROpts - - -- ** useful type families - , ZwischenT - , FailWhenT - , FailUnlessT - , AndT - , OrT - , NotT - , RepeatT - , IntersperseT - , LenT - , InductTupleC(..) - , InductListC(..) - , FlipT - , IfT - , SumT - , MapT - , ConsT - , type (%%) - , type (%&) - , type (<%>) - , AnyT - , ExtractAFromList - , ExtractAFromTA - , MaybeT - , LeftT - , RightT - , ThisT - , ThatT - , TheseT - - -- ** extract values from the type level - , nat - , symb - , GetNats(..) - , GetSymbs(..) - , GetLen(..) - , GetThese(..) - , GetOrdering(..) - , GetBool(..) - , OrderingP(..) - , GetOrd(..) - - -- ** printing methods - , prtTreePure - , formatOMsg - , prtTree - - -- ** boolean methods - , (~>) - - -- ** extract from n-tuple - , T4_1 - , T4_2 - , T4_3 - , T4_4 - , T5_1 - , T5_2 - , T5_3 - , T5_4 - , T5_5 - - -- ** miscellaneous - , Holder - , hh - , showT - , showTK - , prettyOrd - , removeAnsi - , MonadEval(..) - , errorInProgram - , readField - , showThese - , chkSize - , pureTryTest - , pureTryTestPred - , isPrime - , unlessNull - , badLength - , showIndex - - ) where -import qualified GHC.TypeNats as GN -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import Control.Lens -import Control.Arrow -import Data.List -import qualified Data.Tree.View as TV -import Data.Tree -import Data.Tree.Lens -import Data.Proxy -import Data.Data -import System.Console.Pretty -import GHC.Exts (Constraint) -import qualified Text.Regex.PCRE.Heavy as RH -import qualified Text.Regex.PCRE.Light as RL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import GHC.Word (Word8) -import Data.Sequence (Seq) -import Control.Applicative (ZipList) -import Data.Kind (Type) -import Data.These (These(..)) -import Data.These.Combinators (isThis, isThat, isThese) -import qualified Control.Exception as E -import Control.DeepSeq -import System.IO.Unsafe (unsafePerformIO) -import Data.Bool -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as N -import Data.Either -import qualified Text.Read.Lex as L -import Text.ParserCombinators.ReadPrec -import qualified GHC.Read as GR -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.ByteString.Char8 as BS8 -import GHC.Stack -import Data.Monoid (Last (..)) -import Data.Maybe -import Data.Coerce -import Data.Foldable (toList) -import Data.Containers.ListUtils (nubOrd) - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators - --- | represents the evaluation tree for predicates -data TT a = TT { _tBool :: !(BoolT a) -- ^ the value at this root node - , _tString :: !String -- ^ detailed information eg input and output and text - , _tForest :: !(Forest PE) -- ^ the child nodes - } deriving Show - --- | contains the typed result from evaluating the expression tree -data BoolT a where - FailT :: !String -> BoolT a -- failure with string - FalseT :: BoolT Bool -- false predicate - TrueT :: BoolT Bool -- true predicate - PresentT :: !a -> BoolT a -- non predicate value - --- | semigroup instance for 'BoolT' --- -instance Semigroup (BoolT a) where - FailT s <> FailT s1 = FailT (s <> s1) - FailT s <> _ = FailT s - _ <> FailT s = FailT s - FalseT <> _ = FalseT - _ <> FalseT = FalseT - TrueT <> TrueT = TrueT - TrueT <> PresentT a = PresentT a - PresentT a <> TrueT = PresentT a - PresentT _ <> PresentT a = PresentT a - -deriving instance Show a => Show (BoolT a) -deriving instance Eq a => Eq (BoolT a) - --- | extracts the \'BoolT a\' constructors from the typelevel -class GetBoolT a (x :: BoolT a) | x -> a where - getBoolT :: Either Bool Bool -instance GetBoolT Bool 'TrueT where - getBoolT = Left True -instance GetBoolT Bool 'FalseT where - getBoolT = Left False -instance GetBoolT a ('PresentT b) where - getBoolT = Right True -instance GetBoolT a ('FailT s) where - getBoolT = Right False - --- | lens for accessing 'BoolT' in 'TT' -tBool :: Lens (TT a) (TT b) (BoolT a) (BoolT b) -tBool afb s = (\b -> s { _tBool = b }) <$> afb (_tBool s) - --- | lens for accessing the message from 'BoolT' -tString :: Lens' (TT a) String -tString afb s = (\b -> s { _tString = b }) <$> afb (_tString s) - --- | lens for accessing the subtree from 'BoolT' -tForest :: Lens' (TT a) (Forest PE) -tForest afb s = (\b -> s { _tForest = b }) <$> afb (_tForest s) - --- | a lens from typed 'BoolT' to the untyped 'BoolP' -boolT2P :: Lens' (BoolT a) BoolP -boolT2P afb = \case - FailT e -> FailT e <$ afb (FailP e) - TrueT -> TrueT <$ afb TrueP - FalseT -> FalseT <$ afb FalseP - PresentT a -> PresentT a <$ afb PresentP - --- | contains the untyped result from evaluating the expression tree -data BoolP = - FailP !String -- ^ fails the entire evaluation - | FalseP -- ^ False predicate - | TrueP -- ^ True predicate - | PresentP -- ^ Any value - deriving (Show, Eq) - --- | represents the untyped evaluation tree for final display -data PE = PE { _pBool :: !BoolP -- ^ holds the result of running the predicate - , _pString :: !String -- ^ optional strings to include in the results - } deriving Show - --- | lens for accessing '_pBool' -pBool :: Lens' PE BoolP -pBool afb s = (\b -> s { _pBool = b }) <$> afb (_pBool s) - --- | 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 opts bt ss hs = - case oDebug opts of - DZero -> TT bt [] [] - DLite -> TT bt ss [] -- keeps the last one so we can use the root to give more details on failure (especially for Refined* types) - _ -> TT bt ss (map fromTTH hs) - --- | creates a Boolean node for a predicate type -mkNodeB :: POpts - -> Bool - -> String - -> [Holder] - -> TT Bool -mkNodeB opts b = mkNode opts (bool FalseT TrueT b) - -mkNodeSkipP :: Tree PE -mkNodeSkipP = Node (PE TrueP "skipped PP ip i = Id") [] - -getValAndPE :: TT a -> (Either String a, Tree PE) -getValAndPE tt = (getValLRFromTT tt, fromTT tt) - -getValLRFromTT :: TT a -> Either String a -getValLRFromTT = getValLR . _tBool - --- | get the value from BoolT or fail -getValLR :: BoolT a -> Either String a -getValLR = \case - FailT e -> Left e - TrueT -> Right True - FalseT -> Right False - PresentT a -> Right a - --- | converts a typed tree to an untyped on for display -fromTT :: TT a -> Tree PE -fromTT (TT bt ss tt) = Node (PE (bt ^. boolT2P) ss) tt - --- | a monomorphic container of trees -data Holder = forall w . Holder !(TT w) - --- | converts a typed tree into an untyped one -fromTTH :: Holder -> Tree PE -fromTTH (Holder x) = fromTT x - --- | convenience method to wrap a typed tree -hh :: TT w -> Holder -hh = Holder - --- | add more detail to the tree if there are errors -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 - tt' - ) - (getValLRFromTT tt) - --- | wrapper for a show instance around 'Color' -newtype SColor = SColor Color - -instance Show SColor where - show (SColor c) = - case c of - Black-> "Black" - Red-> "Red" - Green-> "Green" - Yellow-> "Yellow" - Blue-> "Blue" - Magenta-> "Magenta" - Cyan-> "Cyan" - White-> "White" - Default -> "Default" - --- | the color palette for displaying the expression tree -newtype PColor = PColor (BoolP -> String -> String) -instance Show PColor where - show PColor {} = "PColor <fn>" - --- | elide the 'Identity' wrapper so it acts like a normal adt -type family HKD f a where - HKD Identity a = a - HKD f a = f a - --- | final set of options using Identity -type POpts = HOpts Identity - --- | customizable options for running a typelevel expression -data HOpts f = - HOpts { oWidth :: !(HKD f Int) -- ^ length of data to display for 'showLitImpl' - , oDebug :: !(HKD f Debug) -- ^ debug level - , oDisp :: !(HKD f Disp) -- ^ display the tree using the normal tree or unicode - , oColor :: !(HKD f (String, PColor)) -- ^ color palette used - , oMsg :: ![String] -- ^ messages associated with type - , oRecursion :: !(HKD f Int) -- ^ max recursion - , oOther :: !(HKD f (Bool, SColor, SColor)) -- ^ other message effects - , oNoColor :: !(HKD f Bool) -- ^ no colors - } - -deriving instance - ( Show (HKD f Int) - , Show (HKD f Debug) - , Show (HKD f Disp) - , Show (HKD f (String, PColor)) - , Show (HKD f Bool) - , Show (HKD f (Bool, SColor, SColor)) - ) => Show (HOpts f) - --- | combine options ala monoid -reifyOpts :: HOpts Last -> HOpts Identity -reifyOpts h = - HOpts (fromMaybe (oWidth defOpts) (getLast (oWidth h))) - (fromMaybe (oDebug defOpts) (getLast (oDebug h))) - (fromMaybe (oDisp defOpts) (getLast (oDisp h))) - (if fromMaybe (oNoColor defOpts) (getLast (oNoColor h)) then nocolor - else fromMaybe (oColor defOpts) (getLast (oColor h))) - (oMsg defOpts <> oMsg h) - (fromMaybe (oRecursion defOpts) (getLast (oRecursion h))) - (if fromMaybe (oNoColor defOpts) (getLast (oNoColor h)) then otherDef - else fromMaybe (oOther defOpts) (getLast (oOther h))) - (fromMaybe (oNoColor defOpts) (getLast (oNoColor h))) - --- | set maximum display width of expressions -setWidth :: Int -> POptsL -setWidth i = mempty { oWidth = pure i } - --- | set title message for the display tree -setMessage :: String -> POptsL -setMessage s = mempty { oMsg = pure s } - --- | set maximum recursion eg when running regex -setRecursion :: Int -> POptsL -setRecursion i = mempty { oRecursion = pure i } - --- | set color of title message -setOther :: Bool - -> Color - -> Color - -> POptsL -setOther b c1 c2 = mempty { oOther = pure $ coerce (b, c1, c2) } - --- | turn on/off colors -setNoColor :: Bool -> POptsL -setNoColor b = mempty { oNoColor = pure b } - --- | display type eg 'Unicode' or 'Ansi' -setDisp :: Disp -> POptsL -setDisp d = mempty { oDisp = pure d } - --- | create color palette for the expression tree -setCreateColor :: String - -> Color - -> Color - -> Color - -> Color - -> Color - -> Color - -> Color - -> Color - -> POptsL -setCreateColor s c1 c2 c3 c4 c5 c6 c7 c8 = - let pc = \case - FailP {} -> color c1 . bgColor c2 - FalseP -> color c3 . bgColor c4 - TrueP -> color c5 . bgColor c6 - PresentP -> color c7 . bgColor c8 - in mempty { oColor = pure (s,PColor pc) } - --- | set debug mode -setDebug :: Debug -> POptsL -setDebug d = - mempty { oDebug = pure d } - --- | monoid opts -type POptsL = HOpts Last - -instance Monoid (HOpts Last) where - mempty = HOpts mempty mempty mempty mempty mempty mempty mempty mempty - -instance Semigroup (HOpts Last) where - HOpts a b c d e f g h <> HOpts a' b' c' d' e' f' g' h' - = HOpts (a <> a') - (b <> b') - (c <> c') - (d <> d') - (e <> e') - (f <> f') - (g <> g') - (h <> h') - ---seqPOptsM :: HOpts Last -> Maybe (HOpts Identity) ---seqPOptsM h = coerce (HOpts <$> oWidth h <*> oDebug h <*> oDisp h <*> oColor h) - --- | display format for the tree -data Disp = Ansi -- ^ draw normal tree - | Unicode -- ^ use unicode - deriving (Show, Eq) - --- | default options -defOpts :: POpts -defOpts = HOpts - { oWidth = 100 - , oDebug = DNormal - , oDisp = Ansi - , oColor = colorDef - , oMsg = mempty - , oRecursion = 100 - , oOther = otherDef - , oNoColor = False - } - --- | default title message color and boundaries between multipart refine messages -otherDef :: (Bool, SColor, SColor) -otherDef = coerce (True, Default, Default) - -nocolor, colorDef :: (String, PColor) -nocolor = ("nocolor", PColor $ flip const) -colorDef = fromJust $ getLast $ oColor $ getOptT' @Color5 - --- | how much detail to show in the expression tree -data Debug = - DZero -- ^ one line summary used mainly for testing - | DLite -- ^ one line summary with additional context from the head of the evaluation tree - | DNormal -- ^ outputs the evaluation tree but skips noisy subtrees - | DVerbose -- ^ outputs the entire evaluation tree - deriving (Ord, Show, Eq, Enum, Bounded) - --- | verbose debug flag -isVerbose :: POpts -> Bool -isVerbose = (DVerbose==) . oDebug - --- | color palettes -type Color1 = 'OColor "color1" 'Default 'Blue 'Default 'Red 'Black 'Cyan 'Black 'Yellow -type Color2 = 'OColor "color2" 'Default 'Magenta 'Default 'Red 'Black 'White 'Black 'Yellow -type Color3 = 'OColor "color3" 'Default 'Blue 'Red 'Default 'White 'Default 'Black 'Yellow -type Color4 = 'OColor "color4" 'Default 'Red 'Red 'Default 'Green 'Default 'Black 'Yellow -type Color5 = 'OColor "color5" 'Blue 'Default 'Red 'Default 'Cyan 'Default 'Yellow 'Default - -type Other1 = 'OOther 'True 'Yellow 'Default -type Other2 = 'OOther 'True 'Default 'Default - --- | fix PresentT Bool to TrueT or FalseT -fixBoolT :: TT Bool -> TT Bool -fixBoolT t = - case t ^? tBool . _PresentT of - 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 - -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 - | null fmt && null as = msg0 - | otherwise = - msg0 - <> " " - <> showL opts ret - <> litVerbose opts (" | " ++ fmt) as - --- | 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 o i s a = - if oDebug o >= i || oDebug o == DLite then s <> litL o a - else "" - -showVerbose :: Show a - => POpts - -> String - -> a - -> String -showVerbose o = showAImpl o DVerbose - -showAImpl :: Show a - => POpts - -> Debug - -> String - -> a - -> String -showAImpl o i s a = showLitImpl o i s (show a) - -showL :: Show a - => POpts - -> a - -> String -showL o = litL o . show - -litL :: POpts -> String -> String -litL = litL' . oWidth - -litL' :: Int -> String -> String -litL' i s = take i s <> if length s > i then "..." else "" - -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 - | Auto_callout -- ^ Compile automatic callouts --- | Bsr_anycrlf -- \R matches only CR, LF, or CrlF --- | Bsr_unicode -- ^ \R matches all Unicode line endings - | Caseless -- ^ Do caseless matching - | Dollar_endonly -- ^ dollar not to match newline at end - | Dotall -- ^ matches anything including NL - | Dupnames -- ^ Allow duplicate names for subpatterns - | Extended -- ^ Ignore whitespace and # comments - | Extra -- ^ PCRE extra features (not much use currently) - | Firstline -- ^ Force matching to be before newline - | Multiline -- ^ caret and dollar match newlines within data --- | Newline_any -- ^ Recognize any Unicode newline sequence --- | Newline_anycrlf -- ^ Recognize CR, LF, and CrlF as newline sequences - | Newline_cr -- ^ Set CR as the newline sequence - | Newline_crlf -- ^ Set CrlF as the newline sequence - | Newline_lf -- ^ Set LF as the newline sequence - | No_auto_capture -- ^ Disable numbered capturing parentheses (named ones available) - | Ungreedy -- ^ Invert greediness of quantifiers - | Utf8 -- ^ Run in UTF--8 mode - | No_utf8_check -- ^ Do not check the pattern for UTF-8 validity - deriving (Show,Eq,Ord,Enum,Bounded) - --- | compile a regex using the type level symbol -compileRegex :: forall rs a . GetROpts rs - => 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)) (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 :: ([String], [RL.PCREOption]) -instance GetROpts '[] where - 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 -instance GetROpt 'Anchored where getROpt = RL.anchored -instance GetROpt 'Auto_callout where getROpt = RL.auto_callout ---instance GetROpt 'Bsr_anycrlf where getROpt = RL.bsr_anycrlf ---instance GetROpt 'Bsr_unicode where getROpt = RL.bsr_unicode -instance GetROpt 'Caseless where getROpt = RL.caseless -instance GetROpt 'Dollar_endonly where getROpt = RL.dollar_endonly -instance GetROpt 'Dotall where getROpt = RL.dotall -instance GetROpt 'Dupnames where getROpt = RL.dupnames -instance GetROpt 'Extended where getROpt = RL.extended -instance GetROpt 'Extra where getROpt = RL.extra -instance GetROpt 'Firstline where getROpt = RL.firstline -instance GetROpt 'Multiline where getROpt = RL.multiline ---instance GetROpt 'Newline_any where getROpt = RL.newline_any ---instance GetROpt 'Newline_anycrlf where getROpt = RL.newline_anycrlf -instance GetROpt 'Newline_cr where getROpt = RL.newline_cr -instance GetROpt 'Newline_crlf where getROpt = RL.newline_crlf -instance GetROpt 'Newline_lf where getROpt = RL.newline_lf -instance GetROpt 'No_auto_capture where getROpt = RL.no_auto_capture -instance GetROpt 'Ungreedy where getROpt = RL.ungreedy -instance GetROpt 'Utf8 where getROpt = RL.utf8 -instance GetROpt 'No_utf8_check where getROpt = RL.no_utf8_check - --- | simple regex string replacement options -data ReplaceFnSub = RPrepend | ROverWrite | RAppend deriving (Show,Eq) - --- | extract replacement options from typelevel -class GetReplaceFnSub (k :: ReplaceFnSub) where - getReplaceFnSub :: ReplaceFnSub -instance GetReplaceFnSub 'RPrepend where getReplaceFnSub = RPrepend -instance GetReplaceFnSub 'ROverWrite where getReplaceFnSub = ROverWrite -instance GetReplaceFnSub 'RAppend where getReplaceFnSub = RAppend - --- | used by 'Predicate.ReplaceImpl' and 'RH.sub' and 'RH.gsub' to allow more flexible replacement --- These parallel the RegexReplacement (not exported) class in "Text.Regex.PCRE.Heavy" but have overlappable instances which is problematic for this code so I use 'RReplace' -data RReplace = - RReplace !ReplaceFnSub !String - | RReplace1 !(String -> [String] -> String) - | RReplace2 !(String -> String) - | RReplace3 !([String] -> String) - -instance Show RReplace where - show = \case - RReplace o s -> "RReplace " ++ show o ++ " " ++ s - RReplace1 {} -> "RReplace1 <fn>" - RReplace2 {} -> "RReplace2 <fn>" - RReplace3 {} -> "RReplace3 <fn>" - --- | extract values from the trees or if there are errors return a tree with context -splitAndAlign :: Show x => - POpts - -> String - -> [((Int, x), TT a)] - -> Either (TT w) [(a, (Int, x), TT a)] -splitAndAlign opts msgs ts = - case partitionEithers (map partitionTTExtended ts) of - (excs@(e:_), _) -> - Left $ mkNode opts - (FailT (groupErrors (map snd excs))) - (msgs <> (formatList opts [fst e] <> " excnt=" <> show (length excs))) - (map (hh . snd) ts) - ([], tfs) -> Right tfs - -groupErrors :: [String] -> String -groupErrors = - intercalate " | " - . map (\xs@(x :| _) -> x <> (if length xs > 1 then "(" <> show (length xs) <> ")" else "")) - . N.group - -partitionTTExtended :: (w, TT a) -> Either ((w, TT x), String) (a, w, TT a) -partitionTTExtended (s, t) = - case _tBool t of - FailT e -> Left ((s, t & tBool .~ FailT e), e) - PresentT a -> Right (a,s,t) - TrueT -> Right (True,s,t) - FalseT -> Right (False,s,t) - -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 - foldMap am = foldMap am . _tBool - -instance Foldable BoolT where - foldMap am = either (const mempty) am . getValLR - --- cant use: is / isn't / has as only FailT will be False: use Fold --- this is more specific to TrueP FalseP --- | prism from BoolT to Bool -_boolT :: Prism' (BoolT Bool) Bool -_boolT = prism' (bool FalseT TrueT) - $ \case - PresentT a -> Just a - TrueT -> Just True - FalseT -> Just False - FailT {} -> Nothing - --- | 'FailT' prism -_FailT :: Prism' (BoolT a) String -_FailT = prism' FailT $ \case - FailT s -> Just s - _ -> Nothing - --- | 'PresentT' prism -_PresentT :: Prism' (BoolT a) a -_PresentT = prism' PresentT $ \case - PresentT a -> Just a - _ -> Nothing - --- | 'FalseT' prism -_FalseT :: Prism' (BoolT Bool) () -_FalseT = prism' (const FalseT) $ - \case - FalseT -> Just () - _ -> Nothing - --- | 'TrueT' prism -_TrueT :: Prism' (BoolT Bool) () -_TrueT = prism' (const TrueT) $ - \case - TrueT -> Just () - _ -> Nothing - --- | boolean implication --- --- >>> True ~> False --- False --- --- >>> True ~> True --- True --- --- >>> False ~> False --- True --- --- >>> False ~> True --- True --- -(~>) :: Bool -> Bool -> Bool -p ~> q = not p || q -infixr 1 ~> - --- | type level Between -type family ZwischenT (a :: Nat) (b :: Nat) (v :: Nat) :: Constraint where - ZwischenT m n v = - FailUnlessT (AndT (m GL.<=? v) (v GL.<=? n)) - ('GL.Text "ZwischenT failure" - ':$$: 'GL.ShowType v - ':$$: 'GL.Text " is outside of " - ':$$: 'GL.ShowType m - ':<>: 'GL.Text " and " - ':<>: 'GL.ShowType n) - --- | helper method that fails with a msg when True -type family FailWhenT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where - FailWhenT 'False _ = () - FailWhenT 'True e = GL.TypeError e - --- | helper method that fails with msg when False -type family FailUnlessT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where - FailUnlessT 'True _ = () - FailUnlessT 'False e = GL.TypeError e - --- | typelevel boolean And -type family AndT (b :: Bool) (b1 :: Bool) :: Bool where - AndT 'False _ = 'False - AndT 'True b1 = b1 - --- | typelevel boolean Or -type family OrT (b :: Bool) (b1 :: Bool) :: Bool where - OrT 'True _ = 'True - OrT 'False b1 = b1 - --- | typelevel boolean Not -type family NotT (b :: Bool) :: Bool where - NotT 'True = 'False - NotT 'False = 'True - --- | get a Nat from the typelevel --- --- >>> nat @14 --- 14 --- -nat :: forall n a . (KnownNat n, Num a) => a -nat = fromIntegral (GL.natVal (Proxy @n)) - --- | gets the Symbol from the typelevel --- --- >>> symb @"abc" --- "abc" --- -symb :: forall s . KnownSymbol s => String -symb = GL.symbolVal (Proxy @s) - --- | get a list of Nats from the typelevel --- --- >>> getNats @'[10,12,1] --- [10,12,1] -class GetNats as where - getNats :: [Int] -instance GetNats '[] where - getNats = [] -instance (KnownNat n, GetNats ns) => GetNats (n ': ns) where - getNats = nat @n : getNats @ns - --- | get a list of Symbols from the typelevel --- --- >>> getSymbs @'["abc","def","g"] --- ["abc","def","g"] --- -class GetSymbs ns where - getSymbs :: [String] -instance GetSymbs '[] where - getSymbs = [] -instance (KnownSymbol s, GetSymbs ss) => GetSymbs (s ': ss) where - getSymbs = symb @s : getSymbs @ss - --- | get the length of a typelevel container --- --- >>> getLen @'["abc","def","g"] --- 3 --- --- >>> getLen @'[] --- 0 --- --- >>> getLen @(9 ':| '[1,2,3]) --- 4 --- --- >>> getLen @('These 9 "Asfs") --- 1 --- --- >>> getLen @('This 1) --- 0 --- -class GetLen xs where -- (xs :: [k]) will break it! ghc 8.6.5 - getLen :: Int -instance GetLen '[] where - getLen = 0 -instance GetLen xs => GetLen (x ': xs) where - getLen = 1 + getLen @xs -instance GetLen ('Just a) where - getLen = 1 -instance GetLen 'Nothing where - getLen = 0 -instance GetLen ('Left a) where - getLen = 0 -instance GetLen ('Right a) where - getLen = 1 -instance GetLen ('This a) where - getLen = 0 -instance GetLen ('That a) where - getLen = 1 -instance GetLen ('These a b) where - getLen = 1 -instance GetLen xs => GetLen (x ':| xs) where - getLen = 1 + getLen @xs - --- | display constructor name for 'These' -showThese :: These a b -> String -showThese = \case - This {} -> "This" - That {} -> "That" - These {} -> "These" - --- | get 'These' from typelevel -class GetThese th where - getThese :: (String, These w v -> Bool) -instance GetThese ('This x) where - getThese = ("This", isThis) -instance GetThese ('That y) where - getThese = ("That", isThat) -instance GetThese ('These x y) where - getThese = ("These", isThese) - --- | get ordering from the typelevel -class GetOrdering (cmp :: Ordering) where - getOrdering :: Ordering -instance GetOrdering 'LT where - getOrdering = LT -instance GetOrdering 'EQ where - getOrdering = EQ -instance GetOrdering 'GT where - getOrdering = GT - --- | get 'Bool' from the typelevel -class GetBool (a :: Bool) where - getBool :: Bool -instance GetBool 'True where - getBool = True -instance GetBool 'False where - getBool = False - --- | get 'Color' from the typelevel -class GetColor (a :: Color) where - getColor :: Color -instance GetColor 'Black where - getColor = Black -instance GetColor 'Red where - getColor = Red -instance GetColor 'Green where - getColor = Green -instance GetColor 'Yellow where - getColor = Yellow -instance GetColor 'Blue where - getColor = Blue -instance GetColor 'Magenta where - getColor = Magenta -instance GetColor 'Cyan where - getColor = Cyan -instance GetColor 'White where - getColor = White -instance GetColor 'Default where - getColor = Default - --- | all the ways to compare two values -data OrderingP = CGt | CGe | CEq | CLe | CLt | CNe deriving (Show, Eq, Enum, Bounded) - --- | extract 'OrderingP' from the typelevel -class GetOrd (k :: OrderingP) where - getOrd :: Ord a => (String, a -> a -> Bool) - -instance GetOrd 'CGt where getOrd = (">", (>)) -instance GetOrd 'CGe where getOrd = (">=",(>=)) -instance GetOrd 'CEq where getOrd = ("==",(==)) -instance GetOrd 'CLe where getOrd = ("<=",(<=)) -instance GetOrd 'CLt where getOrd = ("<", (<)) -instance GetOrd 'CNe where getOrd = ("/=",(/=)) - --- | pretty print a tree -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 - else colorBoolP opts (_pBool bpe) <> " " <> _pString bpe - -hasNoTree :: POpts -> Bool -hasNoTree opts = - case oDebug opts of - DZero -> True - DLite -> True - DNormal -> False - DVerbose -> False - -nullSpace :: String -> String -nullSpace s | null s = "" - | otherwise = " " <> s - --- | render the 'BoolP' value with colors -colorBoolP :: - POpts - -> BoolP - -> String -colorBoolP o = - \case - b@(FailP e) -> "[" <> colorMe o b "Error" <> nullSpace e <> "]" - b@PresentP -> colorMe o b "P" - b@TrueP -> colorMe o b "True" - b@FalseP -> colorMe o b "False" - --- | render the 'BoolT' value with colors -colorBoolT :: Show a - => POpts - -> BoolT a - -> String -colorBoolT o r = - let f = colorMe o (r ^. boolT2P) - in case r of - FailT e -> f "Error " <> e - TrueT -> f "True" - FalseT -> f "False" - PresentT x -> f "Present " <> show x - -colorBoolT' :: Show a - => POpts - -> BoolT a - -> String -colorBoolT' o r = - let f = colorMe o (r ^. boolT2P) - in case r of - FailT e -> f "FailT " <> e - TrueT -> f "TrueT" - FalseT -> f "FalseT" - PresentT x -> f "PresentT " <> show x - --- | colors the result of the predicate based on the current color palette -colorMe :: - POpts - -> BoolP - -> String - -> String -colorMe o b s = - let (_, PColor f) = if oNoColor o then nocolor else oColor o - in f b s - --- | override PresentP case if there is no tree ie lite or zero mode -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 - --- | override PresentP case with long name -fixPresentP :: Show a - => POpts - -> BoolP - -> a - -> String -fixPresentP opts bp a = - case bp of - PresentP -> colorMe opts PresentP "Present " <> show a - _ -> colorBoolP opts bp - --- | display tree -prtTreePure :: - POpts - -> Tree PE - -> String -prtTreePure opts t - | hasNoTree opts = colorBoolP opts (t ^. root . pBool) - | otherwise = showImpl opts $ fmap (toNodeString opts) t - --- | extract message part from tree -topMessage :: TT a -> String -topMessage pp = - let s = pp ^. tString - in unlessNull s $ "(" <> s <> ")" - -showImpl :: POpts - -> Tree String - -> String -showImpl o = - case oDisp o of - Unicode -> TV.showTree - Ansi -> drawTree -- to drop the last newline else we have to make sure that everywhere else has that newline: eg fixLite - --- | render numbered tree -fixit :: ((Int, x), TT a) -> TT a -fixit ((i, _), t) = prefixMsg ("i=" <> show i <> ": ") t - --- | prefix text in front of tString -prefixMsg :: String -> TT a -> TT a -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)) - --- | pretty print 'Ordering' -prettyOrd :: Ordering -> String -prettyOrd = \case - LT -> "<" - EQ -> "=" - GT -> ">" - --- | Repeat an expression n times -type family RepeatT (n :: Nat) (p :: k) :: [k] where - RepeatT 0 p = GL.TypeError ('GL.Text "RepeatT is not defined for zero") - RepeatT 1 p = p ': '[] - RepeatT n p = p ': RepeatT (n GN.- 1) p - -type s <%> t = GL.AppendSymbol s t -infixr 7 <%> - --- | Intersperse a symbol inside a list of symbols -type family IntersperseT (s :: Symbol) (xs :: [Symbol]) :: Symbol where - IntersperseT s '[] = "" - IntersperseT s '[x] = x - IntersperseT s (x ': y ': xs) = x <%> s <%> IntersperseT s (y ': xs) - --- | length of a type level list -type family LenT (xs :: [k]) :: Nat where - LenT '[] = 0 - LenT (x ': xs) = 1 GN.+ LenT xs - --- | takes a flat n-tuple and creates a reversed inductive tuple. see 'Predicate.Data.ReadShow.PrintT' --- --- >>> inductTupleC (123,'x',False,"abc") --- ("abc",(False,('x',(123,())))) --- --- >>> inductTupleC (123,'x') --- ('x',(123,())) --- -class InductTupleC x where - type InductTupleP x - inductTupleC :: x -> InductTupleP x -instance (GL.TypeError ('GL.Text "InductTupleC: inductive tuple cannot be empty")) => InductTupleC () where - type InductTupleP () = () - inductTupleC () = () -instance InductTupleC (a,b) where - type InductTupleP (a,b) = (b,(a,())) - inductTupleC (a,b) = (b,(a,())) -instance InductTupleC (a,b,c) where - type InductTupleP (a,b,c) = (c,(b,(a,()))) - inductTupleC (a,b,c) = (c,(b,(a,()))) -instance InductTupleC (a,b,c,d) where - type InductTupleP (a,b,c,d) = (d,(c,(b,(a,())))) - inductTupleC (a,b,c,d) = (d,(c,(b,(a,())))) -instance InductTupleC (a,b,c,d,e) where - type InductTupleP (a,b,c,d,e) = (e,(d,(c,(b,(a,()))))) - inductTupleC (a,b,c,d,e) = (e,(d,(c,(b,(a,()))))) -instance InductTupleC (a,b,c,d,e,f) where - type InductTupleP (a,b,c,d,e,f) = (f,(e,(d,(c,(b,(a,())))))) - inductTupleC (a,b,c,d,e,f) = (f,(e,(d,(c,(b,(a,())))))) -instance InductTupleC (a,b,c,d,e,f,g) where - type InductTupleP (a,b,c,d,e,f,g) = (g,(f,(e,(d,(c,(b,(a,()))))))) - inductTupleC (a,b,c,d,e,f,g) = (g,(f,(e,(d,(c,(b,(a,()))))))) -instance InductTupleC (a,b,c,d,e,f,g,h) where - type InductTupleP (a,b,c,d,e,f,g,h) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) - inductTupleC (a,b,c,d,e,f,g,h) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) -instance InductTupleC (a,b,c,d,e,f,g,h,i) where - type InductTupleP (a,b,c,d,e,f,g,h,i) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) - inductTupleC (a,b,c,d,e,f,g,h,i) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) -instance InductTupleC (a,b,c,d,e,f,g,h,i,j) where - type InductTupleP (a,b,c,d,e,f,g,h,i,j) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) - inductTupleC (a,b,c,d,e,f,g,h,i,j) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) -instance InductTupleC (a,b,c,d,e,f,g,h,i,j,k) where - type InductTupleP (a,b,c,d,e,f,g,h,i,j,k) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) - inductTupleC (a,b,c,d,e,f,g,h,i,j,k) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) -instance InductTupleC (a,b,c,d,e,f,g,h,i,j,k,l) where - type InductTupleP (a,b,c,d,e,f,g,h,i,j,k,l) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) - inductTupleC (a,b,c,d,e,f,g,h,i,j,k,l) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) - --- | takes a list and converts to a reversed inductive tuple. see 'Predicate.Data.ReadShow.PrintL' --- --- >>> inductListC @4 [10,12,13,1] --- (1,(13,(12,(10,())))) --- --- >>> inductListC @2 ["ab","cc"] --- ("cc",("ab",())) --- -class InductListC (n :: Nat) a where - type InductListP n a - inductListC :: [a] -> InductListP n a -instance (GL.TypeError ('GL.Text "InductListC: inductive tuple cannot be empty")) => InductListC 0 a where - type InductListP 0 a = () - inductListC _ = errorInProgram "InductListC 0: shouldnt be called" -instance InductListC 1 a where - type InductListP 1 a = (a,()) - inductListC [a] = (a,()) - inductListC _ = errorInProgram "inductListC: expected 1 value" -instance InductListC 2 a where - type InductListP 2 a = (a,(a,())) - inductListC [a,b] = (b,(a,())) - inductListC _ = errorInProgram "inductListC: expected 2 values" -instance InductListC 3 a where - type InductListP 3 a = (a,(a,(a,()))) - inductListC [a,b,c] = (c,(b,(a,()))) - inductListC _ = errorInProgram "inductListC: expected 3 values" -instance InductListC 4 a where - type InductListP 4 a = (a,(a,(a,(a,())))) - inductListC [a,b,c,d] = (d,(c,(b,(a,())))) - inductListC _ = errorInProgram "inductListC: expected 4 values" -instance InductListC 5 a where - type InductListP 5 a = (a,(a,(a,(a,(a,()))))) - inductListC [a,b,c,d,e] = (e,(d,(c,(b,(a,()))))) - inductListC _ = errorInProgram "inductListC: expected 5 values" -instance InductListC 6 a where - type InductListP 6 a = (a,(a,(a,(a,(a,(a,())))))) - inductListC [a,b,c,d,e,f] = (f,(e,(d,(c,(b,(a,())))))) - inductListC _ = errorInProgram "inductListC: expected 6 values" -instance InductListC 7 a where - type InductListP 7 a = (a,(a,(a,(a,(a,(a,(a,()))))))) - inductListC [a,b,c,d,e,f,g] = (g,(f,(e,(d,(c,(b,(a,()))))))) - inductListC _ = errorInProgram "inductListC: expected 7 values" -instance InductListC 8 a where - type InductListP 8 a = (a,(a,(a,(a,(a,(a,(a,(a,())))))))) - inductListC [a,b,c,d,e,f,g,h] = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) - inductListC _ = errorInProgram "inductListC: expected 8 values" -instance InductListC 9 a where - type InductListP 9 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))) - inductListC [a,b,c,d,e,f,g,h,i] = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) - inductListC _ = errorInProgram "inductListC: expected 9 values" -instance InductListC 10 a where - type InductListP 10 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))) - inductListC [a,b,c,d,e,f,g,h,i,j] = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) - inductListC _ = errorInProgram "inductListC: expected 10 values" -instance InductListC 11 a where - type InductListP 11 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))))) - inductListC [a,b,c,d,e,f,g,h,i,j,k] = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) - inductListC _ = errorInProgram "inductListC: expected 11 values" -instance InductListC 12 a where - type InductListP 12 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))))) - inductListC [a,b,c,d,e,f,g,h,i,j,k,l] = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) - inductListC _ = errorInProgram "inductListC: expected 12 values" - --- partially apply the 2nd arg to an ADT -- $ and & work with functions only --- doesnt apply more than once because we need to eval it -type family (p :: k -> k1) %% (q :: k) :: k1 where - p %% q = p q - -infixl 9 %% - -type family (p :: k) %& (q :: k -> k1) :: k1 where - p %& q = q p - -infixr 9 %& - --- | 'flip' at the type level -type family FlipT (d :: k1 -> k -> k2) (p :: k) (q :: k1) :: k2 where - FlipT d p q = d q p - --- | 'if' at the type level -type family IfT (b :: Bool) (t :: k) (f :: k) :: k where - -- IfT b x x = x -- todo: benefit? now it needs to eval both sides - IfT 'True t f = t - IfT 'False t f = f - --- | 'sum' at the type level for a list of 'Nat' -type family SumT (ns :: [Nat]) :: Nat where - SumT '[] = 0 - SumT (n ': ns) = n GL.+ SumT ns - --- only works if you use ADTs not type synonyms --- | 'map' at the type level -type family MapT (f :: k -> k1) (xs :: [k]) :: [k1] where - MapT f '[] = '[] - MapT f (x ': xs) = f x ': MapT f xs - --- | Extract \'a\' from a list-like container -type family ConsT s where - ConsT [a] = a - ConsT (ZipList a) = a - ConsT T.Text = Char - ConsT ByteString = Word8 - ConsT (Seq a) = a - ConsT s = GL.TypeError ( - 'GL.Text "invalid ConsT instance" - ':$$: 'GL.Text "s = " - ':<>: 'GL.ShowType s) - --- | a typeclass for choosing which monad to run in -class Monad m => MonadEval m where - runIO :: IO a -> m (Maybe a) - catchit :: E.Exception e => a -> m (Either String a) - catchitNF :: (E.Exception e, NFData a) => a -> m (Either String a) - liftEval :: m a -> IO a - --- | 'Identity' instance for evaluating the expression -instance MonadEval Identity where - runIO _ = Identity Nothing - catchit v = Identity $ unsafePerformIO $ catchit @IO @E.SomeException v - catchitNF v = Identity $ unsafePerformIO $ catchitNF @IO @E.SomeException v - liftEval = return . runIdentity - --- | 'IO' instance for evaluating the expression -instance MonadEval IO where - runIO ioa = Just <$> ioa - catchit v = E.evaluate (Right $! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) - catchitNF v = E.evaluate (Right $!! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) - liftEval = id - --- | strip ansi characters from a string and print it (for doctests) -removeAnsi :: Show a => Either String a -> IO () -removeAnsi = putStrLn . removeAnsiImpl - -removeAnsiImpl :: Show a => Either String a -> String -removeAnsiImpl = - \case - Left e -> let esc = '\x1b' - f :: String -> Maybe (String, String) - f = \case - [] -> Nothing - c:cs | c == esc -> case break (=='m') cs of - (_,'m':s) -> Just ("",s) - _ -> Nothing - | otherwise -> Just $ break (==esc) (c:cs) - in concat $ unfoldr f e - Right a -> show a - -errorInProgram :: HasCallStack => String -> x -errorInProgram s = error $ "programmer error:" <> s - --- | read a field and value using 'ReadPrec' parser -readField :: String -> ReadPrec a -> ReadPrec a -readField fieldName readVal = do - GR.expectP (L.Ident fieldName) - 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 = - OWidth !Nat -- ^ set display width - | OMsg !Symbol -- ^ set text to add context to a failure message for refined types - | ORecursion !Nat -- ^ set recursion limit eg for regex - | OOther -- ^ set effects for messages - !Bool -- ^ set underline - !Color -- ^ set foreground color - !Color -- ^ set background color - | OEmpty -- ^ mempty - | !OptT :# !OptT -- ^ mappend - | OColor -- ^ set color palette - !Symbol -- ^ name of color palette - !Color -- ^ Fail foreground color - !Color -- ^ Fail background color - !Color -- ^ False foreground color - !Color -- ^ False background color - !Color -- ^ True foreground color - !Color -- ^ True background color - !Color -- ^ Present foreground color - !Color -- ^ Present background color - | OColorOn -- ^ turn on colors - | OColorOff -- ^ turn off colors - | OAnsi -- ^ ansi display - | OUnicode -- ^ unicode display - | OZero -- ^ debug mode return nothing - | OLite -- ^ debug mode return one line - | ONormal -- ^ debug mode normal - | OVerbose -- ^ debug mode verbose - | OZ -- ^ composite: no messages - | OL -- ^ composite: lite version - | 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 - OWidth _n -> "OWidth" - OMsg _s -> "OMsg" - ORecursion _n -> "ORecursion" - OOther _b _c1 _c2 -> "OOther" - OEmpty -> "OEmpty" - a :# b -> show a ++ " ':# " ++ show b - OColor _s _c1 _c2 _c3 _c4 _c5 _c6 _c7 _c8 -> "OColor" - 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 :# - --- | extract options from the typelevel -class OptTC (k :: OptT) where - getOptT' :: POptsL -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 - getOptT' = setOther (getBool @b) (getColor @c1) (getColor @c2) -instance OptTC 'OEmpty where - getOptT' = mempty -instance ( OptTC a - , OptTC b - ) => OptTC (a ':# b) where - getOptT' = getOptT' @a <> getOptT' @b -instance ( KnownSymbol s - , GetColor c1 - , GetColor c2 - , GetColor c3 - , GetColor c4 - , GetColor c5 - , GetColor c6 - , GetColor c7 - , GetColor c8) - => OptTC ('OColor s c1 c2 c3 c4 c5 c6 c7 c8) where - getOptT' = setCreateColor - (symb @s) - (getColor @c1) - (getColor @c2) - (getColor @c3) - (getColor @c4) - (getColor @c5) - (getColor @c6) - (getColor @c7) - (getColor @c8) -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 <> setWidth 200 -instance OptTC 'OAN where - 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 <> setWidth 100 -instance OptTC 'OAB where - 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' = getOptT' @('OA ':# 'OUnicode) -instance OptTC 'OUB where - getOptT' = getOptT' @('OAB ':# 'OUnicode) -instance OptTC 'OUV where - getOptT' = getOptT' @('OAV ':# 'OUnicode) - --- | combinations of options -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")) --- (Ansi,("color4",321)) --- --- >>> oMsg (getOptT @('OMsg "abc" ':# 'OMsg "def")) --- ["abc","def"] --- --- >>> 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==b && b==c --- True --- -getOptT :: forall o . OptTC o => POpts -getOptT = reifyOpts (getOptT' @o) - --- | extract \'opts\' part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' -type family T4_1 x where - T4_1 '(opts,_,_,_) = opts --- | extract \'ip\' part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' -type family T4_2 x where - T4_2 '(_,ip,_,_) = ip --- | extract \'op\' part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' -type family T4_3 x where - T4_3 '(_,_,op,_) = op --- | extract \'i\' part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2' -type family T4_4 x where - T4_4 '(_,_,_,i) = i - --- | extract \'opts\' part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' -type family T5_1 x where - T5_1 '(opts,_,_,_,_) = opts --- | extract \'ip\' part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' -type family T5_2 x where - T5_2 '(_,ip,_,_,_) = ip --- | extract \'op\' part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' -type family T5_3 x where - T5_3 '(_,_,op,_,_) = op --- | extract \'fmt\' part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' -type family T5_4 x where - T5_4 '(_,_,_,fmt,_) = fmt --- | extract \'i\' part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3' -type family T5_5 x where - T5_5 '(_,_,_,_,i) = i - --- | deal with possible recursion on a list -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")) ("max is " ++ show mx) hhs - --- | pretty print a message -formatOMsg :: POpts -> String -> String -formatOMsg o suffix = - case oMsg o of - [] -> mempty - s@(_:_) -> intercalate " | " (map (setOtherEffects o) s) <> suffix - --- | override options for 'DZero' so we dont lose error information -subopts :: POpts -> POpts -subopts opts = - case oDebug opts of - DZero -> opts { oDebug = DLite } - _ -> opts - --- | render a string for messages using optional color and underline -setOtherEffects :: POpts -> String -> String -setOtherEffects o = - if oNoColor o then id - else case coerce (oOther o) of - (False, Default, Default) -> id - (b, c1, c2) -> (if b then style Underline else id) . color c1 . bgColor c2 - -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 p a = do - lr <- left E.displayException <$> E.try @E.SomeException (E.evaluate a) - return $ case lr of - Left e | p e -> Right (Left ()) - | 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]) - --- | represents any kind -type family AnyT :: k where {} - --- | mconcat 'OptT' 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 - --- | convenience method for optional display -unlessNull :: (Foldable t, Monoid m) => t a -> m -> m -unlessNull t m | null t = mempty - | otherwise = m - --- | message to display when the length of a foldable is exceeded -badLength :: Foldable t - => t a - -> Int - -> String -badLength as n = ":invalid length(" <> show (length as) <> ") expected " ++ show n - --- | type family to extract \'a\' from \'t a\' -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 --- | type family to extract \'a\' from a list of \'a\' -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) - -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) - - -type family LeftT lr where - LeftT (Either a _) = 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) - -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) - -prtTree :: Show x => POpts -> TT x -> String -prtTree opts pp = - let r = pp ^. tBool - in case oDebug opts of - DZero -> "" - DLite -> - formatOMsg opts " >>> " - <> colorBoolT opts r - <> " " - <> topMessage pp - <> "\n" - _ -> formatOMsg opts "\n" - <> prtTreePure opts (fromTT pp) - -showIndex :: (Show i, Num i) => i -> String -showIndex i = show (i+0) +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | utility methods for Predicate / methods for displaying the evaluation tree +module Predicate.Util ( + -- ** Val + Val(..) + , _Fail + , _Val + , _True + , _False + , _ValEither + , val2P + , val2PBool + + -- ** TT typed tree + , TT(..) + , ttVal + , ttValBool + , ttString + , ttForest + + -- ** PE untyped tree + , PE(..) + , peValP + , peString + + -- ** ValP + , ValP(..) + , _FailP + , _TrueP + , _FalseP + , _ValP + + -- ** create tree + , mkNode + , mkNodeB + , mkNodeCopy + + -- ** tree manipulation + , getValAndPE + , getValLRFromTT + , getValueLR + , Inline (..) + , prefixNumberToTT + , prefixMsg + , splitAndAlign + , verboseList + , fixTTBool + , topMessage + , hasNoTree + + -- ** options + , POpts + , Debug(..) + , Disp(..) + , Color(..) + , isVerbose + , colorValBool + , colorValP + , Long(..) + , setOtherEffects + , type Color1 + , type Color2 + , type Color3 + , type Color4 + , type Color5 + , type Other1 + , type Other2 + + , type OZ + , type OL + , type OA + , type OAB + , type OAN + , type OAV + , type OANV + , type OU + , type OUB + , type OUN + , type OUV + , type OUNV + + , HOpts(..) + , Opt(..) + , OptC + , type OptT + , getOpt + , subopts + , _DVerbose + , _Debug + , defOpts + +-- ** formatting functions + , show3 + , show3' + , lit3 + , litVerbose + , showVerbose + , showL + , litL + , litBL + , litBS + + -- ** printing methods + , prtTreePure + , formatOMsg + , prtTree + + -- ** MonadEval + , MonadEval(..) + + -- ** miscellaneous + , hh + , chkSize + , chkSize2 + , badLength + + ) where +import Predicate.Misc +import GHC.TypeLits (Symbol, Nat, KnownSymbol, KnownNat) +import Control.Lens +import Control.Arrow (Arrow((&&&)), ArrowChoice(left)) +import Data.List (intercalate, isInfixOf) +import Data.Tree (drawTree, Forest, Tree(Node)) +import Data.Tree.Lens (root) +import System.Console.Pretty (Color(..)) +import qualified System.Console.Pretty as C +import qualified Control.Exception as E +import Control.DeepSeq (NFData, ($!!)) +import System.IO.Unsafe (unsafePerformIO) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as N +import Data.Either (partitionEithers) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Char8 as BS8 +import Data.Monoid (Last(Last)) +import Data.Maybe (fromMaybe) +import Data.Coerce (coerce) +import Data.Foldable (toList) +import qualified Safe (initSafe, fromJustNote) +import Control.Monad (ap) +import Data.Bool (bool) +import GHC.Generics (Generic, Generic1) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :m + Control.Arrow + +-- | contains the untyped result from evaluating an expression +data ValP = + FailP !String -- ^ evaluation failed + | FalseP -- ^ False predicate + | TrueP -- ^ True predicate + | ValP -- ^ Any value + deriving stock (Show, Ord, Eq, Read, Generic) + +makePrisms ''ValP + +-- | untyped child node for 'TT' +data PE = PE { _peValP :: !ValP -- ^ holds the result of running the predicate + , _peString :: !String -- ^ optional strings to include in the results + } deriving stock (Show, Read, Eq, Generic) + +makeLenses ''PE + +instance Monoid PE where + mempty = PE mempty mempty + +-- | concatenate two strings with delimiter +-- +-- >>> jamSS "xyz" "abc" +-- "xyz | abc" +-- +-- >>> jamSS "" "abc" +-- "abc" +-- +-- >>> jamSS "xyz" "" +-- "xyz" +-- +-- >>> jamSS "" "" +-- "" +-- +jamSS :: String -> String -> String +jamSS s s1 = s <> (if null s || null s1 then "" else " | ") <> s1 + +instance Semigroup PE where + PE b s <> PE b1 s1 = PE (b <> b1) (jamSS s s1) + +-- | semigroup for ValP +-- +-- >>> TrueP <> FalseP <> ValP +-- ValP +-- +-- >>> ValP <> TrueP <> FalseP +-- FalseP +-- +-- >>> FailP "abc" <> (TrueP <> FalseP) <> FailP "def" +-- FailP "abc | def" +-- +-- >>> (FailP "abc" <> TrueP) <> (FalseP <> FailP "def") +-- FailP "abc | def" +-- +-- >>> FailP "" <> (TrueP <> FalseP) <> FailP "def" +-- FailP "def" +-- +-- >>> FailP "abc" <> FailP "" <> FailP "def" +-- FailP "abc | def" +-- +-- >>> FailP "abc" <> FailP "xyz" <> FailP "def" +-- FailP "abc | xyz | def" +-- +instance Semigroup ValP where + FailP s <> FailP s1 = FailP (jamSS s s1) + FailP s <> _ = FailP s + _ <> FailP s = FailP s + _ <> ValP = ValP + _ <> TrueP = TrueP + _ <> FalseP = FalseP + +instance Monoid ValP where + mempty = ValP + +-- | contains the typed result from evaluating an expression +data Val a = Fail !String | Val !a + deriving stock (Show, Eq, Ord, Read, Functor, Foldable, Traversable, Generic, Generic1) + +makePrisms ''Val + +instance Applicative Val where + pure = Val + (<*>) = ap + +instance Monad Val where + return = pure + Val a >>= amb = amb a + Fail s >>= _ = Fail s + +-- | semigroup instance for 'Val' +-- +-- >>> Val 123 <> (Val 456 <> Val 789) == (Val 123 <> Val 456) <> Val 789 +-- True +-- +-- >>> Val True <> Val False +-- Val False +-- +-- >>> Val True <> Val True +-- Val True +-- +-- >>> Fail "abc" <> (Val True <> Val False) <> Fail "def" +-- Fail "abc | def" +-- +-- >>> (Fail "abc" <> Val True) <> (Val False <> Fail "def") +-- Fail "abc | def" +-- +-- >>> Fail "" <> (Val True <> Val False) <> Fail "def" +-- Fail "def" +-- +-- >>> Fail "abc" <> Fail "" <> Fail "def" +-- Fail "abc | def" +-- +-- >>> Val False <> (Val True <> Val False) == (Val False <> Val True) <> Val False +-- True +-- +instance Semigroup (Val a) where + Fail s <> Fail s1 = Fail (jamSS s s1) + Fail s <> _ = Fail s + _ <> Fail s = Fail s + Val _ <> Val b = Val b + +-- | monoid instance for 'Val' +-- +-- >>> mempty :: Val (Maybe [Int]) +-- Val Nothing +-- +-- >>> import qualified Data.Semigroup as SG +-- >>> mempty :: SG.Sum Int +-- Sum {getSum = 0} +-- +instance Monoid a => Monoid (Val a) where + mempty = Val mempty + +-- | 'Read' instance for Val +-- +-- >>> reads @(Val Int) "Val 123" +-- [(Val 123,"")] +-- +-- >>> reads @(Val Bool) "Val False abc" +-- [(Val False," abc")] +-- +-- >>> reads @(Val Bool) "Fail \"some error message\"" +-- [(Fail "some error message","")] +-- +-- >>> reads @(Val Double) "Fail \"some error message\"" +-- [(Fail "some error message","")] +-- + +-- | typed tree holding the results of evaluating a type level expression +data TT a = TT { _ttValP :: !ValP -- ^ display value + , _ttVal :: !(Val a) -- ^ the value at this root node + , _ttString :: !String -- ^ detailed information eg input and output and text + , _ttForest :: !(Forest PE) -- ^ the child nodes + } deriving stock (Functor, Read, Show, Eq, Foldable, Traversable, Generic, Generic1) + +makeLensesFor [("_ttString","ttString"),("_ttForest","ttForest")] ''TT + +instance Semigroup (TT a) where + TT bp bt ss ts <> TT bp1 bt1 ss1 ts1 = + TT (bp <> bp1) (bt <> bt1) (jamSS ss ss1) (ts <> ts1) + +instance Monoid a => Monoid (TT a) where + mempty = TT mempty mempty mempty mempty + +instance Applicative TT where + pure a = TT ValP (pure a) "" [] + (<*>) = ap + +instance Monad TT where + return = pure + z@(TT _ bt ss ts) >>= amb = + case bt of + Val a -> amb a & ttString %~ jamSS ss + & ttForest %~ (ts <>) + Fail e -> z & ttVal .~ Fail e + +-- | creates a Node for the evaluation tree +mkNodeCopy :: POpts + -> TT a + -> String + -> [Tree PE] + -> TT a +mkNodeCopy opts = mkNodeImpl opts . (_ttValP &&& _ttVal) + +-- | creates a Node for the evaluation tree +mkNode :: POpts + -> Val a + -> String + -> [Tree PE] + -> TT a +mkNode opts = mkNodeImpl opts . (view val2P &&& id) + +-- | creates a Node for the evaluation tree +mkNodeImpl :: POpts + -> (ValP, Val a) + -> String + -> [Tree PE] + -> TT a +mkNodeImpl opts (bp',bt) ss hs = + let bp = validateValP bp' bt + in case oDebug opts of + DZero -> TT bp bt "" [] + DLite -> + -- keeps the last string so we can use the root to give more details on failure (especially for Refined* types) + -- also holds onto any failures + let zs = filter (has (root . peValP . _FailP)) hs + in TT bp bt ss zs + _ -> TT bp bt ss hs + +-- | check that 'ValP' value is consistent with 'Val' a +validateValP :: ValP -> Val a -> ValP +validateValP bp bt = + case bt of + Val _a -> case bp of + FailP e -> errorInProgram $ "validateValP: found FailP for Val in Val e=" ++ e + _ -> bp + Fail e -> case bp of + FailP e1 | e==e1 -> bp + | otherwise -> errorInProgram $ "validateValP: found Fail but message mismatch in ValP " ++ show (e,e1) + _ -> errorInProgram $ "validateValP: found " ++ show bp ++ " expected FailP e=" ++ e + +-- | fix the 'ValP' value for the Bool case: ie use 'TrueP' and 'FalseP' +-- +-- >>> fixTTBool (TT ValP (Val True) "x" []) == TT TrueP (Val True) "x" [] +-- True +-- +-- >>> fixTTBool (TT FalseP (Fail "abc") "x" []) == TT (FailP "abc") (Fail "abc") "x" [] +-- True +-- +fixTTBool :: TT Bool -> TT Bool +fixTTBool = over ttValBool id + +-- | creates a Boolean node for a predicate type +mkNodeB :: POpts + -> Bool + -> String + -> [Tree PE] + -> TT Bool +mkNodeB opts = mkNodeImpl opts . (bool FalseP TrueP &&& Val) + +-- | convenience method to pull parts out of 'TT' +getValAndPE :: TT a -> (Either String a, Tree PE) +getValAndPE = getValLRFromTT &&& hh + +-- | convenience method to pull out the return value from 'TT' +getValLRFromTT :: TT a -> Either String a +getValLRFromTT = view (ttVal . _ValEither) + +-- | converts a typed tree to an untyped tree for display +hh :: TT a -> Tree PE +hh (TT bp bt ss tt) = Node (PE (validateValP bp bt) ss) tt + +data Inline = Inline | NoInline deriving (Show, Eq) + +-- | decorate the tree with more detail when there are errors but inline the error node +getValueLR :: Inline + -> POpts + -> String + -> TT a + -> [Tree PE] + -> Either (TT x) a +getValueLR inline opts msg0 tt hs = +-- hack: if infix ... + let ts = if _ttString tt `isInfixOf` msg0 then "" else _ttString tt + xs = ts <> (if null ts || null msg0 then "" else " | ") <> msg0 + tts = case inline of + Inline -> hs <> _ttForest tt + NoInline -> hs <> [hh tt] + in left (\e -> mkNode opts (Fail e) xs tts) (getValLRFromTT tt) + + +-- | elide the 'Identity' wrapper so it acts like a normal ADT +type family HKD f a where + HKD Identity a = a + HKD f a = f a + +-- | final set of options using Identity +type POpts = HOpts Identity + +-- | customizable options for running a typelevel expression +data HOpts f = + HOpts { oWidth :: !(HKD f Int) -- ^ length of data to display for 'showLitImpl' + , oDebug :: !(HKD f Debug) -- ^ debug level + , oDisp :: !(HKD f Disp) -- ^ display the tree using the normal tree or unicode + , oColor :: !(HKD f (String, PColor)) -- ^ color palette used + , oMsg :: ![String] -- ^ messages associated with type + , oRecursion :: !(HKD f Int) -- ^ max recursion + , oOther :: !(HKD f (Bool, SColor, SColor)) -- ^ other message effects + , oNoColor :: !(HKD f Bool) -- ^ no colors + } + +-- | the color palette for displaying the expression tree +newtype PColor = PColor (ValP -> String -> String) +instance Show PColor where + show PColor {} = "PColor <fn>" + +deriving stock instance + ( Show (HKD f Int) + , Show (HKD f Debug) + , Show (HKD f Disp) + , Show (HKD f (String, PColor)) + , Show (HKD f Bool) + , Show (HKD f (Bool, SColor, SColor)) + ) => Show (HOpts f) + +-- | combine options ala monoid +reifyOpts :: HOpts Last -> HOpts Identity +reifyOpts h = + HOpts (fromMaybe (oWidth defOpts) (coerce (oWidth h))) + (fromMaybe (oDebug defOpts) (coerce (oDebug h))) + (fromMaybe (oDisp defOpts) (coerce (oDisp h))) + (if fromMaybe (oNoColor defOpts) (coerce (oNoColor h)) + then nocolor + else fromMaybe (oColor defOpts) (coerce (oColor h)) + ) + (oMsg defOpts <> oMsg h) + (fromMaybe (oRecursion defOpts) (coerce (oRecursion h))) + (if fromMaybe (oNoColor defOpts) (coerce (oNoColor h)) + then otherDef + else fromMaybe (oOther defOpts) (coerce (oOther h)) + ) + (fromMaybe (oNoColor defOpts) (coerce (oNoColor h))) + +-- | set maximum display width of expressions +setWidth :: Int -> HOpts Last +setWidth i = mempty { oWidth = pure i } + +-- | set title message for the display tree +setMessage :: String -> HOpts Last +setMessage s = mempty { oMsg = pure s } + +-- | set maximum recursion eg when running regex +setRecursion :: Int -> HOpts Last +setRecursion i = mempty { oRecursion = pure i } + +-- | set color of title message +setOther :: Bool + -> Color + -> Color + -> HOpts Last +setOther b c1 c2 = mempty { oOther = pure $ coerce (b, c1, c2) } + +-- | turn on/off colors +setNoColor :: Bool -> HOpts Last +setNoColor b = mempty { oNoColor = pure b } + +-- | display type eg 'Unicode' or 'Ansi' +setDisp :: Disp -> HOpts Last +setDisp d = mempty { oDisp = pure d } + +-- | create color palette for the expression tree +setCreateColor :: String + -> Color + -> Color + -> Color + -> Color + -> Color + -> Color + -> Color + -> Color + -> HOpts Last +setCreateColor s c1 c2 c3 c4 c5 c6 c7 c8 = + let pc = \case + FailP {} -> C.color c1 . C.bgColor c2 + FalseP -> C.color c3 . C.bgColor c4 + TrueP -> C.color c5 . C.bgColor c6 + ValP -> C.color c7 . C.bgColor c8 + in mempty { oColor = pure (s,PColor pc) } + +-- | set debug mode +setDebug :: Debug -> HOpts Last +setDebug d = + mempty { oDebug = pure d } + +-- | monoid opts +instance Monoid (HOpts Last) where + mempty = HOpts mempty mempty mempty mempty mempty mempty mempty mempty + +instance Semigroup (HOpts Last) where + HOpts a b c d e f g h <> HOpts a' b' c' d' e' f' g' h' + = HOpts (a <> a') + (b <> b') + (c <> c') + (d <> d') + (e <> e') + (f <> f') + (g <> g') + (h <> h') + +--seqPOptsM :: HOpts Last -> Maybe (HOpts Identity) +--seqPOptsM h = coerce (HOpts <$> oWidth h <*> oDebug h <*> oDisp h <*> oColor h) + +-- | display format for the tree +data Disp = Ansi -- ^ draw normal tree + | Unicode -- ^ use unicode + deriving stock (Show, Eq, Read, Bounded, Enum) + +-- | default options +defOpts :: POpts +defOpts = HOpts + { oWidth = 100 + , oDebug = DNormal + , oDisp = Ansi + , oColor = colorDef + , oMsg = mempty + , oRecursion = 100 + , oOther = otherDef + , oNoColor = False + } + +-- | default title message color and boundaries between multipart refine messages +otherDef :: (Bool, SColor, SColor) +otherDef = coerce (True, Default, Default) + +nocolor, colorDef :: (String, PColor) +nocolor = ("nocolor", PColor $ flip const) +colorDef = Safe.fromJustNote "colorDef" $ coerce $ oColor $ getOptC @Color5 + +-- | how much detail to show in the expression tree +data Debug = + DZero -- ^ one line summary used mainly for testing + | DLite -- ^ one line summary with additional context from the top of the evaluation tree + | DNormal -- ^ outputs the evaluation tree but skips noisy subtrees + | DVerbose -- ^ outputs the entire evaluation tree + deriving stock (Read, Ord, Show, Eq, Enum, Bounded) + +-- | verbose debug flag +isVerbose :: POpts -> Bool +isVerbose = (DVerbose==) . oDebug + +-- | color palettes +type Color1 = 'OColor "color1" 'Default 'Blue 'Default 'Red 'Black 'Cyan 'Black 'Yellow +type Color2 = 'OColor "color2" 'Default 'Magenta 'Default 'Red 'Black 'White 'Black 'Yellow +type Color3 = 'OColor "color3" 'Default 'Blue 'Red 'Default 'White 'Default 'Black 'Yellow +type Color4 = 'OColor "color4" 'Default 'Red 'Red 'Default 'Green 'Default 'Black 'Yellow +type Color5 = 'OColor "color5" 'Blue 'Default 'Red 'Default 'Cyan 'Default 'Yellow 'Default + +type Other1 = 'OOther 'True 'Yellow 'Default +type Other2 = 'OOther 'True 'Default 'Default + +show3 :: (Show a1, Show a2) + => POpts + -> String + -> a1 + -> a2 + -> String +show3 opts msg0 ret = lit3 opts msg0 ret "" . show + +show3' :: (Show a1, Show a2) + => POpts + -> String + -> a1 + -> String + -> a2 + -> String +show3' opts msg0 ret fmt = lit3 opts msg0 ret fmt . show + +lit3 :: Show a1 + => POpts + -> String + -> a1 + -> String + -> String + -> String +lit3 opts msg0 ret fmt as + | null fmt && null as = msg0 + | otherwise = + msg0 + <> (if null msg0 then "" else " ") + <> showL opts ret + <> litVerbose opts (" | " <> take 100 fmt) as + +-- | 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 o i s a = + if oDebug o >= i || oDebug o == DLite then take 100 s <> litL o a + else "" + +showVerbose :: Show a + => POpts + -> String + -> a + -> String +showVerbose o = showAImpl o DVerbose + +showAImpl :: Show a + => POpts + -> Debug + -> String + -> a + -> String +showAImpl o i s a = showLitImpl o i (take 100 s) (show a) + +showL :: Show a + => POpts + -> a + -> String +showL o = litL o . show + +litL :: POpts -> String -> String +litL = litL' . oWidth + +litL' :: Int -> String -> String +litL' i s = + let z = take i s + in z ++ if length z >= i then "..." else "" + +litBL :: POpts -> BL8.ByteString -> String +litBL o s = + let i = oWidth o + in litL' i (BL8.unpack (BL8.take (fromIntegral i) s)) + +litBS :: POpts -> BS8.ByteString -> String +litBS o s = + let i = oWidth o + in litL' i (BS8.unpack (BS8.take i s)) + +-- | extract values from the trees or if there are errors return a tree with context +splitAndAlign :: Show x => + POpts + -> String + -> [((Int, x), TT a)] + -> Either (TT w) [(a, (Int, x), TT a)] +splitAndAlign opts msgs ts = + case partitionEithers (map partitionTTExtended ts) of + (excs@(e:_), _) -> + Left $ mkNode opts + (Fail (groupErrors (map snd excs))) + (msgs <> (formatList opts [fst e] <> " excnt=" <> show (length excs))) + (map (hh . snd) ts) + ([], tfs) -> Right tfs + +groupErrors :: [String] -> String +groupErrors = + intercalate " | " + . map (\xs@(x :| _) -> x <> (if length xs > 1 then "(" <> show (length xs) <> ")" else "")) + . N.group + +partitionTTExtended :: (w, TT a) -> Either ((w, TT x), String) (a, w, TT a) +partitionTTExtended (s, t) = + case _ttVal t of + Fail e -> Left ((s, t & ttVal .~ Fail e), e) + Val a -> Right (a,s,t) + +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 <> ")") + +-- | pretty print a tree +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 + else colorValP Long opts (_peValP bpe) <> " " <> _peString bpe + +hasNoTree :: POpts -> Bool +hasNoTree opts = + case oDebug opts of + DZero -> True + DLite -> True + DNormal -> False + DVerbose -> False + +-- | render 'ValP' value with colors +colorValP :: + Long + -> POpts + -> ValP + -> String +colorValP long o bp = + case bp of + FailP e -> case long of + Long -> "[" <> f "Error" <> nullSpace e <> "]" + Short -> f "Failed" + FalseP -> f "False" + TrueP -> f "True" + ValP -> f "P" + where f = colorMe o bp + +data Long = Long | Short deriving (Show, Eq) + +-- | render 'Val' value with colors +colorValLite :: Show a + => POpts + -> (Val a, ValP) + -> String +colorValLite o (bt,bp') = + let f = colorMe o bp + bp = validateValP bp' bt + in case bt of + Fail e -> f "Error" <> " " <> e + Val a -> case bp of + FalseP -> f "False" + TrueP -> f "True" + ValP -> f "Present" <> " " <> show a + FailP {} -> errorInProgram $ "colorValLite: unexpected FailP " ++ show (bt,bp) + +colorValBool :: + POpts + -> Val Bool + -> String +colorValBool o r = + let f = colorMe o (r ^. val2PBool) + in case r of + Fail e -> f "Fail" <> " " <> e + Val False -> f "False" + Val True -> f "True" + +-- | colors the result of the predicate based on the current color palette +colorMe :: + POpts + -> ValP + -> String + -> String +colorMe o b s = + let (_, f) | oNoColor o = nocolor + | otherwise = oColor o + in coerce f b s + +-- | display tree +prtTreePure :: + POpts + -> Tree PE + -> String +prtTreePure opts t + | hasNoTree opts = colorValP Long opts (t ^. root . peValP) + | otherwise = showTreeImpl opts $ fmap (toNodeString opts) t + +showTreeImpl :: POpts + -> Tree String + -> String +showTreeImpl o = + case oDisp o of + Unicode -> drawTreeU + Ansi -> Safe.initSafe . drawTree -- to drop the last newline else we have to make sure that everywhere else has that newline + +-- | extract message part from tree +topMessage :: TT a -> String +topMessage pp = + let s = _ttString pp + in unlessNull s $ "(" <> s <> ")" + +-- | render numbered tree +prefixNumberToTT :: ((Int, x), TT a) -> TT a +prefixNumberToTT ((i, _), t) = prefixMsg ("i=" <> show i <> ": ") t + +-- | prefix text in front of ttString +prefixMsg :: String -> TT a -> TT a +prefixMsg msg = ttString %~ (msg <>) + +-- | a typeclass for choosing which monad to run in +-- +-- >>> hasIO @IO +-- True +-- +-- >>> hasIO @Identity +-- False +-- + +class Monad m => MonadEval m where + runIO :: IO a -> m (Maybe a) + catchit :: a -> m (Either String a) + catchitNF :: NFData a => a -> m (Either String a) + liftEval :: m a -> IO a + hasIO :: Bool + hasIO = False + +-- | 'Identity' instance for evaluating the expression +instance MonadEval Identity where + runIO _ = Identity Nothing + catchit = catchitIdentityUnsafe + catchitNF = catchitNFIdentityUnsafe + liftEval = return . runIdentity + + +{-# NOINLINE catchitIdentityUnsafe #-} +catchitIdentityUnsafe :: a -> Identity (Either String a) +catchitIdentityUnsafe v = Identity $ unsafePerformIO $ catchit @IO v + +{-# NOINLINE catchitNFIdentityUnsafe #-} +catchitNFIdentityUnsafe :: NFData a => a -> Identity (Either String a) +catchitNFIdentityUnsafe v = Identity $ unsafePerformIO $ catchitNF @IO v + + +-- | 'IO' instance for evaluating the expression +instance MonadEval IO where + runIO ioa = Just <$> ioa + catchit v = E.evaluate (Right $! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) + catchitNF v = E.evaluate (Right $!! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) + liftEval = id + hasIO = True + +-- composite types are used instead of type synonyms as showT (typeRep) unrolls the definition +-- eg sqlhandler.encode/decode and parsejson* etc +-- | Display options +data Opt = + OEmpty -- ^ mempty + | OWidth !Nat -- ^ set display width + | OMsg !Symbol -- ^ set text to add context to a failure message for refined types + | ORecursion !Nat -- ^ set recursion limit eg for regex + | OOther -- ^ set effects for messages + !Bool -- ^ set underline + !Color -- ^ set foreground color + !Color -- ^ set background color + | !Opt :# !Opt -- ^ mappend + | OColor -- ^ set color palette + !Symbol -- ^ name of color palette + !Color -- ^ Fail foreground color + !Color -- ^ Fail background color + !Color -- ^ False foreground color + !Color -- ^ False background color + !Color -- ^ True foreground color + !Color -- ^ True background color + !Color -- ^ Present foreground color + !Color -- ^ Present background color + | OColorOn -- ^ turn on colors + | OColorOff -- ^ turn off colors + | OAnsi -- ^ ansi display + | OUnicode -- ^ unicode display + | OZero -- ^ debug mode return nothing + | OLite -- ^ debug mode return one line + | ONormal -- ^ debug mode normal + | OVerbose -- ^ debug mode verbose + | OZ -- ^ composite: no messages + | OL -- ^ composite: lite version + | OA -- ^ composite: ansi + colors + | OAB -- ^ composite: ansi + colors + background + | OAN -- ^ composite: ansi + no colors + | OAV -- ^ composite: ansi + colors + verbose + | OANV -- ^ composite: ansi + no colors + verbose + | OU -- ^ composite: unicode + colors + | OUB -- ^ composite: unicode + colors + background + | OUN -- ^ composite: unicode + no colors + | OUV -- ^ composite: unicode + colors + verbose + | OUNV -- ^ composite: unicode + no colors + verbose + +infixr 6 :# +-- | extract options from the typelevel +class OptC (k :: Opt) where + getOptC :: HOpts Last +instance KnownNat n => OptC ('OWidth n) where + getOptC = setWidth (nat @n) +instance KnownSymbol s => OptC ('OMsg s) where + getOptC = setMessage (symb @s) +instance KnownNat n => OptC ('ORecursion n) where + getOptC = setRecursion (nat @n) +instance ( GetBool b + , GetColor c1 + , GetColor c2 + ) => OptC ('OOther b c1 c2) where + getOptC = setOther (getBool @b) (getColor @c1) (getColor @c2) +instance OptC 'OEmpty where + getOptC = mempty +instance ( OptC a + , OptC b + ) => OptC (a ':# b) where + getOptC = getOptC @a <> getOptC @b +instance ( KnownSymbol s + , GetColor c1 + , GetColor c2 + , GetColor c3 + , GetColor c4 + , GetColor c5 + , GetColor c6 + , GetColor c7 + , GetColor c8) + => OptC ('OColor s c1 c2 c3 c4 c5 c6 c7 c8) where + getOptC = setCreateColor + (symb @s) + (getColor @c1) + (getColor @c2) + (getColor @c3) + (getColor @c4) + (getColor @c5) + (getColor @c6) + (getColor @c7) + (getColor @c8) +instance OptC 'OColorOn where + getOptC = setNoColor False +instance OptC 'OColorOff where + getOptC = setNoColor True +instance OptC 'OAnsi where + getOptC = setDisp Ansi +instance OptC 'OUnicode where + getOptC = setDisp Unicode +instance OptC 'OZero where + getOptC = setDebug DZero +instance OptC 'OLite where + getOptC = setDebug DLite +instance OptC 'ONormal where + getOptC = setDebug DNormal +instance OptC 'OVerbose where + getOptC = setDebug DVerbose +instance OptC 'OZ where + getOptC = setDisp Ansi <> setNoColor True <> setDebug DZero +instance OptC 'OL where + getOptC = setDisp Ansi <> setNoColor True <> setDebug DLite <> setWidth 200 +instance OptC 'OA where + getOptC = setDisp Ansi <> getOptC @Color5 <> setDebug DNormal <> getOptC @Other2 <> setWidth 100 +instance OptC 'OAB where + getOptC = setDisp Ansi <> getOptC @Color1 <> setDebug DNormal <> getOptC @Other1 <> setWidth 100 +instance OptC 'OAN where + getOptC = setDisp Ansi <> setNoColor True <> setDebug DNormal <> setWidth 100 +instance OptC 'OAV where + getOptC = getOptC @('OA ':# 'OVerbose ':# 'OWidth 200) +instance OptC 'OANV where + getOptC = setDisp Ansi <> setNoColor True <> setDebug DVerbose <> setWidth 200 +instance OptC 'OU where + getOptC = getOptC @('OA ':# 'OUnicode) +instance OptC 'OUB where + getOptC = getOptC @('OAB ':# 'OUnicode) +instance OptC 'OUN where + getOptC = getOptC @('OAN ':# 'OUnicode) +instance OptC 'OUV where + getOptC = getOptC @('OAV ':# 'OUnicode) +instance OptC 'OUNV where + getOptC = getOptC @('OANV ':# 'OUnicode) + +-- | option synonyms to save a keystroke +type OZ = 'OZ -- 'OAnsi ':# 'OColorOff ':# 'OZero +type OL = 'OL -- 'OAnsi ':# 'OColorOff ':# 'OLite ':# 'OWidth 200 +type OA = 'OA -- 'OAnsi ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100 +type OAB = 'OAB -- 'OAnsi ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100 +type OAN = 'OAN -- 'OAnsi ':# 'OColorOff ':# 'ONormal ':# 'OWidth 100 +type OAV = 'OAV -- 'OAnsi ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200 +type OANV = 'OANV -- 'OAnsi ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200 +type OU = 'OU -- 'OUnicode ':# Color5 ':# 'ONormal ':# Other2 ':# 'OWidth 100 +type OUB = 'OUB -- 'OUnicode ':# Color1 ':# 'ONormal ':# Other1 ':# 'OWidth 100 +type OUN = 'OUN -- 'OUnicode ':# 'OColorOff ':# 'OWidth 200 +type OUV = 'OUV -- 'OUnicode ':# Color5 ':# 'OVerbose ':# Other2 ':# 'OWidth 200 +type OUNV = 'OUNV -- 'OUnicode ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200 + +_Debug :: Lens' POpts Debug +_Debug afb opts = (\d -> opts { oDebug = d }) <$> afb (oDebug opts) + +_DVerboseI :: Prism' Debug () +_DVerboseI = + prism' (const DVerbose) + $ \case + DVerbose -> Just () + _ -> Nothing + +-- | traversal for DVerbose +-- +-- >>> has _DVerbose (getOpt @OU) +-- False +-- +-- >>> has _DVerbose (getOpt @OUV) +-- True +-- +_DVerbose :: Traversal' POpts () +_DVerbose = _Debug . _DVerboseI + +-- | convert typelevel options to 'POpts' +-- +-- >>> (oDisp &&& fst . oColor &&& oWidth) (getOpt @(OA ':# OU ':# OA ':# 'OWidth 321 ':# Color4 ':# 'OMsg "test message")) +-- (Ansi,("color4",321)) +-- +-- >>> oMsg (getOpt @('OMsg "abc" ':# 'OMsg "def")) +-- ["abc","def"] +-- +-- >>> oOther (getOpt @('OOther 'False 'Red 'White ':# 'OOther 'True 'Red 'Black)) +-- (True,Red,Black) +-- +-- >>> a = show (getOpt @('OEmpty ':# OU)) +-- >>> b = show (getOpt @(OU ':# 'OEmpty)); +-- >>> c = show (getOpt @OU) +-- >>> a==b && b==c +-- True +-- +getOpt :: forall o . OptC o => POpts +getOpt = reifyOpts (getOptC @o) + +-- | deal with possible recursion on a list +chkSize :: Foldable t + => POpts + -> String + -> t a + -> [Tree PE] + -> Either (TT x) [a] +chkSize opts msg0 xs hhs = + let mx = oRecursion opts + in case splitAt mx (toList xs) of + (zs,[]) -> Right zs + (_,_:_) -> Left $ mkNode opts (Fail (msg0 <> " list size exceeded")) ("max is " ++ show mx) hhs + +-- | deal with possible recursion on two lists +chkSize2 :: (Foldable t, Foldable u) + => POpts + -> String + -> t a + -> u b + -> [Tree PE] + -> Either (TT x) ([a],[b]) +chkSize2 opts msg0 xs ys hhs = + (,) <$> chkSize opts msg0 xs hhs <*> chkSize opts msg0 ys hhs + +-- | pretty print a message +formatOMsg :: POpts -> String -> String +formatOMsg o suffix = + case oMsg o of + [] -> mempty + s@(_:_) -> intercalate " | " (map (setOtherEffects o) s) <> suffix + +-- | override options for 'DZero' so we dont lose error information +subopts :: POpts -> POpts +subopts opts = + case oDebug opts of + DZero -> opts { oDebug = DLite } + _ -> opts + +-- | render a string for messages using optional color and underline +setOtherEffects :: POpts -> String -> String +setOtherEffects o = + if oNoColor o then id + else case coerce (oOther o) of + (False, Default, Default) -> id + (b, c1, c2) -> (if b then C.style C.Underline else id) . C.color c1 . C.bgColor c2 + +-- | mconcat 'Opt' options at the type level +-- +-- >>> x = getOpt @(OptT '[ 'OMsg "test", 'ORecursion 123, OU, OL, 'OMsg "field2"]) +-- >>> oMsg x +-- ["test","field2"] +-- >>> oRecursion x +-- 123 +-- +type family OptT (xs :: [Opt]) where + OptT '[] = 'OEmpty + OptT (x ': xs) = x ':# OptT xs + +-- | message to display when the length of a foldable is exceeded +badLength :: Foldable t + => t a + -> Int + -> String +badLength as n = ":invalid length(" <> show (length as) <> ") expected " ++ show n + +prtTree :: Show x => POpts -> TT x -> String +prtTree opts tt = + case oDebug opts of + DZero -> "" + + DLite -> + formatOMsg opts " >>> " + <> colorValLite opts ((_ttVal &&& _ttValP) tt) + <> " " + <> topMessage tt + + _ -> formatOMsg opts "" + <> prtTreePure opts (hh tt) + +verboseList :: POpts -> TT a -> [Tree PE] +verboseList o tt + | isVerbose o = [hh tt] + | otherwise = [] + +-- | prism for Val True +-- +-- >>> Val True ^? _True +-- Just () +-- +-- >>> Val False ^? _True +-- Nothing +-- +_True :: a ~ Bool => Prism' (Val a) () +_True = + prism' (const (Val True)) + $ \case + Val True -> Just () + Val False -> Nothing + Fail {} -> Nothing + +-- | prism for Val False +-- +-- >>> (_True # ()) ^? _True +-- Just () +-- +-- >>> (_False # ()) ^? _False +-- Just () +-- +-- >>> Val False ^? _False +-- Just () +-- +-- >>> Val True ^? _False +-- Nothing +-- +_False :: a ~ Bool => Prism' (Val a) () +_False = + prism' (const (Val False)) + $ \case + Val False -> Just () + Val True -> Nothing + Fail {} -> Nothing + +-- | iso for 'Val' +-- +-- >>> Val 123 ^. _ValEither +-- Right 123 +-- +-- >>> Val 123 & _ValEither %~ right' (show . succ) +-- Val "124" +-- +-- >>> Fail "abc" & _ValEither %~ ((<>"def") +++ (show . succ)) +-- Fail "abcdef" +-- +-- >>> Right 1.2 & from _ValEither %~ fmap (show . (*10)) +-- Right "12.0" +-- +-- >>> Val True ^. _ValEither +-- Right True +-- +-- >>> Fail "abc" ^. _ValEither +-- Left "abc" +-- +-- >>> Left "abc" ^. from _ValEither +-- Fail "abc" +-- +-- >>> _ValEither # Right False +-- Val False +-- +-- >>> [Just (Val 'x')] ^. mapping (mapping _ValEither) +-- [Just (Right 'x')] +-- +-- >>> Just (Fail "abcd") ^. mapping _ValEither +-- Just (Left "abcd") +-- +_ValEither :: Iso (Val a) (Val b) (Either String a) (Either String b) +_ValEither = iso fw bw + where fw = \case + Val a -> Right a + Fail e -> Left e + bw = either Fail Val + +-- | a lens from typed 'Val' to the untyped 'ValP' +-- +-- >>> Val True ^. val2P +-- ValP +-- +-- >>> Val 123 ^. val2P +-- ValP +-- +-- >>> Fail "abc" ^. val2P +-- FailP "abc" +-- +val2P :: Lens' (Val a) ValP +val2P afb bt = bt <$ afb r + where r = case bt of + Fail e -> FailP e + Val {} -> ValP + +-- | a lens from typed 'Val' Bool to the untyped 'ValP' +-- +-- >>> Val True ^. val2PBool +-- TrueP +-- +-- >>> Val False ^. val2PBool +-- FalseP +-- +-- >>> Fail "abc" ^. val2PBool +-- FailP "abc" +-- +val2PBool :: a ~ Bool => Lens' (Val a) ValP +val2PBool afb bt = bt <$ afb r + where r = case bt of + Fail e -> FailP e + Val True -> TrueP + Val False -> FalseP + +-- | lens that keeps ValP in sync with Val for TT Bool +-- +-- >>> (TT ValP (Val True) "xxx" [] & ttValBool %~ \b -> fmap not b) == TT FalseP (Val False) "xxx" [] +-- True +-- +-- >>> (TT ValP (Val True) "xxx" [] & ttValBool .~ Fail "abc") == TT (FailP "abc") (Fail "abc") "xxx" [] +-- True +-- +-- >>> (TT ValP (Val True) "xxx" [] & ttValBool %~ id) == TT TrueP (Val True) "xxx" [] +-- True +-- +-- >>> (TT FalseP (Val True) "xxx" [] & ttValBool %~ id) == TT TrueP (Val True) "xxx" [] +-- True +-- +ttValBool :: a ~ Bool => Lens' (TT a) (Val Bool) +ttValBool afb tt = (\b -> tt { _ttValP = f b, _ttVal = b }) <$> afb (_ttVal tt) + where f = \case + Fail e -> FailP e + Val True -> TrueP + Val False -> FalseP + +-- | lens from TT to Val that also keeps ValP in sync with Val +-- +-- >>> (TT FalseP (Val True) "xxx" [] & ttVal %~ id) == TT ValP (Val True) "xxx" [] +-- True +-- +-- >>> (TT FalseP (Val 123) "xxx" [] & ttVal .~ Fail "aa") == TT (FailP "aa") (Fail "aa") "xxx" [] +-- True +-- +-- >>> (TT (FailP "sdf") (Val 123) "xxx" [] & ttVal %~ fmap show) == TT ValP (Val "123") "xxx" [] +-- True +-- +ttVal :: Lens (TT a) (TT b) (Val a) (Val b) +ttVal afb tt = (\b -> tt { _ttValP = f b, _ttVal = b }) <$> afb (_ttVal tt) + where f = \case + Fail e -> FailP e + Val {} -> ValP +
src/Predicate/Util_TH.hs view
@@ -1,26 +1,19 @@--- stack exec -- ghc-pkg unregister ghc-lib-parser-8.8.0.20190424 --force -{-# OPTIONS -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE NoStarIsType #-} -{- | - Template Haskell methods for creating Refined, Refined2, and Refined3 refinement types --} -module Predicate.Util_TH - ( +-- | Template Haskell methods for creating Refined, Refined2, and Refined3 refinement types +module Predicate.Util_TH ( -- ** Refined refinedTH , refinedTHIO - -- ** Refined1 - , refined1TH - -- ** Refined2 , refined2TH , refined2THIO @@ -28,16 +21,21 @@ -- ** Refined3 , refined3TH , refined3THIO + + -- ** Refined5 + , refined5TH + , refined5THIO + ) where import Predicate.Util +import Predicate.Misc import Predicate.Core import Predicate.Refined -import Predicate.Refined1 import Predicate.Refined2 import Predicate.Refined3 +import Predicate.Refined5 import qualified Language.Haskell.TH.Syntax as TH -import Data.Functor.Identity -- $setup -- >>> :set -XDataKinds @@ -48,54 +46,31 @@ -- | creates a 'Refined.Refined' refinement type -- --- >>> $$(refinedTH 123) :: Refined OZ (Between 100 125 Id) Int +-- >>> $$(refinedTH 123) :: Refined OL (Between 100 125 Id) Int -- Refined 123 -- -- @ --- >$$(refinedTH 99) :: Refined OZ (Between 100 125 Id) Int +-- >$$(refinedTH 99) :: Refined OL (Between 100 125 Id) Int -- -- <interactive>:8:4: error: --- * refinedTH: predicate failed with FalseP (100 <= 99) +-- * refinedTH: predicate failed with False (100 <= 99) -- * In the Template Haskell splice $$(refinedTH 99) -- In the expression: --- $$(refinedTH 99) :: Refined (Between 100 125 Id) Int --- In an equation for \'it\': --- it = $$(refinedTH 99) :: Refined (Between 100 125 Id) Int +-- $$(refinedTH 99) :: Refined OL (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 --- --- <interactive>:116:4: error: --- * --- [Error asdf] lhs failed >> --- | --- `- [Error asdf] Fail asdf --- | --- `- P '"asdf" --- --- refinedTH: predicate failed with FailP "asdf" ((>>) lhs failed) --- * In the Template Haskell splice $$(refinedTH 99) --- In the expression: --- $$(refinedTH 99) :: --- Refined (FailS "asdf" >> Between 100 125 Id) Int --- @ --- refinedTH :: forall opts p i . (TH.Lift i, RefinedC opts p i) => i -> TH.Q (TH.TExp (Refined opts p i)) refinedTH i = let msg0 = "refinedTH" - ((bp,(top,e)),mr) = runIdentity $ newRefinedM @opts @p i - in case mr of - Nothing -> - let msg1 = if hasNoTree (getOptT @opts) then "" else "\n" ++ e ++ "\n" - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ bp ++ " " ++ top - Just r -> TH.TExp <$> TH.lift r + in case newRefined @opts @p i of + Left m -> fail $ refinedFailMsg @opts msg0 m + Right r -> [||r||] refinedTHIO :: forall opts p i . (TH.Lift i, RefinedC opts p i) @@ -103,91 +78,31 @@ -> TH.Q (TH.TExp (Refined opts p i)) refinedTHIO i = do let msg0 = "refinedTHIO" - ((bp,(top,e)),mr) <- TH.runIO (newRefinedM @opts @p i) - case mr of - Nothing -> - let msg1 = if hasNoTree (getOptT @opts) then "" else "\n" ++ e ++ "\n" - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ bp ++ " " ++ top - Just r -> TH.TExp <$> TH.lift r - --- | creates a 'Refined1.Refined1' refinement type --- --- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int --- Refined1 100 --- --- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int --- Refined1 100 --- --- >>> $$(refined1TH 100) :: Refined1 OZ Id (Between 100 125 Id) Id Int --- Refined1 100 --- --- @ --- >$$(refined1TH 99) :: Refined1 OZ Id (Between 100 125 Id) Id Int --- --- <interactive>:127:4: error: --- * --- *** Step 1. Success Initial Conversion(ip) (99) *** --- --- P Id 99 --- --- *** Step 2. False Boolean Check(op) *** --- --- False 100 <= 99 --- | --- +- P Id 99 --- | --- +- P '100 --- | --- `- P '125 --- --- 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 --- In an equation for \'it\': --- 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) - => i - -> TH.Q (TH.TExp (Refined1 opts ip op fmt i)) -refined1TH i = - let msg0 = "refined1TH" - o = getOptT @opts - (ret,mr) = eval1 @opts @ip @op @fmt i - in case mr of - Nothing -> - let m1 = prt1Impl o ret - msg1 = if hasNoTree o then "" else m1Long m1 ++ "\n" - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ (m1Desc m1 <> " | " <> m1Short m1) - Just r -> TH.TExp <$> TH.lift r + lr <- TH.runIO (newRefined' i) + case lr of + Left m -> fail $ refinedFailMsg @opts msg0 m + Right r -> [||r||] +refinedFailMsg :: forall opts . OptC opts => String -> Msg0 -> String +refinedFailMsg msg m = + let msg1 | hasNoTree (getOpt @opts) || null (m0Long m) = "" + | otherwise = nullIf "\n" (m0Long m) + in msg ++ ": predicate failed with " ++ m0ValBoolColor m ++ " " ++ m0Short m ++ msg1 -- | creates a 'Refined2.Refined2' refinement type -- --- >>> $$(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 --- Refined2 {r2In = 100, r2Out = 100} +-- Refined2 100 100 -- -- @ -- >$$(refined2TH 99) :: Refined2 OAN Id (Between 100 125 Id) Int -- -- <interactive>:127:4: error: --- * +-- * Step 2. False Boolean Check(op) | {100 <= 99} -- *** Step 1. Success Initial Conversion(ip) (99) *** --- -- P Id 99 --- -- *** Step 2. False Boolean Check(op) *** --- --- False 100 <= 99 +-- Present False 100 <= 99 -- | -- +- P Id 99 -- | @@ -195,67 +110,53 @@ -- | -- `- P '125 -- --- 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 --- In an equation for \'it\': --- it = $$(refined2TH 99) :: Refined2 OZ Id (Between 100 125 Id) Id Int +-- $$(refined2TH 99) :: Refined2 OAN Id (Between 100 125 Id) Int -- @ -- refined2TH :: forall opts ip op i - . ( Show (PP ip i) + . ( Refined2C opts ip op i , TH.Lift i , TH.Lift (PP ip i) - , Refined2C opts ip op i + , Show (PP ip i) ) => i -> TH.Q (TH.TExp (Refined2 opts ip op i)) refined2TH i = - let msg0 = "refined2TH" - o = getOptT @opts - (ret,mr) = eval2 @opts @ip @op i - in case mr of - Nothing -> - let m2 = prt2Impl o ret - msg1 = if hasNoTree o then "" else m2Long m2 ++ "\n" - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ (m2Desc m2 <> " | " <> m2Short m2) - Just r -> TH.TExp <$> TH.lift r + case newRefined2 i of + Left e -> fail $ show e + Right r -> [||r||] +-- | creates a 'Refined2.Refined2' refinement type using IO refined2THIO :: forall opts ip op i - . ( Show (PP ip i) - , TH.Lift i + . ( TH.Lift i , TH.Lift (PP ip i) , Refined2C opts ip op i + , Show (PP ip i) ) => i -> TH.Q (TH.TExp (Refined2 opts ip op i)) refined2THIO i = do - x <- TH.runIO (eval2M @opts @ip @op i) + x <- TH.runIO (newRefined2' i) case x of - (_, Just a) -> TH.TExp <$> TH.lift a - (ret, Nothing) -> fail $ show $ prt2Impl (getOptT @opts) ret + Left e -> fail $ show e + Right r -> [||r||] -- | creates a 'Refined3.Refined3' refinement type -- --- >>> $$(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 --- Refined3 {r3In = 100, r3Out = 100} +-- Refined3 100 100 -- -- @ -- >$$(refined3TH 99) :: Refined3 OAN Id (Between 100 125 Id) Id Int -- -- <interactive>:127:4: error: --- * +-- * Step 2. False Boolean Check(op) | {100 <= 99} -- *** Step 1. Success Initial Conversion(ip) (99) *** --- -- P Id 99 --- -- *** Step 2. False Boolean Check(op) *** --- --- False 100 <= 99 +-- Present False 100 <= 99 -- | -- +- P Id 99 -- | @@ -263,49 +164,91 @@ -- | -- `- P '125 -- --- 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 --- In an equation for \'it\': --- 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") --- Refined3 {r3In = [200,2,3,4], r3Out = "200.002.003.004"} +-- >>> $$(refined3TH @OL @(Resplit "\\." >> Map (ReadP Int Id)) @(All (0 <..> 0xff) && Len == 4) @(PrintL 4 "%03d.%03d.%03d.%03d" Id) "200.2.3.4") +-- Refined3 [200,2,3,4] "200.002.003.004" -- refined3TH :: forall opts ip op fmt i - . ( Show i - , Show (PP ip i) + . ( Refined3C opts ip op fmt i , TH.Lift i , TH.Lift (PP ip i) - , Refined3C opts ip op fmt i + , Show (PP ip i) ) => i -> TH.Q (TH.TExp (Refined3 opts ip op fmt i)) refined3TH i = - let msg0 = "refined3TH" - (ret,mr) = eval3 @opts @ip @op @fmt i - in case mr of - Nothing -> - let m3 = prt3Impl o ret - o = getOptT @opts - msg1 = if hasNoTree o then "" else m3Long m3 ++ "\n" - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ (m3Desc m3 <> " | " <> m3Short m3) - Just r -> TH.TExp <$> TH.lift r + case newRefined3 i of + Left e -> fail $ show e + Right r -> [||r||] +-- | creates a 'Refined3.Refined3' refinement type using IO refined3THIO :: forall opts ip op fmt i - . ( Show i - , Show (PP ip i) - , TH.Lift i + . ( TH.Lift i , TH.Lift (PP ip i) , Refined3C opts ip op fmt i + , Show (PP ip i) ) => i -> TH.Q (TH.TExp (Refined3 opts ip op fmt i)) refined3THIO i = do - x <- TH.runIO (eval3M @opts @ip @op @fmt i) + x <- TH.runIO (newRefined3' i) case x of - (_, Just a) -> TH.TExp <$> TH.lift a - (ret, Nothing) -> fail $ show $ prt3Impl (getOptT @opts) ret + Left e -> fail $ show e + Right r -> [||r||] + +-- | creates a 'Refined5.Refined5' refinement type +-- +-- >>> $$(refined5TH 100) :: Refined5 OAN Id (Between 100 125 Id) Int +-- Refined5 100 +-- +-- @ +-- >$$(refined5TH 99) :: Refined5 OAN Id (Between 100 125 Id) Int +-- +-- <interactive>:127:4: error: +-- * Step 2. False Boolean Check(op) | {100 <= 99} +-- *** Step 1. Success Initial Conversion(ip) (99) *** +-- P Id 99 +-- *** Step 2. False Boolean Check(op) *** +-- Present False 100 <= 99 +-- | +-- +- P Id 99 +-- | +-- +- P '100 +-- | +-- `- P '125 +-- +-- * In the Template Haskell splice $$(refined5TH 99) +-- In the expression: +-- $$(refined5TH 99) :: Refined5 OAN Id (Between 100 125 Id) Int +-- @ +-- +refined5TH :: forall opts ip op i + . ( Refined2C opts ip op i + , TH.Lift (PP ip i) + , Show (PP ip i) + ) + => i + -> TH.Q (TH.TExp (Refined5 opts ip op i)) +refined5TH i = + case newRefined5 i of + Left e -> fail $ show e + Right r -> [||r||] + +-- | creates a 'Refined5.Refined5' refinement type using IO +refined5THIO :: forall opts ip op i + . ( TH.Lift (PP ip i) + , Refined2C opts ip op i + , Show (PP ip i) + ) + => i + -> TH.Q (TH.TExp (Refined5 opts ip op i)) +refined5THIO i = do + x <- TH.runIO (newRefined5' i) + case x of + Left e -> fail $ show e + Right r -> [||r||]
test/TastyExtras.hs view
@@ -1,7 +1,4 @@-{-# OPTIONS -Wall #-} {-# OPTIONS -Wno-compat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} @@ -9,7 +6,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoOverloadedLists #-} -- overloaded lists breaks some predicates {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoStarIsType #-} @@ -21,6 +17,13 @@ import Data.List import Text.Show.Functions () +expectIO' :: (HasCallStack, Show a, Show e) => IO (Either e a) -> (Either e a -> Either e ()) -> IO () +expectIO' iolr p = do + lr <- iolr + case p lr of + Left e -> assertFailure $ "expectIO: " <> show e <> " lr=" <> show lr + Right () -> pure () + expectIO :: (HasCallStack, Show a) => IO (Either String a) -> (Either String a -> Either String ()) -> IO () expectIO iolr p = do lr <- iolr @@ -50,8 +53,8 @@ orderTests :: String -> [Assertion] -> [TestTree] orderTests s = zipWith (\i -> testCase (s <> "_" <> show i)) [1::Int ..] -expectPE :: (Show a, Eq a, HasCallStack) => BoolT a -> IO (BoolT a) -> IO () -expectPE bp m = do +expectBT :: (Show a, Eq a, HasCallStack) => Val a -> IO (Val a) -> IO () +expectBT bp m = do x <- m print (x,bp) x @?= bp
test/TestJson.hs view
@@ -1,7 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} @@ -14,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoStarIsType #-} module TestJson where +--module TestJson (suite) where import TastyExtras import Test.Tasty import Test.Tasty.HUnit @@ -26,32 +23,33 @@ import Data.Aeson import qualified Data.ByteString as BS import Control.Lens +import qualified Safe (readNote) 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 "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 "testperson1 ok" $ expectIO (testPerson1 @OAN 2) (() <$) + , testCase "testperson1 bad ipaddress" $ expectIO (testPerson1 @OAN 3) (expectLeftWith ["octet 3 out of range 0-255 found 260"]) + , testCase "testperson1 bad lastname lowercase first letter" $ expectIO (testPerson1 @OAN 4) (expectLeftWith ["lastName1", "invalid name", "diaz"]) + , testCase "testperson1 bad first name lowercase first letter" $ expectIO (testPerson1 @OAN 6) (expectLeftWith ["firstName1", "not upper first(d)"]) + , testCase "testperson1 age 99 out of range" $ expectIO (testPerson1 @OAN 5) (expectLeftWith ["Error in $[0].age1"]) + , testCase "parse fail person1" $ expectBT (Fail "ParseJsonFile [Person1 'OZ](test3.json) Error in $[0].ipaddress1: Refined3:Step 2. Failed Boolean Check(op) | octet 3 out of range 0-255 found 260") $ pz @(ParseJsonFile [Person1 'OZ] "test3.json") () + , testCase "parse ok person1" $ expectBT (Val 5) $ pl @(ParseJsonFile [Person1 OAN] "test2.json" >> Len) () + , testCase "missing file" $ expectBT (Fail "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 ^? _PresentT . to (unRefined . age1)) @=? Just 45 - (x ^? _PresentT . to (R3.r3Out . ipaddress1)) @=? Just "124.001.012.223" + x <- pz @(ParseJsonFile [Person1 OAN] "test2.json" >> Id !! 2) () + (x ^? _Val . to (unRefined . age1)) @?= Just 45 + (x ^? _Val . to (R3.r3Out . ipaddress1)) @?= Just "124.001.012.223" , testCase "getRow2" $ do - 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"}) + x <- pz @(ParseJsonFile [Person1 OAN] "test2.json" >> Id !! 2) () + x @?= Val (Person1 {firstName1 = unsafeRefined "John", lastName1 = unsafeRefined "Doe", age1 = unsafeRefined 45, likesPizza1 = False, date1 = R3.unsafeRefined3 (Safe.readNote "testjson: utc date" "2003-01-12 04:05:33 UTC") "2003-01-12 04:05:33", ipaddress1 = R3.unsafeRefined3 [124,1,12,223] "124.001.012.223"}) ] testPerson :: IO (Either String [Person]) testPerson = eitherDecodeStrict' <$> BS.readFile "test1.json" -testPerson1 :: forall opts . OptTC opts => Int -> IO (Either String [Person1 opts]) +testPerson1 :: forall opts . OptC opts => Int -> IO (Either String [Person1 opts]) testPerson1 i = do let fn = "test" ++ show i ++ ".json" eitherDecodeStrict' <$> BS.readFile fn @@ -60,35 +58,43 @@ firstName :: !Text , lastName :: !Text , age :: !Int - , likesPizza :: Bool + , likesPizza :: !Bool } deriving (Show,Generic,Eq) instance ToJSON Person instance FromJSON Person -data Person1 (opts :: OptT) = Person1 { - firstName1 :: NameR2 (opts ':# 'OMsg "person1 firstname1") - , lastName1 :: NameR1 (opts ':# 'OMsg "person1 lastname1") - , age1 :: AgeR (opts ':# 'OMsg "age1 errors") - , likesPizza1 :: Bool - , date1 :: R3.DateTimeNR (opts ':# 'OMsg "person date1") - , ipaddress1 :: R3.Ip4R (opts ':# 'OMsg "ipaddress1 errors") +data Person1 (opts :: Opt) = Person1 { + firstName1 :: !(NameR2 (opts ':# 'OMsg "person1 firstname1")) + , lastName1 :: !(NameR1 (opts ':# 'OMsg "person1 lastname1")) + , age1 :: !(AgeR (opts ':# 'OMsg "age1 errors")) + , likesPizza1 :: !Bool + , date1 :: !(R3.DateTimeNR (opts ':# 'OMsg "person date1")) + , ipaddress1 :: !(R3.Ip4R (opts ':# 'OMsg "ipaddress1 errors")) } deriving (Show,Generic,Eq) -instance OptTC opts => ToJSON (Person1 opts) -instance OptTC opts => FromJSON (Person1 opts) +instance OptC opts => ToJSON (Person1 opts) +instance OptC opts => FromJSON (Person1 opts) -type NameR1 (opts :: OptT) = R.Refined opts Name1 String -type Name1 = Msg "invalid name:" (Re "^[A-Z][a-z']+$" Id) +type NameR1 (opts :: Opt) = R.Refined opts Name1 String +type Name1 = Msg "invalid name:" (Re "^[A-Z][a-z']+$") -- more specific messages -type NameR2 (opts :: OptT) = R.Refined opts (Name2 >> 'True) String +type NameR2 (opts :: Opt) = R.Refined opts Name2 String type Name2 = Uncons >> Just' - >> Guard (PrintF "not upper first(%c)" Id) IsUpper - *** Guard (PrintF "not lower rest(%s)" Id) IsLowerAll - -type AgeR (opts :: OptT) = R.Refined opts (Between 10 60 Id) Int + >> (Guard (PrintF "not upper first(%c)" Id) IsUpper + *** Guard (PrintF "not lower rest(%s)" Id) IsLowerAll) + >> 'True +{- +type NameR2' (opts :: Opt) = R.Refined opts Name2' String +type Name2' = + Uncons + >> Just' + >> (Fst >> GuardBool (PrintF "not upper first(%c)" Id) IsUpper) + && (Snd >> GuardBool (PrintF "not lower rest(%s)" Id) IsLowerAll) +-} +type AgeR (opts :: Opt) = R.Refined opts (Between 10 60 Id) Int
test/TestPredicate.hs view
@@ -1,7 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# OPTIONS -Wno-type-defaults #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -15,6 +11,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoStarIsType #-} module TestPredicate where +--module TestPredicate (suite) where import TastyExtras import Test.Tasty import Test.Tasty.HUnit @@ -24,13 +21,14 @@ import Data.Typeable import Control.Lens +import Control.Lens.Action import Data.Time import Text.Show.Functions () import qualified Data.Monoid as MM import qualified Data.Semigroup as SG import Data.These import GHC.TypeLits (Nat) - +import qualified GHC.Exts as GE (Any) suite :: TestTree suite = let s = "TestPredicate" @@ -38,127 +36,129 @@ allTests :: [IO ()] allTests = - [ expectPE (PresentT [False,True,True,False]) $ pl @'[Gt 5, Lt 9, Same 4, W 'False] 4 - , expectPE (PresentT [21,19,20,40,60,2]) $ pl @'[Succ Id, Pred Id, Id, Id + Id, Id * 3, Id `Mod` 3] 20 - , expectPE (PresentT [False,False,False,True]) $ pl @(Map (Mod Id 3) (Fst Id) >> Map (Gt 1) Id) ([10,12,3,5],"ss") - , expectPE (PresentT 5) $ pl @(Snd Id >> Snd Id >> Snd Id >> Snd Id >> Id) (9,(1,(2,(3,5)))) - , expectPE (PresentT (-1.0)) $ pl @(Negate Id >> Dup >> First (Succ Id) >> Swap >> Fst Id - Snd Id) 4 - , expectPE (PresentT False) $ pl @(Msg "someval4" (Gt 4 >> Id)) 4 - , expectPE (PresentT ()) $ pl @(Snd Id >> Snd Id >> Snd Id >> Snd Id >> Id) (1,('a',(3,(True,())))) - , expectPE (PresentT True) $ pl @(Thd Id >> Fst Id) (1,2,(True,4)) - , expectPE (PresentT True) $ pl @(Fst (Thd Id)) (1,2,(True,4)) - , expectPE (FailT "failed3") $ pl @((Fst Id >> Failt _ "failed3" >> Le (6 -% 1)) || 'False) ([-5],True) - , expectPE (PresentT [(-999) % 1,10 % 1,20 % 1,(-999) % 1,30 % 1]) $ pl @(Map (Wrap (MM.First _) Id &&& (Pure Maybe (999 -% 1 ) >> Wrap (MM.First _) Id)) Id >> Map SapA Id >> Map ('Just (Unwrap Id)) Id) [Nothing,Just 10,Just 20,Nothing,Just 30] - - , expectPE (PresentT (True,3.4)) $ pl @(Thd Id >> Snd Id >> Fst Id) (1,'a',('x',((True,3.4),999))) - , expectPE (PresentT (True,3.4)) $ pl @(Fst (Snd (Thd Id))) (1,'a',('x',((True,3.4),999))) - , expectPE (PresentT [13,16,17]) $ pl @(Guard "err" (Len > 2) >> Map (Succ Id) Id) [12,15,16] - , expectPE (PresentT 55) $ pl @(Map (Wrap (SG.Sum _) Id) Id >> MConcat Id >> Unwrap Id) [1..10] - , expectPE (PresentT 9) $ pl @((Wrap _ Id *** Wrap (SG.Sum _) Id) >> SapA >> Unwrap Id) (4,5) - , expectPE (PresentT (SG.Sum 9)) $ pl @((Wrap _ Id *** Wrap _ Id) >> SapA) (4,5) - , expectPE (FailT "len is bad") $ pl @Ip6Test "FE80::203:Baff:FE77:326FF" - , expectPE (FailT "not a hex") $ pl @Ip6Test "FE80::203:Baff:GE77:326F" - , expectPE (FailT "count is bad") $ pl @Ip6Test "FE80::203:Baff:FE77:326F:::::" - , expectPE (PresentT [1,2,3,244]) $ pl @(Rescan Ip4RE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id) >> Ip4op) "1.2.3.244" - , expectPE (FailT "octet 1 out of range 0-255 found 256") $ pl @(Rescan Ip4RE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id) >> Ip4op) "1.256.3.244" - , expectPE (FailT "Guards:invalid length(5) expected 4") $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap (Snd Id) Id >> Map (ReadBase Int 10 Id) Id >> Ip4op) "1.22.244.66.77" - , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP Id >> Snd Id >> OneP Id >> ReadBase Int 16 Id >> Succ Id) "\\xfF" - , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x(.{2})$" Id >> OneP Id >> Snd Id >> OneP Id >> ReadBase Int 16 Id >> Succ Id) "\\xfF" - , expectPE (PresentT (("fF",(255,"ff")),False)) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP Id >> Snd Id >> OneP Id >> (Id &&& (ReadBase Int 16 Id >> (Id &&& ShowBase 16 Id))) >> (Id &&& ((Id *** Snd Id) >> Fst Id == Snd Id))) "\\xfF" - , expectPE (PresentT [31,11,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id) >> Ddmmyyyyop) "31-11-1999" - , expectPE (PresentT (TimeOfDay 23 13 59)) $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE Id) >> ReadP TimeOfDay Id) "23:13:59" - , expectPE (FailT "hh:mm:ss regex failed") $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE Id) >> ReadP TimeOfDay Id) "23:13:60" - , expectPE (PresentT (124,["1","2","2"])) $ pl @(Left' >> (Succ Id &&& (Pred Id >> ShowP Id >> Ones Id))) (Left 123) - , expectPE (PresentT (1,("asdf",True))) $ pl @'(1,'("asdf",'True)) () - , expectPE (PresentT (12, False)) $ pl @('These Id (Not Id)) (These 12 True) - --- have to wrap with W cos different kinds - , expectPE TrueT $ pl @('PresentT I >> Not 'FalseT) False - -- IxL "d" doesnt work cos is Text not String - -- use Fromstring - , expectPE (PresentT [7,9,9,2,7,3,9,8,7,1,3]) $ pl @(Map (ReadP Int Id) (Ones Id) >> Guard "checkdigit fail" (Luhn Id)) "79927398713" - , expectPE (FailT "checkdigit fail") $ pl @(Map (ReadP Int Id) (Ones Id) >> Guard "checkdigit fail" (Luhn Id)) "79927398714" - , expectPE (PresentT [10,14,15,9]) $ pl @(MM1 16 >> MM2 16) "aef9" - , expectPE (FailT "invalid base 16") $ pl @(MM1 16 >> MM2 16) "aef9g" - , expectPE (FailT "found empty") $ pl @(MM1 16 >> MM2 16) "" - , expectPE (FailT "0<=x<n") $ pl @(MM2 16) [10,1,17,1,-3,7] - , expectPE (PresentT 70) $ pl @(Luhn' 11) "79927398713" - , expectPE (FailT "expected 71 mod 10 = 0 but found 1") $ pl @(Luhn' 11) "79927398714" + [ expectBT (Val [False,True,True,False]) $ pl @'[Gt 5, Lt 9, Same 4, W 'False] 4 + , expectBT (Val [21,19,20,40,60,2]) $ pl @'[Succ, Pred, Id, Id + Id, Id * 3, Id `Mod` 3] 20 + , expectBT (Val [False,False,False,True]) $ pl @(Map' (Mod Id 3) Fst >> Map (Gt 1)) ([10,12,3,5],"ss") + , expectBT (Val 5) $ pl @(Snd >> Snd >> Snd >> Snd) (9,(1,(2,(3,5)))) + , expectBT (Val (-1.0)) $ pl @(Negate Id >> Dup >> First Succ >> Swap >> Fst - Snd) 4 + , expectBT (Val False) $ pl @(Msg "someval4" (Gt 4 >> Id)) 4 + , expectBT (Val ()) $ pl @(Snd >> Snd >> Snd >> Snd >> Id) (1,('a',(3,(True,())))) + , expectBT (Val ()) $ pl @(L22 >> L22) (1,('a',(3,(True,())))) + , expectBT (Val True) $ pl @L31 (1,2,(True,4)) + , expectBT (Fail "failed3") $ pl @((Fst >> FailT _ "failed3" >> Le (6 -% 1)) || 'False) ([-5],True) + , expectBT (Val [(-999) % 1,10 % 1,20 % 1,(-999) % 1,30 % 1]) $ pl @(Map (Wrap (MM.First _) Id &&& (Pure Maybe (999 -% 1 ) >> Wrap (MM.First _) Id)) >> Map (Fst <> Snd) >> Map ('Just Unwrap)) [Nothing,Just 10,Just 20,Nothing,Just 30] + , expectBT (Val (True,3.4)) $ pl @(Thd >> Snd >> Fst) (1,'a',('x',((True,3.4),999))) + , expectBT (Val [13,16,17]) $ pl @(Guard "err" (Len > 2) >> Map Succ) [12,15,16] + , expectBT (Val 55) $ pl @(Map (Wrap (SG.Sum _) Id) >> MConcat Id >> Unwrap) [1..10] + , expectBT (Val 9) $ pl @((Wrap _ Id *** Wrap (SG.Sum _) Id) >> (Fst <> Snd) >> Unwrap) (4,5) + , expectBT (Val (SG.Sum 9)) $ pl @((Wrap _ Id *** Wrap _ Id) >> (Fst <> Snd)) (4,5) + , expectBT (Fail "len is bad") $ pl @Ip6Test "FE80::203:Baff:FE77:326FF" + , expectBT (Fail "not a hex") $ pl @Ip6Test "FE80::203:Baff:GE77:326F" + , expectBT (Fail "count is bad") $ pl @Ip6Test "FE80::203:Baff:FE77:326F:::::" + , expectBT (Val [1,2,3,244]) $ pl @(Rescan Ip4RE >> OneP >> Map' (ReadBase Int 10) Snd >| Ip4op) "1.2.3.244" + , expectBT (Fail "octet 1 out of range 0-255 found 256") $ pl @(Rescan Ip4RE >> OneP >> Map' (ReadBase Int 10) Snd >| Ip4op) "1.256.3.244" + , expectBT (Fail "Guards:invalid length(5) expected 4") $ pl @(Rescan "(\\d+)\\.?" >> ConcatMap Snd Id >> Map (ReadBase Int 10) >| Ip4op) "1.22.244.66.77" + , expectBT (Val 256) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" >> OneP >> Snd >> OneP >> ReadBase Int 16 >> Succ) "\\xfF" + , expectBT (Val 256) $ pl @(Rescan "(?i)^\\\\x(.{2})$" >> OneP >> Snd >> OneP >> ReadBase Int 16 >> Succ) "\\xfF" + , expectBT (Val (("fF",(255,"ff")),False)) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" >> OneP >> Snd >> OneP >> (Id &&& (ReadBase Int 16 >> (Id &&& ShowBase 16))) >> (Id &&& ((Id *** Snd) >> Fst == Snd))) "\\xfF" + , expectBT (Val [31,11,1999]) $ pl @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadBase Int 10) Snd >| Ddmmyyyyop) "31-11-1999" + , expectBT (Val (TimeOfDay 23 13 59)) $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE) >> ReadP TimeOfDay Id) "23:13:59" + , expectBT (Fail "hh:mm:ss regex failed") $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE) >> ReadP TimeOfDay Id) "23:13:60" + , expectBT (Val (124,["1","2","2"])) $ pl @(Left' >> (Succ &&& (Pred >> ShowP Id >> Ones))) (Left 123) + , expectBT (Val (1,("asdf",True))) $ pl @'(1,'("asdf",'True)) () + , expectBT (Val (12, False)) $ pl @('These Id (Not Id)) (These 12 True) + , expectBT (Val [7,9,9,2,7,3,9,8,7,1,3]) $ pl @(Map' (ReadP Int Id) Ones >> Guard "invalid checkdigit" IsLuhn) "79927398713" + , expectBT (Fail "invalid checkdigit") $ pl @(Map' (ReadP Int Id) Ones >> Guard "invalid checkdigit" IsLuhn) "79927398714" + , expectBT (Val [10,14,15,9]) $ pl @(MM1 16 >> MM2 16) "aef9" + , expectBT (Fail "invalid base 16") $ pl @(MM1 16 >> MM2 16) "aef9g" + , expectBT (Fail "found empty") $ pl @(MM1 16 >> MM2 16) "" + , expectBT (Fail "0<=x<n") $ pl @(MM2 16) [10,1,17,1,-3,7] + , expectBT (Val 70) $ pl @(Luhn' 11) "79927398713" + , expectBT (Fail "expected 71 mod 10 = 0 but found 1") $ pl @(Luhn' 11) "79927398714" -- works but way to difficult: use Guard to do all the work --- >pl @(((Rescan "([[:xdigit:]])" >> Map (Snd Id) >> (Id &&& Len)) &&& Len) >> Guard "notallmatched" ((Snd Id *** Id) >> Fst Id == Snd Id)) "134F" +-- >pl @(((Rescan "([[:xdigit:]])" >> Map Snd >> (Id &&& Len)) &&& Len) >> Guard "notallmatched" ((Snd *** Id) >> Fst == Snd)) "134F" -- have to check the length of the match vs input to see that are the same - , expectPE (PresentT [1,3,4,15]) $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd Id >> OneP Id >> ReadBase Int 16 Id) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst Id == Snd Id) >> Fst Id) "134F" - , expectPE (FailT "notallmatched") $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd Id >> OneP Id >> ReadBase Int 16 Id) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst Id == Snd Id) >> Fst Id) "134g" - , expectPE TrueT $ pl @(Map (ReadP _ Id) (Ones Id) >> Luhn Id) "12345678903" - , expectPE FalseT $ pl @(Map (ReadP _ Id) (Ones Id) >> Luhn Id) "12345678904" - , expectPE (FailT "incorrect number of digits found 10 but expected 11 in [1234567890]") $ pl @(Luhn' 11) "1234567890" - , (@?=) (Just "abc") ((_FailT # "abc") ^? _FailT) - , (@?=) (Just ()) ((_TrueT # ()) ^? _TrueT) - , (@?=) (Just ()) ((_FalseT # ()) ^? _FalseT) - , (@?=) (Just 'x') ((_PresentT # 'x') ^? _PresentT) - , expectPE (PresentT (111,'b')) $ pl @('(123,Char1 "c") >> (Id - 12 *** Pred Id)) () - , expectPE (FailT "'Nothing found Just") $ pl @'Nothing (Just 12) + , expectBT (Val [1,3,4,15]) $ pl @(((Rescan "([[:xdigit:]])" >> Map (Snd >> OneP >> ReadBase Int 16)) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst == Snd) >> Fst) "134F" + , expectBT (Fail "notallmatched") $ pl @(((Rescan "([[:xdigit:]])" >> Map (Snd >> OneP >> ReadBase Int 16)) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst == Snd) >> Fst) "134g" + , expectBT (Val True) $ pl @(Map' (ReadP _ Id) Ones >> IsLuhn) "12345678903" + , expectBT (Val False) $ pl @(Map' (ReadP _ Id) Ones >> IsLuhn) "12345678904" + , expectBT (Fail "incorrect length: found 10 but expected 11 in [1234567890]") $ pl @(Luhn' 11) "1234567890" + , (@?=) (Just "abc") ((_Fail # "abc") ^? _Fail) + , (@?=) (Just 'x') ((_Val # 'x') ^? _Val) - -- need to fill in the types for both even in ghci - , expectPE (PresentT [Just 1,Just 2,Just 3,Just 4]) $ pl @Sequence (Just [1..4]) + , expectEQR (Just ()) (pz @(Proxy GE.Any) () ^!? acts . _Val . only (Proxy @GE.Any)) + , expectEQR (Just ()) (pz @(Proxy GE.Any) () ^!? acts . _Val . only (Proxy @_)) + , expectEQR (Just ()) (pz @(Proxy _) () ^!? acts . _Val . only (Proxy @GE.Any)) - , expectPE (PresentT [13,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadP Int Id) (Snd Id)) "13-02-1999" - , expectPE (PresentT [3,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadP Int Id) (Snd Id) >> Ddmmyyyyop) "03-02-1999" - , expectPE (FailT "month 13 is out of range") $ pl @(Rescan DdmmyyyyRE Id >> OneP Id >> Map (ReadP Int Id) (Snd Id) >> Ddmmyyyyop) "12-13-1999" - , expectPE (PresentT 10) $ pl @(Luhn' 4) "1230" - , expectPE (FailT "expected 14 mod 10 = 0 but found 4") $ pl @(Luhn' 4) "1234" - , expectPE (PresentT [4, 7, 8, 9]) $ pl @'[4,7,8,9] () - , expectPE (PresentT ["aa","b","","ddd"]) $ pl @'["aa","b","","ddd"] () - , expectPE (PresentT "abcdef") $ pl @(Fst Id <> (Snd Id >> Fst Id)) ("abc",("def",12)) - , expectPE (PresentT 23) $ pl @(Fst Id + Last (Snd Id)) (10,[12,13]) - , expectPE (PresentT 157) $ pl @(Fst Id * (Snd Id >> Fst Id) + (Snd Id >> Snd Id) `Div` 2) (12,(13,3)) - , expectPE (PresentT (Proxy @'["xy","xy","xy","xy"])) $ pl @(Proxy (RepeatT 4 "xy")) 3 - , expectPE (PresentT (66788,26232)) $ pl @(Last Id >> Id * 123 >> Dup >> (Pred Id *** (ShowP Id >> Rescan "(\\d{2})" Id >> Concat (ConcatMap (Snd Id) Id) >> ReadBase Int 16 Id))) [12,13,543::Int] + , expectBT (Val (111,'b')) $ pl @('(123,Char1 "c") >> (Id - 12 *** Pred)) () + , expectBT (Fail "'Nothing found Just") $ pl @'Nothing (Just 12) + , expectBT (Val [Just 1,Just 2,Just 3,Just 4]) $ pl @Sequence (Just [1..4]) - , expectPE (PresentT ('x',('x',"someval"))) $ pl @Duplicate ('x',"someval") - , expectPE (PresentT "someval") $ pl @Extract ('x',"someval") - , expectPE (PresentT (9,"abc")) $ pl @(I $$ 9 $$ "abc") (,) - , expectPE (PresentT ("abc",9)) $ pl @(9 $& "abc" $& I) (,) - , expectPE (PresentT "28") $ pl @(Fst Id $$ Snd Id) (show . (7*),4) - , expectPE (PresentT (12,"12")) $ pl @(Fst Id $$ Snd Id $$ ShowP (Snd Id)) ((,),12) - , expectPE (PresentT (4,("aa",'x'))) $ pl @'(4,'(Fst Id,Snd Id)) ("aa",'x') - , expectPE (PresentT (4,"aa",'x')) $ pl @'(4,Fst Id,Snd Id) ("aa",'x') - , expectPE (PresentT (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @(EnumFromTo (Fst Id) (Snd Id)) (ModifiedJulianDay 0, ModifiedJulianDay 5) - , expectPE (PresentT (4,'x')) $ pl @('(,) 4 %% Char1 "x") () - , expectPE (PresentT (4,"abc")) $ pl @('(,) %% 4 %% "abc") () - , expectPE (PresentT ("abc",4)) $ pl @(4 %& "abc" %& '(,)) () - , expectPE (PresentT ("abc",4)) $ pl @(FlipT '(,) 4 "abc") () - , expectPE (PresentT []) $ pl @'[] 4 - , expectPE (PresentT (-5 % 3)) $ pl @(Snd Id / Fst Id) (-3,5) - , expectPE (FailT "(/) zero denominator") $ pl @(Snd Id / Fst Id) (0,5) - , expectPE (PresentT (False,7)) - $ pl @(Foldl (If (Fst (Fst Id)) - (If (Snd Id > Snd (Fst Id)) - '( 'True, Snd Id ) - '( 'False, Snd (Fst Id) ) - ) (Fst Id)) - '( 'True, Head Id) (Tail Id)) [1,4,7,6,16] - , expectPE (PresentT [10,12,13]) $ pl @(CatMaybes Id) [Just 10, Just 12, Nothing, Just 13] + , expectBT (Val [13,2,1999]) $ pl @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadP Int Id) Snd) "13-02-1999" + , expectBT (Val [3,2,1999]) $ pl @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadP Int Id) Snd >| Ddmmyyyyop) "03-02-1999" + , expectBT (Fail "month 13 is out of range") $ pl @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadP Int Id) Snd >| Ddmmyyyyop) "12-13-1999" + , expectBT (Val 10) $ pl @(Luhn' 4) "1230" + , expectBT (Fail "expected 14 mod 10 = 0 but found 4") $ pl @(Luhn' 4) "1234" + , expectBT (Val [4, 7, 8, 9]) $ pl @'[4,7,8,9] () + , expectBT (Val ["aa","b","","ddd"]) $ pl @'["aa","b","","ddd"] () + , expectBT (Val "abcdef") $ pl @(Fst <> L21) ("abc",("def",12)) + , expectBT (Val 23) $ pl @(Fst + (Snd >> Last)) (10,[12,13]) + , expectBT (Val 157) $ pl @(Fst * L21 + L22 `Div` 2) (12,(13,3)) + , expectBT (Val (Proxy @'["xy","xy","xy","xy"])) $ pl @(Proxy (RepeatT 4 "xy")) 3 + , expectBT (Val (66788,26232)) $ pl @(Last >> Id * 123 >> Dup >> (Pred *** (ShowP Id >> Rescan "(\\d{2})" >> ConcatMap Snd Id >> Concat >> ReadBase Int 16))) [12,13,543] + , expectBT (Val (9,"abc")) $ pl @(Id $$ 9 $$ "abc") (,) + , expectBT (Val ("abc",9)) $ pl @(9 $& "abc" $& Id) (,) + , expectBT (Val "28") $ pl @(Fst $$ Snd) (show . (7*),4) + , expectBT (Val (12,"12")) $ pl @(Fst $$ Snd $$ ShowP Snd) ((,),12) + , expectBT (Val (4,("aa",'x'))) $ pl @'(4,'(Fst,Snd)) ("aa",'x') + , expectBT (Val (4,"aa",'x')) $ pl @'(4,Fst,Snd) ("aa",'x') + , expectBT (Val (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @(Fst ... Snd) (ModifiedJulianDay 0, ModifiedJulianDay 5) + , expectBT (Val (4,'x')) $ pl @('(,) 4 %% Char1 "x") () + , expectBT (Val (4,"abc")) $ pl @('(,) %% 4 %% "abc") () + , expectBT (Val ("abc",4)) $ pl @(4 %& "abc" %& '(,)) () + , expectBT (Val ("abc",4)) $ pl @(FlipT '(,) 4 "abc") () + , expectBT (Val []) $ pl @'[] 4 + , expectBT (Val (-5 % 3)) $ pl @(Snd / Fst) (-3,5) + , expectBT (Fail "(/) zero denominator") $ pl @(Snd / Fst) (0,5) + , expectBT (Val (False,7)) + $ pl @(Foldl (If L11 + (If (Snd > L12) + '( 'True, Snd ) + '( 'False, L12 ) + ) Fst) + '( 'True, Head) Tail) [1,4,7,6,16] + , expectBT (Val [10,12,13]) $ pl @CatMaybes [Just 10, Just 12, Nothing, Just 13] - , expectPE (FailT "abcsomeval") $ pl @(Fail (Snd Id >> Unproxy) (Fst Id <> "someval")) ("abc",Proxy @Int) + , expectBT (Fail "abcsomeval") $ pl @(Fail (Snd >> UnproxyT) (Fst <> "someval")) ("abc",Proxy @Int) - , expectPE (PresentT [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @(Map Fizzbuzz''' Id) [1..15] - , expectPE (PresentT "abc") $ pl @(Thd (Snd (Fst Id))) (('x',(13,False,"abc")),True,'y') - , expectPE (PresentT 9.3) $ pl @(Fst (Snd (Thd Id))) ('x',True,(13,(9.3,False),"def")) - , expectPE (PresentT (4,"helo|oleh")) $ pl @'(Len, Id <> "|" <> Reverse) "helo" - , expectPE (PresentT (123,"helo")) $ pl @'(Snd Id, Fst Id) ("helo",123) - , expectPE (PresentT (4,"helo","oleh")) $ pl @'(Len, Id, Reverse) "helo" - , expectPE (PresentT [1,2,3,1000,998]) $ pl @'[W 1, W 2, W 3, Succ Id, Pred Id] 999 - , expectPE (PresentT [3996,998]) $ pl @'[Id * 4, Pred Id] 999 + , expectBT (Val [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @(Map Fizzbuzz''') [1..15] + , expectBT (Val [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @(Map Fizzbuzz'') [1..15] + , expectBT (Val [(1,""),(2,""),(3,"fizz"),(4,""),(5,"buzz"),(6,"fizz"),(7,""),(8,""),(9,"fizz"),(10,"buzz"),(11,""),(12,"fizz"),(13,""),(14,""),(15,"fizzbuzz")]) $ pl @Fizzbuzzs [1..15] + , expectBT (Val [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @Fizzbuzzs2 [1..15] + , expectBT (Val [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @Fizzbuzzs3 [1..15] + , expectBT (Val "abc") $ pl @(L3 L12) (('x',(13,False,"abc")),True,'y') + , expectBT (Val 9.3) $ pl @(L1 L32) ('x',True,(13,(9.3,False),"def")) + , expectBT (Val (4,"helo|oleh")) $ pl @'(Len, Id <> "|" <> Reverse) "helo" + , expectBT (Val (123,"helo")) $ pl @'(Snd, Fst) ("helo",123) + , expectBT (Val (4,"helo","oleh")) $ pl @'(Len, Id, Reverse) "helo" + , expectBT (Val [1,2,3,1000,998]) $ pl @'[W 1, W 2, W 3, Succ, Pred] 999 + , expectBT (Val [3996,998]) $ pl @'[Id * 4, Pred] 999 + , expectBT (Val [2,3,4,5,6]) $ pz @(FlipT Map' Id Succ) [1..5] + , expectBT (Val (2,True)) $ pz @( FlipT '(,) 'True 2) () + , expectBT (Val (1,"ab",2)) $ pz @( FlipT ('(,,) 1) 2 Id) "ab" + , expectBT (Val 13) $ pz @(12 & Lift Succ) () + , expectBT (Val 10) $ pz @('[1,2,3,4] & FoldMap (SG.Sum _)) () + -- test semigroup interaction - , expectEQR (These (PresentT 6) (FailT "xyzhello")) $ fmap This (pz @Predicate.Sum [1,2,3]) <> fmap That (pz @(FailS "xyz") 5) <> fmap That (pz @(FailS "hello") 1) - , expectEQR (These (PresentT 6) (PresentT ("5",6))) $ fmap This (pz @Predicate.Sum [1,2,3]) <> fmap That (pz @(ShowP Id &&& Succ Id) 5) + , expectEQR (These (Val 6) (Fail "xyz | hello")) $ fmap This (pz @Predicate.Sum [1,2,3]) <> fmap That (pz @(FailS "xyz") 5) <> fmap That (pz @(FailS "hello") 1) + , expectEQR (These (Val 6) (Val ("5",6))) $ fmap This (pz @Predicate.Sum [1,2,3]) <> fmap That (pz @(ShowP Id &&& Succ) 5) -- test options , oRecursion testopts1 @?= 11 , oDebug testopts1 @?= DVerbose @@ -175,27 +175,28 @@ ] testopts1, testopts2, testopts3 :: POpts -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) +testopts1 = getOpt @('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 = getOpt @('OColorOn ':# 'OColor "testcolor" 'Red 'Green 'Default 'White 'Default 'White 'Default 'White) +testopts3 = getOpt @('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" "") -type Fizzbuzz'' = Case (MkLeft String (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id +type Fizzbuzz'' = Case (MkLeft String Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id -- makes use of type family MapT which does the apply on ADTs: so type synonyms dont work -type Fizzbuzz''' = Case (MkLeft String (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] (MapT (MkRight' (Hole Int)) '[ "fizzbuzz", "fizz", "buzz"]) Id +type Fizzbuzz''' = Case (MkLeft String Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] (MapT (MkRight' (Hole Int)) '["fizzbuzz", "fizz", "buzz"]) Id -type Fizzbuzzs = Map Fizzbuzz Id -type Fizzbuzzs2 = Map (Fizzbuzz >> If (Null' (Snd Id)) (MkLeft String (Fst Id)) (MkRight Int (Snd Id))) Id +type Fizzbuzzs = Map Fizzbuzz +type Fizzbuzzs2 = Map (Fizzbuzz >> If (Null' Snd) (MkLeft String Fst) (MkRight Int Snd)) -- best one cos leverages type info to determine Either a b -type Fizzbuzzs3 = Map (Fizzbuzz >> If (Snd Id == "") (MkLeft' (Snd Id) (Fst Id)) (MkRight' (Fst Id) (Snd Id))) Id +type Fizzbuzzs3 = Map (Fizzbuzz >> If (Snd == "") (MkLeft' Snd Fst) (MkRight' Fst Snd)) -type Ip6Test = Resplit ":" Id +type Ip6Test = Resplit ":" >> Guard "count is bad" (Between 0 8 Len) - >> Guard "not a hex" (All (All (Elem Id "abcdefABCDEF0123456789") Id) Id) - >> Guard "len is bad" (All (Len >> Le 4) Id) + >> Guard "not a hex" (All (All (Elem Id "abcdefABCDEF0123456789"))) + >> Guard "len is bad" (All (Len >> Le 4)) -- base n number of length x and then convert to a list of length x of (0 to (n-1)) -- checks that each digit is between 0 and n-1 -type MM1 (n :: Nat) = Map (ReadBase Int n Id) (Ones Id) -type MM2 (n :: Nat) = ExitWhen "found empty" IsEmpty >> Guard "0<=x<n" (All (Ge 0 && Lt n) Id) +type MM1 (n :: Nat) = Map' (ReadBase Int n) Ones +type MM2 (n :: Nat) = ExitWhen "found empty" IsEmpty >> Guard "0<=x<n" (All (Ge 0 && Lt n)) +
test/TestRefined.hs view
@@ -1,7 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# OPTIONS -Wno-type-defaults #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -11,21 +7,23 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoOverloadedLists #-} -- overloaded lists breaks some predicates {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoStarIsType #-} module TestRefined where +--module TestRefined (suite) where import TastyExtras import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Predicate -import Predicate.TH_Orphans () -- need this else refined*TH' fails for dates - -import Control.Lens import Data.Aeson -import Control.Monad.IO.Class (MonadIO) +import qualified Safe (readNote) +import Control.Applicative (liftA2) +import Control.Arrow (left) +import Data.Kind (Type) +import Data.Proxy +import qualified GHC.TypeLits as GL suite :: TestTree suite = @@ -35,48 +33,52 @@ 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 @OAN @'True @Int 7) (Right (unsafeRefined 7)) + , testCase "between5and9" $ (@=?) (newRefined @OAN @(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 @OAN @'True ("1.2.3.4" :: String))) (newRefined "1.2.3.4") + , (@=?) (Right (unsafeRefined @OAN @((Len == 4) && IsLuhn) [1,2,3,0])) (newRefined [1,2,3,0]) + , (@=?) (Right (unsafeRefined @OAN @(Not ((Len == 4) && IsLuhn)) [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 OAN (Between 2 10 Id) Int) "Refined 7") + , (@=?) [] (reads @(Refined OAN (Between 2 10 Id) Int) "Refined 0") + , (@=?) [(unsafeRefined "abcaaaabb", "")] (reads @(Refined OAN (Re "^[abc]+$") String) "Refined \"abcaaaabb\"") + , (@=?) [] (reads @(Refined OAN (Re "^[abc]+$") 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 (||)"]) (toFrom (unsafeRefined @OL @(Between 4 7 Id || Gt 14 || Failt _ "someval") 12)) + , expectJ (Left ["Error in $: Refined(FromJSON:parseJSON):Fail 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") + , tst2' 10 200 >>= (@?= Right (10,200)) + , tst2' 11 12 >>= (@?= Left (Right False)) - , (fst <$> unRavelT (tst1 10 200)) >>= (@=? Right (10,200)) - , (fst <$> unRavelT (tst1 11 12)) >>= (@=? Left "FalseT") + , tst1' 10 200 @?= Right (10,200) + , tst1' 11 12 @?= Left (Right False) + ] 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 @OAN @(Between 10 45 Id) (choose (1,100))) (\r -> Safe.readNote @(Refined OAN (Between 10 45 Id) Int) "testrefined: readshow" (show r) === r) + , testProperty "jsonroundtrip" $ forAll (genRefined @OAN @(Between 10 45 Id) (choose (1,100))) (\r -> testRefinedJ @OAN @(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 - $ \y -> return (unRefined x, unRefined y) +tst1' :: Int -> Int -> Either (Either String Bool) (Int,Int) +tst1' i j = left m0BoolE $ do + x <- newRefined @OAN @(Between 2 11 Id) i + y <- newRefined @OAN @(Between 200 211 Id) j + 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 - $ \y -> return (unRefined x, unRefined y) +tst2' :: Int -> Int -> IO (Either (Either String Bool) (Int,Int)) +tst2' i j = left m0BoolE <$> do + x <- newRefined' @OAN @(Between 2 11 Id) i + y <- newRefined' @OAN @(Stderr "startio..." |> Between 200 211 Id >| Stderr "...endio") j + return $ + liftA2 (,) (unRefined <$> x) (unRefined <$> y) -- roundtrip tojson then fromjson testRefinedJ :: forall opts p a @@ -86,7 +88,27 @@ => a -> Either String (Refined opts p a) testRefinedJ a = - let ((bp,(_top,e)),mr) = runIdentity $ newRefinedM @opts @p a - in case mr of - Nothing -> error $ bp ++ "\n" ++ e - Just r -> eitherDecode @(Refined opts p a) $ encode r + case newRefined @opts @p a of + Left (Msg0 _bp _top e bpc) -> error $ bpc ++ "\n" ++ e + Right r -> eitherDecode @(Refined opts p a) $ encode r + +testKindSignature0A :: Either Msg0 + (Refined + OU + (PApp (Proxy (Lift "abc" :: Type -> Type)) (Proxy ()) >> 'True) + ()) +testKindSignature0A = newRefined () + +testKindSignature0B :: Either Msg0 + (Refined + OU + (Pop1' (Proxy (Lift "abc" :: GL.Nat -> Type)) (Proxy 4) () >> 'True) + ()) +testKindSignature0B = newRefined () + +testKindSignature0C :: Either Msg0 + (Refined + OU + (Pop2' (Proxy ('(,) :: Type -> Bool -> (Type,Bool))) (Proxy (W "bbb")) Fst Snd >> Snd) + (Proxy 'True, Int)) +testKindSignature0C = newRefined (Proxy @'True,1234)
test/TestRefined2.hs view
@@ -1,7 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} @@ -10,12 +6,12 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoOverloadedLists #-} -- overloaded lists breaks some predicates {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoStarIsType #-} module TestRefined2 where +--module TestRefined2 (suite) where import TastyExtras import Test.Tasty import Test.Tasty.HUnit @@ -24,235 +20,217 @@ import Predicate.Refined2 import Predicate.Examples.Refined2 import Predicate.Examples.Common -import Predicate.TH_Orphans () -- need this else refined*TH' fails for dates import Data.Ratio import Data.Typeable import Data.Time import GHC.Generics (Generic) import Data.Aeson -import Control.Monad.Cont import Text.Show.Functions () -import Data.Tree import Data.Tree.Lens ---import Data.Maybe import Control.Lens +import Control.Arrow (left) +import qualified Safe (readNote) +import Data.Kind (Type) +import qualified GHC.TypeLits as GL +import qualified Data.Semigroup as SG suite :: TestTree suite = let s = "TestRefined2" - in testGroup s (namedTests <> orderTests s unnamedTests) + in testGroup s (namedTests <> orderTests s (unnamedTests <> tst0a)) 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 Msg2 (MakeR2 (Ip9 OAN))) (Right (unsafeRefined2 [121,0,12,13] "121.0.12.13")) + , testCase "luhn check" $ (@?=) (newRefined2 "12345678903" :: Either Msg2 (MakeR2 (Luhn OAN 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 Msg2 (MakeR2 (DateTime1 OAN UTCTime))) (Right (unsafeRefined2 (Safe.readNote "testrefined2: utc date" "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) + , testCase "datetime localtime" $ (@?=) (newRefined2 "2019-01-04 09:12:30" :: Either Msg2 (MakeR2 (DateTime1 OAN LocalTime))) (Right (unsafeRefined2 (Safe.readNote "testrefined2: localtime" "2019-01-04 09:12:30") "2019-01-04 09:12:30")) + , testCase "hms" $ (@?=) (newRefined2 "12:0:59" :: Either Msg2 (MakeR2 (Hms OAN))) (Right (unsafeRefined2 [12,0,59] "12:0:59")) + , testCase "between5and9" $ (@?=) (newRefined2 "7" :: Either Msg2 (Refined2 OAN (ReadP Int Id) (Between 5 9 Id) String)) (Right (unsafeRefined2 7 "7")) + , testCase "ssn" $ (@?=) (newRefined2 "123-45-6789" :: Either Msg2 (MakeR2 (Ssn OAN))) (Right (unsafeRefined2 [123,45,6789] "123-45-6789")) + , testCase "base16" $ (@?=) (newRefined2 "12f" :: Either Msg2 (MakeR2 (BaseN OAN 16))) (Right (unsafeRefined2 303 "12f")) + , testCase "daten1" $ (@?=) (newRefined2 "June 25 1900" :: Either Msg2 (MakeR2 (DateN OAN))) (Right (unsafeRefined2 (Safe.readNote "testrefined2: daten1" "1900-06-25") "June 25 1900")) + , testCase "daten2" $ (@?=) (newRefined2 "12/02/99" :: Either Msg2 (MakeR2 (DateN OAN))) (Right (unsafeRefined2 (Safe.readNote "testrefined2: daten2" "1999-12-02") "12/02/99")) + , testCase "daten3" $ (@?=) (newRefined2 "2011-12-02" :: Either Msg2 (MakeR2 (DateN OAN))) (Right (unsafeRefined2 (Safe.readNote "testrefined2: daten3" "2011-12-02") "2011-12-02")) + , testCase "ccn123" $ (@?=) (newRefined2 "123455" :: Either Msg2 (MakeR2 (Luhn OAN 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\"}") - - , (@?=) (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") + (@?=) [(unsafeRefined2 255 "ff", "")] (reads @(Refined2 OAN (ReadBase Int 16) (0 <..> 0xff) String) "Refined2 255 \"ff\"") -- escape quotes cos read instance for String + , (@?=) [] (reads @(Refined2 OAN (ReadBase Int 16) (0 <..> 0xff) String) "Refined2 256 \"100\"") + , (@?=) [(unsafeRefined2 (-1234) "-4d2", "")] (reads @(Refined2 OAN (ReadBase Int 16) (Id < 0) String) "Refined2 (-1234) \"-4d2\"") + , (@?=) (Right (unsafeRefined2 [1,2,3,4] "1.2.3.4")) (newRefined2 "1.2.3.4" :: Either Msg2 (Ip4R OAN)) + , expectJ (Right (G4 (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4"))) (toFrom $ G4 @OAN (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) + , expectJ (Left ["Error in $.g4Ip", "False Boolean Check"]) (toFrom $ G4 @OAN (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3.400")) + , expectJ (Left ["Error in $.g4Ip", "ReadP Int (3x)"]) (toFrom $ G4 @OAN (unsafeRefined2 12 "12") (unsafeRefined2 [1,2,3,4] "1.2.3x.4")) + , expectJ (Left ["Error in $.g4Age", "False Boolean Check"]) (toFrom $ G4 @OAN (unsafeRefined2 (-2) "-2") (unsafeRefined2 [1,2,3,4] "1.2.3.4")) + , expectRight (testRefined2P (Proxy @(Luhn OAN 11)) "123-45-6---789-03-") + , expectLeft (testRefined2P (Proxy @(Luhn OAN 11)) "123-45-6---789-04-") + , expectRight (testRefined2P (Proxy @(Hms OAN)) "1:2:33") + , expectLeft (testRefined2P (Proxy @(Hms OAN)) "1:2:61") + , expectRight (testRefined2P (Proxy @(Luhn OAN 11)) "6433-1000-006") + , expectRight (testRefined2P (Proxy @(Luhn OAN 11)) "6433-10000-06") + , expectLeft (testRefined2P (Proxy @(Luhn OAN 11)) "6433-1000-000") + , expectRight (testRefined2P (Proxy @(Luhn OAN 4)) "1-23-0") , expect2 (Left $ XF "Regex no results") - $ eval2 @OA @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int Id) (Snd Id)) - @((Len == 4) && All (Between 0 255 Id) Id) + $ runIdentity $ eval2M @OAN @(Rescan Ip4RE >> HeadFail "failedn" Id >> Map' (ReadP Int Id) Snd) + @((Len == 4) && All (0 <..> 0xff)) "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)) - @((Len == 4) && All (Between 0 255 Id) Id) + $ runIdentity $ eval2M @OAN @(Rescan Ip4RE >> HeadFail "failedn" Id >> Map' (ReadP Int Id) Snd) + @((Len == 4) && All (0 <..> 0xff)) "1.21.31.4" , expect2 (Left $ XTFalse (-6.5) "(-13) % 2 > (-7) % 3") - $ eval2 @OA @(ReadP Double Id) + $ runIdentity $ eval2M @OAN @(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) + $ runIdentity $ eval2M @OAN @(ReadP Double Id) @(ToRational Id > 7 -% 3) "4.123" , expect2 (Right $ unsafeRefined2 4.123 (4123 % 1000)) - $ eval2 @OA @Id @(Gt (7 -% 3)) 4.123 + $ runIdentity $ eval2M @OAN @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" + $ runIdentity $ eval2M @OAN @(Map' (ReadP Int Id) (Resplit "\\.")) @(All (0 <..> 0xff) && (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 @OAN @Ip6ip @Ip6op "123:Ffeff:1123:11:1" + $ runIdentity $ eval2M @OAN @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" + $ runIdentity $ eval2M @OAN @Ip4ip @Ip4op' "12.2.0.255" , 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)) - @(Guard "expected 3" (Len == 3) - >> Guard "3 digits" (Ix' 0 >> Between 0 999 Id) - >> Guard "2 digits" (Ix' 1 >> Between 0 99 Id) - >> Guard "4 digits" (Ix' 2 >> Between 0 9999 Id) - >> 'True + $ runIdentity $ eval2M @OAN + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) + @(GuardBool "expected 3" (Len == 3) + && GuardBool "3 digits" (Between 0 999 (Ix' 0)) + && GuardBool "2 digits" (Between 0 99 (Ix' 1)) + && GuardBool "4 digits" (Between 0 9999 (Ix' 2)) ) "123-45-6789" , 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)) + $ runIdentity $ eval2M @OAN + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) @(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 @OAN @Ip6ip @Ip6op + $ runIdentity $ eval2M @OAN @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 @OAN @Ip6ip @Ip6op + $ runIdentity $ eval2M @OAN @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 + $ runIdentity $ eval2M @OAN @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 + $ runIdentity $ eval2M @OAN @Ip6ip @Ip6op "123::Ffff:::11" , expect2 (Right $ unsafeRefined2 [0,0,291,0,65535,0,0,17] "123::Ffff:::11") - $ eval2 @OA @Ip6ip @Ip6op + $ runIdentity $ eval2M @OAN @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)) - @(Ddmmyyyyop >> 'True) + $ runIdentity $ eval2M @OAN @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadBase Int 10) Snd) + @Ddmmyyyyop "31-11-1999" - , 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)) + , expect2 (Right $ unsafeRefined2 [123,45,6789] "123-45-6789") $ runIdentity $ eval2M @OAN + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) @(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") $ runIdentity $ eval2P (ip4 @OAN) "1.2.3.4" + , expect2 (Left $ XF "ReadP Int (3x)") $ runIdentity $ eval2P (ip4 @OAN) "1.2.3x.4" + , expect2 (Left $ XTF [1,2,3,4,5] "Bools:invalid length(5) expected 4") $ runIdentity $ eval2P (ip4' @OAN) "1.2.3.4.5" + , expect2 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ runIdentity $ eval2P (ip4 @OAN) "1.2.3.4.5" + , expect2 (Left $ XTF [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)") $ runIdentity $ eval2P (ip4' @OAN) "1.2.300.4" + , expect2 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ runIdentity $ eval2P (ip4 @OAN) "1.2.300.4" + , expect2 (Right $ unsafeRefined2 [1,2,3,4,5,6,7,8,9,0,3] "12345678903") $ runIdentity $ eval2P (luhn11 @OAN) "12345678903" + , expect2 (Left $ XTF [1,2,3,4,5,6,7,8,9,0,1] "invalid checkdigit") $ runIdentity $ eval2P (luhn11 @OZ) "12345678901" ] -type HexLtR3 (opts :: OptT) = Refined2 opts (ReadBase Int 16 Id) (Id < 500) String -type IntLtR3 (opts :: OptT) = Refined2 opts (ReadP Int Id) (Id < 10) String - -- better to use Guard for op boolean check cos we get better errormessages -- 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) +type Tst3 (opts :: Opt) = '(opts, Map' (ReadP Int Id) (Resplit "\\."), (Len == 4) && All (0 <..> 0xff), String) -www1, www2 :: String -> Either String (MakeR2 (Tst3 OA)) -www1 = newRefined2P (Proxy @(Tst3 OA)) +www1, www2 :: String -> Either Msg2 (MakeR2 (Tst3 OAN)) +www1 = newRefined2P (Proxy @(Tst3 OAN)) 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) - ,(Len == 4) && All (Between 0 255 Id) Id + '(OAN, Map' (ReadP Int Id) (Resplit "\\.") + ,(Len == 4) && All (0 <..> 0xff) ,String) tst3 = Proxy -- 3. direct -ww3 :: String -> Either String (Refined2 OA - (Map (ReadP Int Id) (Resplit "\\." Id)) - ((Len == 4) && All (Between 0 255 Id) Id) +www3, www3' :: String -> Either Msg2 (Refined2 OAN + (Map' (ReadP Int Id) (Resplit "\\.")) + ((Len == 4) && All (0 <..> 0xff)) String) -ww3 = newRefined2 -{- -ww3 = newRefined2 - @OA - @(Map (ReadP Int Id) (Resplit "\\." Id)) - @((Len == 4) && All (Between 0 255 Id)) --} -data G4 (opts :: OptT) = G4 { g4Age :: MakeR2 (Age opts) - , g4Ip :: MakeR2 (Ip9 opts) +www3 = newRefined2 + +www3' = newRefined2 + @OAN + @(Map' (ReadP Int Id) (Resplit "\\.")) + @((Len == 4) && All (0 <..> 0xff)) + +data G4 (opts :: Opt) = G4 + { g4Age :: !(MakeR2 (Age opts)) + , g4Ip :: !(MakeR2 (Ip9 opts)) } deriving (Show,Generic,Eq) -type MyAge (opts :: OptT) = Refined2 opts (ReadP Int Id) (Gt 4) String +--type MyAge (opts :: Opt) = Refined2 opts (ReadP Int Id) (Gt 4) String -type Age (opts :: OptT) = '(opts, ReadP Int Id, Gt 4, String) +type Age (opts :: Opt) = '(opts, ReadP Int Id, Gt 4, String) -type Ip9 (opts :: OptT) = '(opts, - 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 +type Ip9 (opts :: Opt) = '(opts, + Map' (ReadP Int Id) (Resplit "\\.") -- split String on "." then convert to [Int] + ,Len == 4 && All (0 <..> 0xff) -- process [Int] and make sure length==4 and each octet is between 0 and 255 ,String -- input type is string which is also the output type ) -instance OptTC opts => FromJSON (G4 opts) -instance OptTC opts => ToJSON (G4 opts) +instance OptC opts => FromJSON (G4 opts) +instance OptC opts => ToJSON (G4 opts) -tst0a :: [Bool] +tst0a :: [Assertion] 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 @OL) "June 25 1900" @?= Right (unsafeRefined2 (fromGregorian 1900 6 25) "June 25 1900") + , newRefined2P (daten @OL) "12/02/19" @?= Right (unsafeRefined2 (fromGregorian 2019 12 2) "12/02/19") + , newRefined2P (Proxy @(Luhn OL 4)) "1230" @?= Right (unsafeRefined2 [1,2,3,0] "1230") + , newRefined2P (Proxy @(Luhn OL 6)) "123455" @?= Right (unsafeRefined2 [1,2,3,4,5,5] "123455") + , test2a @?= Right (unsafeRefined2 254 "0000fe") + , test2b @?= Right (unsafeRefined2 [123,211,122,1] "123.211.122.1") + , test2c @?= Right (unsafeRefined2 [200,2,3,4] "200.2.3.4") + , expectIO (left show <$> test2d) (() <$) + , www1 "1.2.3.4" @?= Right (unsafeRefined2 [1,2,3,4] "1.2.3.4") + , www2 "1.2.3.4" @?= Right (unsafeRefined2 [1,2,3,4] "1.2.3.4") + , www3 "1.2.3.4" @?= Right (unsafeRefined2 [1,2,3,4] "1.2.3.4") + , www3' "1.2.3.4" @?= Right (unsafeRefined2 [1,2,3,4] "1.2.3.4") + , tst1a @'OAN @=? Right ((163,"a3"),(12,"12")) ] --- 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" - $ \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" - $ \r2 -> return ((r2In r1, r2Out r1), (r2In r2, r2Out r2)) - --- have to use 'i' as we dont hold onto the input -testRefined2PJ :: forall opts ip op i proxy - . ( ToJSON i - , Show (PP ip i) - , Show i - , Refined2C opts ip op i - , FromJSON i) - => proxy '(opts,ip,op,i) - -> i - -> Either String (Refined2 opts ip op i) -testRefined2PJ _ i = - let (ret,mr) = eval2 @opts @ip @op i - m3 = prt2Impl (getOptT @opts) ret - in case mr of - Just r -> eitherDecode @(Refined2 opts ip op i) $ encode r - Nothing -> Left $ show m3 +tst1a :: forall (opts :: Opt) . OptC opts => Either Msg2 ((Int,String),(Int,String)) +tst1a = do + r1 <- newRefined2 @opts @(ReadBase Int 16) @(Between 100 200 Id) @String "a3" + r2 <- newRefined2 @opts @(ReadP Int Id) @'True @String "12" + return ((r2In r1, r2Out r1), (r2In r2, r2Out r2)) -- test that roundtripping holds ie i ~ PP (PP ip i) testRefined2P :: forall opts ip op i proxy @@ -265,20 +243,15 @@ -> i -> Either (String,String) (Refined2 opts ip op i, Refined2 opts ip op i) testRefined2P _ i = - let (ret,mr) = eval2 @opts @ip @op i - o = getOptT @opts - m3 = prt2Impl o ret - in case mr of - Just r -> - let (ret1,mr1) = eval2 @opts @ip @op (r2Out r) - m3a = prt2Impl o ret1 - in case mr1 of - Nothing -> Left ("testRefined2P(2): round trip failed: old(" ++ show i ++ ") new(" ++ show (r2Out r) ++ ")", show m3a) - Just r1 -> + case newRefined2 @opts @ip @op i of + Right r -> + case newRefined2 @opts @ip @op (r2Out r) of + Left m3a -> Left ("testRefined2P(2): round trip failed: old(" ++ show i ++ ") new(" ++ show (r2Out r) ++ ")", show m3a) + Right r1 -> if r /= r1 then Left ("testRefined2P(3): round trip pure () but values dont match: old(" ++ show i ++ ") new(" ++ show (r2Out r) ++ ")", show (r,r1)) else Right (r,r1) - Nothing -> Left ("testRefined2P(1): bad initial predicate i=" ++ show i, show m3) - + Left m3 -> Left ("testRefined2P(1): bad initial predicate i=" ++ show i, show m3) +{- testRefined2PIO :: forall opts ip op i proxy . ( Show (PP ip i) , Refined2C opts ip op i @@ -291,26 +264,19 @@ case testRefined2P p i of Right (r,r1) -> return $ Right (r,r1) Left (msg, e) -> putStrLn e >> return (Left msg) - -getTTs3 :: RResults2 a -> [Tree PE] -getTTs3 = \case - RF _ t1 -> [t1] - RTF _ t1 _ t2 -> [t1,t2] - RTFalse _ t1 t2 -> [t1,t2] - RTTrue _ t1 t2 -> [t1,t2] - +-} data Results2 a = - XF String -- Left e - | XTF a String -- Right a + Left e - | XTFalse a String -- Right a + Right False - | XTTrue a + XF !String -- Left e + | XTF !a !String -- Right a + Left e + | XTFalse !a !String -- Right a + Right False + | XTTrue !a deriving (Show,Eq) toRResults2 :: RResults2 a -> Results2 a toRResults2 = \case RF e _ -> XF e RTF a _ e _ -> XTF a e - RTFalse a _ t2 -> XTFalse a (t2 ^. root . pString) + RTFalse a _ t2 -> XTFalse a (t2 ^. root . peString) RTTrue a _ _ -> XTTrue a expect2 :: (HasCallStack, Show i, Show r, Eq i, Eq r) @@ -320,23 +286,73 @@ expect2 lhs (rhs,mr) = (@?=) (maybe (Left $ toRResults2 rhs) Right mr) lhs -test2a :: Either String (MakeR2 (BaseN OU 16)) +test2a :: Either Msg2 (MakeR2 (BaseN OAN 16)) test2a = newRefined2 "0000fe" -test2b :: Either String (Refined2 OU - (Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" Id >> Snd (Head Id) >> Map (ReadP Int Id) Id) - (All (0 <..> 0xff) Id) +test2b :: Either Msg2 (Refined2 OAN + (Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" >> Head >> Snd >> Map (ReadP Int Id)) + (All (0 <..> 0xff)) String) test2b = newRefined2 "123.211.122.1" -test2c :: Either String (Refined2 OU - (Resplit "\\." Id >> Map (ReadP Int Id) Id) - (All (0 <..> 0xff) Id && Len == 4) +test2c :: Either Msg2 (Refined2 OAN + (Resplit "\\." >> Map (ReadP Int Id)) + (All (0 <..> 0xff) && Len == 4) String) test2c = newRefined2 "200.2.3.4" -test2d :: Either String (Refined2 OU +test2d :: IO (Either Msg2 (Refined2 OAN TimeUtc - (ToDay Id > 'Just (MkDay '(2020,05,31))) - ()) -test2d = newRefined2P Proxy () + (ToDay > 'Just (MkDay '(2020,05,31))) + ())) +test2d = newRefined2P' Proxy () + +testKindSignature2A :: Either Msg2 + (Refined2 OU + Id + (PApp (Proxy (Lift "abc" :: Type -> Type)) (Proxy ()) >> 'True) + ()) +testKindSignature2A = newRefined2 () + +testKindSignature2B :: Either Msg2 + (Refined2 OU + Id + (Pop1' (Proxy (Lift "abc" :: GL.Nat -> Type)) (Proxy 4) () >> 'True) + ()) +testKindSignature2B = newRefined2 () + +testKindSignature2C :: Either Msg2 + (Refined2 OU + Id + (Pop2' (Proxy ('(,) :: Type -> Bool -> (Type,Bool))) (Proxy (W "bbb")) Fst Snd >> Snd) + (Proxy 'True, Int)) +testKindSignature2C = newRefined2 (Proxy @'True,1234) + +testKindSignature2D :: Either Msg2 + (Refined2 OU + (Second (ReadP Int Id)) + (PApp2 (Proxy ('(,) :: GL.Symbol -> Bool -> (GL.Symbol,Bool))) (Proxy "bbb") Fst >> Pop0 Id () >> Snd) + (Proxy 'True, String)) +testKindSignature2D = newRefined2 (Proxy @'True,"1234") + +testKindSignature2E :: Either Msg2 + (Refined2 OU + '(Id,4 % 6) + (Pop1 (Proxy (MkJust :: Type -> Type)) L13 Id >> Just' >> Len > 3) + (Int,Int,String)) +testKindSignature2E = newRefined2 (1,2,"defghi") + +-- awkward cos FoldMap t p has p for location of stuff and then we need to run in a context (usually Id relative to p) +testKindSignature2F :: Either Msg2 + (Refined2 OU + (Second (Map (ReadP Int '[Id]))) + (Pop2 (Proxy (FoldMap :: Type -> Type -> Type)) (SG.Product Int) Snd Id >> Id > 4) + (Char,String)) +testKindSignature2F = newRefined2 ('x',"23498") + +testKindSignature2G :: Either Msg2 + (Refined2 OU + (Id <> Id) + (PApp (Proxy ((<>) :: GL.Symbol -> GL.Symbol -> Type)) Id >> PApp Id (Proxy "def") >> Pop0 Id () >> Len > 6) + (Proxy "1234")) +testKindSignature2G = newRefined2 (Proxy @"1234")
test/TestRefined3.hs view
@@ -1,7 +1,3 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} @@ -10,215 +6,204 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoOverloadedLists #-} -- overloaded lists breaks some predicates {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoStarIsType #-} module TestRefined3 where +--module TestRefined3 (suite) where import TastyExtras import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Predicate ---import TestRefined hiding (namedTests,unnamedTests,allProps) ---import Predicate.Refined import Predicate.Refined3 import Predicate.Examples.Refined3 import Predicate.Examples.Common -import Predicate.TH_Orphans () -- need this else refined*TH' fails for dates - import Data.Ratio import Data.Typeable import Control.Lens import Data.Time import GHC.Generics (Generic) import Data.Aeson -import Control.Monad.Cont +import Control.Arrow (left) import Text.Show.Functions () -import Data.Tree ---import Data.Maybe import Data.Tree.Lens +import qualified Safe (readNote) +import Data.Kind (Type) +import qualified GHC.TypeLits as GL + suite :: TestTree suite = let s = "TestRefined3" - in testGroup s (namedTests <> orderTests s unnamedTests <> allProps) + in testGroup s (namedTests <> orderTests s (unnamedTests <> tstextras) <> allProps) 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 "ip9" $ (@?=) (newRefined3 "121.0.12.13" :: Either Msg3 (MakeR3 Ip9)) (Right (unsafeRefined3 [121,0,12,13] "121.000.012.013")) + , testCase "luhn check" $ (@?=) (newRefined3 "12345678903" :: Either Msg3 (MakeR3 (Luhn11 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 Msg3 (MakeR3 (DateTime1 OZ UTCTime))) (Right (unsafeRefined3 (Safe.readNote "testrefined3: utc date" "2019-01-04 23:00:59 UTC") "2019-01-04 23:00:59")) + , testCase "datetime localtime" $ (@?=) (newRefined3 "2019-01-04 09:12:30" :: Either Msg3 (MakeR3 (DateTime1 OZ LocalTime))) (Right (unsafeRefined3 (Safe.readNote "testrefined3: localtime" "2019-01-04 09:12:30") "2019-01-04 09:12:30")) + , testCase "hms" $ (@?=) (newRefined3 "12:0:59" :: Either Msg3 (MakeR3 (Hms OAN))) (Right (unsafeRefined3 [12,0,59] "12:00:59")) + , testCase "between5and9" $ (@?=) (newRefined3 "7" :: Either Msg3 (Refined3 OAN (ReadP Int Id) (Between 5 9 Id) (PrintF "%03d" Id) String)) (Right (unsafeRefined3 7 "007")) + , testCase "ssn" $ (@?=) (newRefined3 "123-45-6789" :: Either Msg3 (MakeR3 (Ssn OAN))) (Right (unsafeRefined3 [123,45,6789] "123-45-6789")) + , testCase "base16" $ (@?=) (newRefined3 "12f" :: Either Msg3 (MakeR3 (BaseN OAN 16))) (Right (unsafeRefined3 303 "12f")) + , testCase "daten1" $ (@?=) (newRefined3 "June 25 1900" :: Either Msg3 (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (Safe.readNote "testrefined3: daten1" "1900-06-25") "1900-06-25")) + , testCase "daten2" $ (@?=) (newRefined3 "12/02/99" :: Either Msg3 (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (Safe.readNote "testrefined3: daten2" "1999-12-02") "1999-12-02")) + , testCase "daten3" $ (@?=) (newRefined3 "2011-12-02" :: Either Msg3 (MakeR3 (DateN OAN))) (Right (unsafeRefined3 (Safe.readNote "testrefined3: daten3" "2011-12-02") "2011-12-02")) + , testCase "ccn123" $ (@?=) (newRefined3 "123455" :: Either Msg3 (MakeR3 (Luhn OAN '[1,2,3]))) (Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455")) + , testCase "readshow" $ (@?=) (newRefined3 "12 % 5" :: Either Msg3 (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) (Between 0 255 Id) (ShowBase 16) String) "Refined3 255 \"ff\"") -- escape quotes cos read instance for String + , (@?=) [] (reads @(Refined3 OAN (ReadBase Int 16) (Between 0 255 Id) (ShowBase 16) String) "Refined3 256 \"100\"") + , (@?=) [(unsafeRefined3 (-1234) "-4d2", "")] (reads @(Refined3 OAN (ReadBase Int 16) (Id < 0) (ShowBase 16) String) "Refined3 (-1234) \"-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 Msg3 (Ip4R OAN)) , 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 @(Luhn OAN '[4,4,3])) "123-45-6---789-03-") + , expectLeft (testRefined3P (Proxy @(Luhn 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 @(Luhn OAN '[4,4,3])) "6433-1000-006") + , expectRight (testRefined3P (Proxy @(Luhn OAN '[4,4,3])) "6433-10000-06") + , expectLeft (testRefined3P (Proxy @(Luhn OAN '[4,4,3])) "6433-1000-000") + , expectRight (testRefined3P (Proxy @(Luhn 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)) - @((Len == 4) && All (Between 0 255 Id) Id) + $ runIdentity $ eval3M @OAN @(Rescan Ip4RE >> HeadFail "failedn" Id >> Map' (ReadP Int Id) Snd) + @((Len == 4) && All (Between 0 255 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)) - @((Len == 4) && All (Between 0 255 Id) Id) + $ runIdentity $ eval3M @OAN @(Rescan Ip4RE >> HeadFail "failedn" Id >> Map' (ReadP Int Id) Snd) + @((Len == 4) && All (Between 0 255 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) + $ runIdentity $ eval3M @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) @"" + $ runIdentity $ eval3M @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 + $ runIdentity $ eval3M @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)) @"" + $ runIdentity $ eval3M @OAN @(Map' (ReadP Int Id) (Resplit "\\.")) @(All (Between 0 255 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" + $ runIdentity $ eval3M @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" + $ runIdentity $ eval3M @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)) - @(Guard "expected 3" (Len == 3) - >> Guard "3 digits" (Ix' 0 >> Between 0 999 Id) - >> Guard "2 digits" (Ix' 1 >> Between 0 99 Id) - >> Guard "4 digits" (Ix' 2 >> Between 0 9999 Id) - >> 'True + $ runIdentity $ eval3M + @OAN @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) + @(GuardBool "expected 3" (Len == 3) + && GuardBool "3 digits" (Between 0 999 (Ix' 0)) + && GuardBool "2 digits" (Between 0 99 (Ix' 1)) + && GuardBool "4 digits" (Between 0 9999 (Ix' 2)) ) @"def" "123-45-6789" , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") - $ eval3 + $ runIdentity $ eval3M @OAN - @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP Id >> Map (ReadBase Int 10 Id) (Snd Id)) + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) @(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" + $ runIdentity $ eval3M @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" + $ runIdentity $ eval3M @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" + $ runIdentity $ eval3M @OAN @Ip6ip @Ip6op @"xyz" "123::Ffff:::11" , expect3 (Right $ unsafeRefined3 [0,0,291,0,65535,0,0,17] "xyz") - $ eval3 @OAN @Ip6ip @Ip6op @"xyz" + $ runIdentity $ eval3M @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)) - @(Ddmmyyyyop >> 'True) + $ runIdentity $ eval3M @OAN @(Rescan DdmmyyyyRE >> OneP >> Map' (ReadBase Int 10) Snd) + @Ddmmyyyyop @"xyz" "31-11-1999" - , 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)) + , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ runIdentity $ eval3M @OAN + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" >> OneP >> Map' (ReadBase Int 10) Snd) @(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") $ runIdentity $ eval3P (ip4 @OZ) "1.2.3.4" + , expect3 (Left $ XF "ReadP Int (3x)") $ runIdentity $ eval3P (ip4 @OZ) "1.2.3x.4" + , expect3 (Left $ XTF [1,2,3,4,5] "Guards:invalid length(5) expected 4") $ runIdentity $ eval3P (ip4 @OZ) "1.2.3.4.5" + , expect3 (Left $ XTF [1,2,300,4] "octet 2 out of range 0-255 found 300") $ runIdentity $ eval3P (ip4 @OZ) "1.2.300.4" + , expect3 (Left $ XTF [1,2,3,4,5] "Bools:invalid length(5) expected 4") $ runIdentity $ eval3P (ip4' @OZ) "1.2.3.4.5" + , expect3 (Left $ XTF [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300]") $ runIdentity $ eval3P (ip4' @OZ) "1.2.300.4" - , 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 (Left (XTF [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)")) $ runIdentity $ eval3P (ip4' @OL) "1.2.300.4" + , expect3 (Right $ unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") $ runIdentity $ eval3P (luhn11 @OAN) "12345678903" + , expect3 (Left $ XTF [1,2,3,4,5,6,7,8,9,0,1] "invalid checkdigit") $ runIdentity $ eval3P (luhn11 @OZ) "12345678901" - , 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 ([12,13,14],TimeOfDay 12 13 14) "12:13:14") $ runIdentity $ eval3P hms2E "12:13:14" - -- 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] "001.002.003.004")) $ runIdentity $ eval3M @OAN @Ip4ip @Ip4op' @(ParaN 4 (PrintF "%03d" Id) >> Intercalate '["."] Id >> Concat) "1.2.3.4" + , expect3 (Right (unsafeRefined3 [1,2,3,4] "abc__002__3__zzz")) $ runIdentity $ eval3M @OAN @Ip4ip @Ip4op' @(Para '[W "abc",PrintF "%03d" Id,PrintF "%d" Id,W "zzz"] >> Intercalate '["__"] Id >> Concat) "1.2.3.4" + + , expect3 (Right $ unsafeRefined3 ("1.2.3.4", [1,2,3,4]) "001.002.003.004") $ runIdentity $ eval3M @OAN @(Id &&& Ip4ip) @(Snd >> Ip4op') @(Snd >> ParaN 4 (PrintF "%03d" Id) >> Intercalate '["."] Id >> Concat) "1.2.3.4" + , Right (unsafeRefined3 4 "someval val=004") @=? newRefined3P (Proxy @Tst1) "4" + , Left FalseP @=? left m3ValP (newRefined3P (Proxy @Tst1) "255") ] 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 "base16" $ forAll (genRefined3P (mkProxy3 @'(OAN, ReadBase Int 16, 'True, ShowBase 16, String)) arbitrary) (\r -> evalQuick @OL @(ReadBase Int 16) (r3Out r) === Right (r3In r)) + , testProperty "readshow" $ forAll (genRefined3 arbitrary :: Gen (HexLtR3 OAN)) (\r -> Safe.readNote @(HexLtR3 OAN) "testrefined3: readshow" (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) - -yy1, yy2, yy3, yy4 :: RefinedT Identity (MakeR3 Tst1) - -yy1 = newRefined3TP (Proxy @Tst1) "4" -yy2 = newRefined3TP (Proxy @Tst1) "3" +type HexLtR3 (opts :: Opt) = Refined3 opts (ReadBase Int 16) (Id < 500) (ShowBase 16) String -yy3 = rapply3 (*) yy1 yy2 -- fails -yy4 = rapply3 (+) yy1 yy2 -- pure () +type Tst1 = '(OAN, ReadP Int Id, Between 1 7 Id, PrintF "someval val=%03d" Id, String) -hms2E :: Proxy '( OAN, Hmsip2, Hmsop2 >> 'True, Hmsfmt2, String) +hms2E :: Proxy '(OAN, Hmsip2, Hmsop2, Hmsfmt2, String) hms2E = mkProxy3 -type Hmsip2 = Hmsip &&& ParseTimeP TimeOfDay "%H:%M:%S" Id -type Hmsop2 = Fst Id >> Hmsop -type Hmsfmt2 = Snd Id >> FormatTimeP "%T" Id +type Hmsip2 = Hmsip &&& ParseTimeP TimeOfDay "%H:%M:%S" +type Hmsop2 = Fst >> Hmsop +type Hmsfmt2 = FormatTimeP' "%T" Snd --- better to use Guard for op boolean check cos we get better errormessages +-- use GuardBool for op boolean check to 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 "\\."), (Len == 4) && All (Between 0 255 Id), Lift Concat $ Intercalate '["."] $ Map (PrintF "%03d" Id), String) -www1, www2 :: String -> Either String (MakeR3 Tst3) +www1, www2 :: String -> Either Msg3 (MakeR3 Tst3) www1 = newRefined3P (mkProxy3 @Tst3) www2 = newRefined3P tst3 @@ -226,38 +211,38 @@ -- 2. packaged as a proxy tst3 :: Proxy - '( OAN, Map (ReadP Int Id) (Resplit "\\." Id) - ,(Len == 4) && All (Between 0 255 Id) Id - ,ConcatMap (PrintF "%03d" Id) Id + '(OAN, Map' (ReadP Int Id) (Resplit "\\.") + ,(Len == 4) && All (Between 0 255 Id) + ,Lift Concat $ Intercalate '["."] $ Map (PrintF "%03d" Id) ,String) tst3 = mkProxy3 -- 3. direct -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) +www3, www3' :: String -> Either Msg3 (Refined3 OAN + (Map' (ReadP Int Id) (Resplit "\\.")) + ((Len == 4) && All (Between 0 255 Id)) + (Lift Concat $ Intercalate '["."] $ Map (PrintF "%03d" Id)) String) -ww3 = newRefined3 +www3 = newRefined3 -ww3' = newRefined3 +www3' = newRefined3 @OAN - @(Map (ReadP Int Id) (Resplit "\\." Id)) - @((Len == 4) && All (Between 0 255 Id) Id) - @(ConcatMap (PrintF "%03d" Id) Id) + @(Map' (ReadP Int Id) (Resplit "\\.")) + @((Len == 4) && All (Between 0 255 Id)) + @(Lift Concat $ Intercalate '["."] $ Map (PrintF "%03d" Id)) -data G4 = G4 { g4Age :: MakeR3 Age - , g4Ip :: MakeR3 Ip9 +data G4 = G4 { g4Age :: !(MakeR3 Age) + , 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 - ,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 + ,Map' (ReadP Int Id) (Resplit "\\.") -- split String on "." then convert to [Int] + ,Len == 4 && All (Between 0 255 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] ,String -- input type is string which is also the output type ) @@ -265,31 +250,34 @@ instance FromJSON G4 instance ToJSON G4 -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") +tstextras :: [Assertion] +tstextras = + [ newRefined3P (daten @OAN) "June 25 1900" @?= Right (unsafeRefined3 (fromGregorian 1900 6 25) "1900-06-25") + , newRefined3P (daten @OAN) "12/02/19" @?= Right (unsafeRefined3 (fromGregorian 2019 12 2) "2019-12-02") + , newRefined3P (Proxy @(Luhn OAN '[1,1,1,1])) "1230" @?= Right (unsafeRefined3 [1,2,3,0] "1-2-3-0") + , newRefined3P (Proxy @(Luhn OAN '[1,2,3])) "123455" @?= Right (unsafeRefined3 [1,2,3,4,5,5] "1-23-455") +-- , runIdentity (unRavelTValP $ tst1a @OAN @Identity) @?= Right ((163,"a3"),(12,"12")) +-- , runIdentity (unRavelTValP yy1) ^? _Right @?= Just (unsafeRefined3 4 "someval val=004") +-- , runIdentity (unRavelTValP yy2) ^? _Right @?= Just (unsafeRefined3 3 "someval val=003") +-- , runIdentity (unRavelTString yy3) ^? _Left @?= Just "Step 2. False Boolean Check(op) | {12 <= 7}" +-- , runIdentity (unRavelTValP yy4) ^? _Right @?= Just (unsafeRefined3 7 "someval val=007") + , www1 "1.2.3.4" @?= Right (unsafeRefined3 [1,2,3,4] "001.002.003.004") + , www2 "1.2.3.4" @?= Right (unsafeRefined3 [1,2,3,4] "001.002.003.004") + , www3 "1.2.3.4" @?= Right (unsafeRefined3 [1,2,3,4] "001.002.003.004") + , www3' "1.2.3.4" @?= Right (unsafeRefined3 [1,2,3,4] "001.002.003.004") + , tst1a @'OAN @=? Right ((163,"a3"),(12,"12")) ] --- 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" - $ \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" - $ \r2 -> return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) +tst1a :: forall (opts :: Opt) . OptC opts => Either Msg3 ((Int,String),(Int,String)) +tst1a = do + r1 <- newRefined3 @opts @(ReadBase Int 16) @(Between 100 200 Id) @(ShowBase 16) @String "a3" + r2 <- newRefined3 @opts @(ReadP Int Id) @'True @(ShowP Id) @String "12" + return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) -- have to use 'i' as we dont hold onto the input testRefined3PJ :: forall opts ip op fmt i proxy . (ToJSON (PP fmt (PP ip i)) , Show (PP ip i) - , Show (PP fmt (PP ip i)) , Refined3C opts ip op fmt i , FromJSON i ) @@ -297,11 +285,9 @@ -> i -> Either String (Refined3 opts ip op fmt i) testRefined3PJ _ i = - let (ret,mr) = eval3 @opts @ip @op @fmt i - m3 = prt3Impl (getOptT @opts) ret - in case mr of - Just r -> eitherDecode @(Refined3 opts ip op fmt i) $ encode r - Nothing -> Left $ show m3 + case newRefined3 @opts @ip @op @fmt i of + Right r -> eitherDecode @(Refined3 opts ip op fmt i) $ encode r + Left e -> Left $ show e -- test that roundtripping holds ie i ~ PP fmt (PP ip i) testRefined3P :: forall opts ip op fmt i proxy @@ -309,67 +295,72 @@ , Show (PP fmt (PP ip i)) , Refined3C opts ip op fmt i , Eq i - , Eq (PP ip i)) - => proxy '(opts,ip,op,fmt,i) - -> i - -> Either (String,String) (Refined3 opts ip op fmt i, Refined3 opts ip op fmt i) -testRefined3P _ i = - let (ret,mr) = eval3 @opts @ip @op @fmt i - o = getOptT @opts - m3 = prt3Impl o ret - in case mr of - Just r -> - let (ret1,mr1) = eval3 @opts @ip @op @fmt (r3Out r) - m3a = prt3Impl o ret1 - in case mr1 of - Nothing -> Left ("testRefined3P(2): round trip failed: old(" ++ show i ++ ") new(" ++ show (r3Out r) ++ ")", show m3a) - Just r1 -> - if r /= r1 then Left ("testRefined3P(3): round trip pure () but values dont match: old(" ++ show i ++ ") new(" ++ show (r3Out r) ++ ")", show (r,r1)) - else Right (r,r1) - Nothing -> Left ("testRefined3P(1): bad initial predicate i=" ++ show i, show m3) - -testRefined3PIO :: forall opts ip op fmt i proxy - . ( Show (PP ip i) - , Show (PP fmt (PP ip i)) - , Refined3C opts ip op fmt i - , Eq i , Eq (PP ip i) ) => proxy '(opts,ip,op,fmt,i) -> i - -> IO (Either String (Refined3 opts ip op fmt i, Refined3 opts ip op fmt i)) -testRefined3PIO p i = - case testRefined3P p i of - Right (r,r1) -> return $ Right (r,r1) - Left (msg, e) -> putStrLn e >> return (Left msg) - -getTTs3 :: RResults3 a b -> [Tree PE] -getTTs3 = \case - RF _ t1 -> [t1] - RTF _ t1 _ t2 -> [t1,t2] - RTFalse _ t1 t2 -> [t1,t2] - RTTrueF _ t1 t2 _ t3 -> [t1,t2,t3] - RTTrueT _ t1 t2 _ t3 -> [t1,t2,t3] + -> Either (String,String) (Refined3 opts ip op fmt i, Refined3 opts ip op fmt i) +testRefined3P _ i = + case newRefined3 @opts @ip @op @fmt i of + Right r -> + case newRefined3 @opts @ip @op @fmt (r3Out r) of + Left e -> Left ("testRefined3P(2): round trip failed: old(" ++ show i ++ ") new(" ++ show (r3Out r) ++ ")", show e) + Right r1 -> + if r /= r1 then Left ("testRefined3P(3): round trip pure () but values dont match: old(" ++ show i ++ ") new(" ++ show (r3Out r) ++ ")", show (r,r1)) + else Right (r,r1) + Left e -> Left ("testRefined3P(1): bad initial predicate i=" ++ show i, show e) -data Results3 a b = - XF String -- Left e - | XTF a String -- Right a + Left e - | XTFalse a String -- Right a + Right False - | XTTrueF a String -- Right a + Right True + Left e - | XTTrueT a b -- Right a + Right True + Right b +data Results3 a = + XF !String -- Left e + | XTF !a !String -- Right a + Left e + | XTFalse !a !String -- Right a + Right False + | XTTrueF !a !String -- Right a + Right True + Left e + | XTTrueT !a -- Right a + Right True + Right b deriving (Show,Eq) -toRResults3 :: RResults3 a b -> Results3 a b +toRResults3 :: RResults3 a -> Results3 a toRResults3 = \case RF e _ -> XF e RTF a _ e _ -> XTF a e - RTFalse a _ t2 -> XTFalse a (t2 ^. root . pString) + RTFalse a _ t2 -> XTFalse a (t2 ^. root . peString) RTTrueF a _ _ e _ -> XTTrueF a e - RTTrueT a _ _ b _ -> XTTrueT a b + RTTrueT a _ _ _ -> XTTrueT a -expect3 :: (HasCallStack, Show i, Show r, Eq i, Eq r, Eq j, Show j) - => Either (Results3 i j) r - -> (RResults3 i j, Maybe r) +expect3 :: (HasCallStack, Show i, Show r, Eq i, Eq r) + => Either (Results3 i) r + -> (RResults3 i, Maybe r) -> IO () expect3 lhs (rhs,mr) = (@?=) (maybe (Left $ toRResults3 rhs) Right mr) lhs + +testKindSignature3A :: Either Msg3 + (Refined3 OU + Id + (PApp (Proxy (Lift "abc" :: Type -> Type)) (Proxy ()) >> 'True) + Id + ()) +testKindSignature3A = newRefined3 () + +testKindSignature3B :: Either Msg3 + (Refined3 OU + Id + (Pop1' (Proxy (Lift "abc" :: GL.Nat -> Type)) (Proxy 4) () >> 'True) + Id + ()) +testKindSignature3B = newRefined3 () + +testKindSignature3C :: Either Msg3 + (Refined3 OU + Id + (Pop2' (Proxy ('(,) :: Type -> Bool -> (Type,Bool))) (Proxy (W "bbb")) Fst Snd >> Snd) + Id + (Proxy 'True, Int)) +testKindSignature3C = newRefined3 (Proxy @'True,1234) + +testKindSignature3D :: Either Msg3 + (Refined3 OU + (Second (ReadP Int Id)) + (PApp2 (Proxy ('(,) :: GL.Symbol -> Bool -> (GL.Symbol,Bool))) (Proxy "bbb") Fst >> Pop0 Id () >> Snd) + (Second (ShowP Id)) + (Proxy 'True, String)) +testKindSignature3D = newRefined3 (Proxy @'True,"1234")
test/TestSpec.hs view
@@ -4,7 +4,6 @@ import qualified TestRefined import qualified TestRefined2 import qualified TestRefined3 -import Data.Functor import Test.Tasty import System.IO