summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorgbwey <>2020-11-20 21:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-11-20 21:44:00 (GMT)
commitb505784aed58405327c7e3ece85b12c5fd9db932 (patch)
tree3585a2b6047be9e710a5bd897c7270d017fc2937
parentca2bbb1c2ddd3722c2a310bec1fdd195b7a41cb6 (diff)
version 0.7.4.5HEAD0.7.4.5master
-rw-r--r--doctest/doctests.hs2
-rw-r--r--predicate-typed.cabal16
-rw-r--r--src/Predicate.hs70
-rw-r--r--src/Predicate/Core.hs5
-rw-r--r--src/Predicate/Data/Bits.hs2
-rw-r--r--src/Predicate/Data/Char.hs2
-rw-r--r--src/Predicate/Data/Condition.hs18
-rw-r--r--src/Predicate/Data/DateTime.hs2
-rw-r--r--src/Predicate/Data/Either.hs3
-rw-r--r--src/Predicate/Data/Elr.hs13
-rw-r--r--src/Predicate/Data/Enum.hs2
-rw-r--r--src/Predicate/Data/Extra.hs3
-rw-r--r--src/Predicate/Data/Foldable.hs2
-rw-r--r--src/Predicate/Data/IO.hs2
-rw-r--r--src/Predicate/Data/Index.hs2
-rw-r--r--src/Predicate/Data/Iterator.hs5
-rw-r--r--src/Predicate/Data/Json.hs2
-rw-r--r--src/Predicate/Data/Lifted.hs7
-rw-r--r--src/Predicate/Data/List.hs35
-rw-r--r--src/Predicate/Data/Maybe.hs3
-rw-r--r--src/Predicate/Data/Monoid.hs2
-rw-r--r--src/Predicate/Data/Numeric.hs4
-rw-r--r--src/Predicate/Data/Ordering.hs2
-rw-r--r--src/Predicate/Data/Proxy.hs39
-rw-r--r--src/Predicate/Data/ReadShow.hs2
-rw-r--r--src/Predicate/Data/Regex.hs2
-rw-r--r--src/Predicate/Data/String.hs4
-rw-r--r--src/Predicate/Data/These.hs5
-rw-r--r--src/Predicate/Data/Tuple.hs2
-rw-r--r--src/Predicate/Elr.hs99
-rw-r--r--src/Predicate/Examples/Common.hs18
-rw-r--r--src/Predicate/Examples/Refined2.hs184
-rw-r--r--src/Predicate/Examples/Refined3.hs201
-rw-r--r--src/Predicate/Misc.hs171
-rw-r--r--src/Predicate/Prelude.hs61
-rw-r--r--src/Predicate/Refined.hs2
-rw-r--r--src/Predicate/Refined2.hs50
-rw-r--r--src/Predicate/Refined3.hs7
-rw-r--r--src/Predicate/Refined5.hs4
-rw-r--r--src/Predicate/TH_Orphans.hs31
-rw-r--r--src/Predicate/Util.hs52
-rw-r--r--src/Predicate/Util_TH.hs4
-rw-r--r--test/TastyExtras.hs1
-rw-r--r--test/TestJson.hs2
-rw-r--r--test/TestPredicate.hs2
-rw-r--r--test/TestRefined.hs2
-rw-r--r--test/TestRefined2.hs9
-rw-r--r--test/TestRefined3.hs10
-rw-r--r--test/TestSpec.hs1
49 files changed, 601 insertions, 568 deletions
diff --git a/doctest/doctests.hs b/doctest/doctests.hs
index 5d8540b..14da1cf 100644
--- a/doctest/doctests.hs
+++ b/doctest/doctests.hs
@@ -5,5 +5,5 @@ main = doctest ["src","-XNoStarIsType"]
--main = doctest ["src","--verbose","-XNoStarIsType"]
--- stack exec doctest -- "src/Predicate/Prelude.hs"
+-- stack exec doctest -- "src/Predicate.hs"
-- stack exec doctest -- src
diff --git a/predicate-typed.cabal b/predicate-typed.cabal
index 968dbc3..1b8b09c 100644
--- a/predicate-typed.cabal
+++ b/predicate-typed.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 8623bd3c0ca7069a75570832de0252b98526987f85c470818360b345547a9cff
+-- hash: 7b8641d98523b7ba560d78a888fe80718f2be98e8926561aadf2c52fb60cac8e
name: predicate-typed
-version: 0.7.4.4
+version: 0.7.4.5
synopsis: Predicates, Refinement types and Dsl
description: Please see the README on GitHub at <https://github.com/gbwey/predicate-typed#readme>
category: Data
@@ -58,12 +58,10 @@ library
Predicate.Examples.Refined2
Predicate.Examples.Refined3
Predicate.Misc
- Predicate.Prelude
Predicate.Refined
Predicate.Refined2
Predicate.Refined3
Predicate.Refined5
- Predicate.TH_Orphans
Predicate.Util
Predicate.Util_TH
other-modules:
@@ -88,11 +86,8 @@ library
, pcre-light
, pretty-terminal >=0.1.0.0
, safe
- , string-conversions
, template-haskell
, text
- , th-lift
- , th-lift-instances
, these >=0.8
, time
if impl(ghc >= 8.8)
@@ -127,11 +122,8 @@ test-suite doctests
, predicate-typed
, pretty-terminal >=0.1.0.0
, safe
- , string-conversions
, template-haskell
, text
- , th-lift
- , th-lift-instances
, these >=0.8
, time
if impl(ghc >= 8.8)
@@ -171,15 +163,11 @@ test-suite predicate-typed-test
, predicate-typed
, pretty-terminal >=0.1.0.0
, safe
- , stm
- , string-conversions
, tasty
, tasty-hunit
, tasty-quickcheck
, template-haskell
, text
- , th-lift
- , th-lift-instances
, these >=0.8
, time
if impl(ghc >= 8.8)
diff --git a/src/Predicate.hs b/src/Predicate.hs
index 9aa44cf..1d28b74 100644
--- a/src/Predicate.hs
+++ b/src/Predicate.hs
@@ -1,18 +1,68 @@
-- | 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
+-- "Predicate.Refined2" and "Predicate.Refined3" hold the more advanced refinement
--
module Predicate (
- module Predicate.Core
- , module Predicate.Prelude
- , module Predicate.Util
- , module Predicate.Util_TH
- , module Predicate.Refined
+ module Predicate.Core
+ , module Predicate.Elr
+ , module Predicate.Misc
+ , module Predicate.Refined
+ , module Predicate.Util
+ , module Predicate.Util_TH
+ , module Predicate.Data.Bits
+ , module Predicate.Data.Char
+ , module Predicate.Data.Condition
+ , module Predicate.Data.DateTime
+ , module Predicate.Data.Either
+ , module Predicate.Data.Elr
+ , module Predicate.Data.Enum
+ , module Predicate.Data.Extra
+ , module Predicate.Data.Foldable
+ , module Predicate.Data.Index
+ , 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
+ , module Predicate.Data.These
+ , module Predicate.Data.Tuple
) where
import Predicate.Core
+import Predicate.Elr
+import Predicate.Misc
+import Predicate.Refined
import Predicate.Util
import Predicate.Util_TH
-import Predicate.Prelude
-import Predicate.Refined
-import Predicate.TH_Orphans ()
-import Instances.TH.Lift () \ No newline at end of file
+import Predicate.Data.Bits
+import Predicate.Data.Char
+import Predicate.Data.Condition
+import Predicate.Data.DateTime
+import Predicate.Data.Either
+import Predicate.Data.Elr
+import Predicate.Data.Enum
+import Predicate.Data.Extra
+import Predicate.Data.Foldable
+import Predicate.Data.Index
+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
+import Predicate.Data.These
+import Predicate.Data.Tuple
diff --git a/src/Predicate/Core.hs b/src/Predicate/Core.hs
index 76b594c..c1d6d78 100644
--- a/src/Predicate/Core.hs
+++ b/src/Predicate/Core.hs
@@ -145,7 +145,7 @@ import qualified Data.Semigroup as SG
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import Data.Time
-- >>> :m + Control.Lens
-- >>> :m + Control.Lens.Action
@@ -1985,6 +1985,7 @@ instance (P (DoExpandT ps) a) => P (Do ps) a where
eval _ = eval (Proxy @(DoExpandT ps))
-- need both :: Type and (Id >> p or W)
+-- | expand out a type level list of commands using 'Predicate.Core.>>' (associates to the right)
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]) ()
@@ -2009,6 +2010,7 @@ instance (P (DoExpandLT ps) a) => P (DoL ps) a where
type PP (DoL ps) a = PP (DoExpandLT ps) a
eval _ = eval (Proxy @(DoExpandLT ps))
+-- | like 'DoExpandT' but associates to the left
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
@@ -2477,6 +2479,7 @@ instance x ~ SG.Arg a b => P Arg' x where
ret = (a,b)
in pure $ mkNode opts (Val ret) msg0 []
+-- | calculates the return type for 'Arg''
type family ArgT (x :: Type) where
ArgT (SG.Arg a b) = (a,b)
ArgT o = GL.TypeError (
diff --git a/src/Predicate/Data/Bits.hs b/src/Predicate/Data/Bits.hs
index d142e58..89adf4c 100644
--- a/src/Predicate/Data/Bits.hs
+++ b/src/Predicate/Data/Bits.hs
@@ -47,7 +47,7 @@ import Data.Bits (Bits(..))
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | bitwise @and@ similar to 'Data.Bits..&.'
--
diff --git a/src/Predicate/Data/Char.hs b/src/Predicate/Data/Char.hs
index f80f768..fcb23c4 100644
--- a/src/Predicate/Data/Char.hs
+++ b/src/Predicate/Data/Char.hs
@@ -67,7 +67,7 @@ import qualified Data.Type.Equality as DE
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | extracts the first character from a non empty 'GHC.TypeLits.Symbol'
--
diff --git a/src/Predicate/Data/Condition.hs b/src/Predicate/Data/Condition.hs
index 02bad16..fc68e5e 100644
--- a/src/Predicate/Data/Condition.hs
+++ b/src/Predicate/Data/Condition.hs
@@ -36,7 +36,6 @@ module Predicate.Data.Condition (
-- ** type families
, ToGuardsT
, ToGuardsDetailT
- , GuardsT
) where
import Predicate.Core
import Predicate.Misc
@@ -50,7 +49,7 @@ import Data.Kind (Type)
import Data.Void (Void)
import qualified Data.Type.Equality as DE
-- $setup
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
@@ -126,16 +125,12 @@ instance ( Show (PP r a)
Left e -> e
Right ret -> mkNodeCopy opts qqrr (msg0 <> " '" <> show b <> " " <> showL opts ret) [hh pp]
-type family GuardsT (ps :: [k]) where
- GuardsT '[] = '[]
- GuardsT (p ': ps) = Guard "fromGuardsT" p ': GuardsT ps
-
---type Guards' (ps :: [k]) = Para (GuardsT ps)
-
---type ToGuards (prt :: k) (os :: [k1]) = Proxy (Guards (ToGuardsT prt os))
-
+-- | expands out the condition parameter used by 'Guards' and 'Bools'
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: prt="
+ ':<>:
+ 'GL.ShowType prt)
ToGuardsT prt '[p] = '(prt,p) : '[]
ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps
@@ -673,6 +668,7 @@ 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))
+-- | expands out the condition parameter used by 'GuardsDetail'
type family ToGuardsDetailT (prt :: k1) (os :: [(k2,k3)]) :: [(Type,k3)] where
ToGuardsDetailT prt '[ '(s,p) ] = '(PrintT prt '(s,Snd), p) : '[]
ToGuardsDetailT prt ( '(s,p) ': ps) = '(PrintT prt '(s,Snd), p) ': ToGuardsDetailT prt ps
diff --git a/src/Predicate/Data/DateTime.hs b/src/Predicate/Data/DateTime.hs
index 88506c1..a8027aa 100644
--- a/src/Predicate/Data/DateTime.hs
+++ b/src/Predicate/Data/DateTime.hs
@@ -65,7 +65,7 @@ import qualified Data.Time.Clock.POSIX as P
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import Safe (readNote)
-- | type level expression representing a formatted time
diff --git a/src/Predicate/Data/Either.hs b/src/Predicate/Data/Either.hs
index f9a7a9a..f18fe19 100644
--- a/src/Predicate/Data/Either.hs
+++ b/src/Predicate/Data/Either.hs
@@ -63,7 +63,7 @@ import Data.Either (isLeft, isRight, partitionEithers)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- | extracts the left value from an 'Either'
@@ -634,6 +634,7 @@ instance ( Show a
Left e -> e
Right c -> mkNodeCopy opts qq (show3 opts msg1 c b) hhs
+-- | calculate the return type for 'EitherIn'
type family EitherInT (p :: k) (y :: Type) (lr :: Type) where
EitherInT p y (Either a _) = PP p (y,a)
EitherInT _ _ o = GL.TypeError (
diff --git a/src/Predicate/Data/Elr.hs b/src/Predicate/Data/Elr.hs
index 49f1794..44faf0c 100644
--- a/src/Predicate/Data/Elr.hs
+++ b/src/Predicate/Data/Elr.hs
@@ -64,7 +64,7 @@ import Control.Lens
import Data.Proxy (Proxy(..))
import Data.These (These)
-- $setup
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> :m + Data.These
@@ -206,9 +206,14 @@ instance ( x ~ Elr a b
type PP (IsElr th) x = Bool
eval _ opts x =
let msg0 = "Is"
- (t,f) = getElr @_ @_ @th
- b = f x
- in pure $ mkNodeB opts b (msg0 <> t <> showVerbose opts " | " x) []
+ th = getElr @th
+ fn = case th of
+ ENone -> isENone
+ ELeft () -> isELeft
+ ERight () -> isERight
+ EBoth () () -> isEBoth
+ b = fn x
+ in pure $ mkNodeB opts b (msg0 <> showElr th <> showVerbose opts " | " x) []
-- | predicate on 'ENone'
--
diff --git a/src/Predicate/Data/Enum.hs b/src/Predicate/Data/Enum.hs
index 6589c36..aa6f2c8 100644
--- a/src/Predicate/Data/Enum.hs
+++ b/src/Predicate/Data/Enum.hs
@@ -57,7 +57,7 @@ import Control.Lens (under,enum)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> import Data.Time
diff --git a/src/Predicate/Data/Extra.hs b/src/Predicate/Data/Extra.hs
index 6efa745..6d40c5f 100644
--- a/src/Predicate/Data/Extra.hs
+++ b/src/Predicate/Data/Extra.hs
@@ -58,7 +58,7 @@ import Data.Bool (bool)
-- >>> :set -XTypeOperators
-- >>> import qualified Data.Text as T
-- >>> import qualified Data.Sequence as Seq
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> import Data.These
@@ -543,5 +543,4 @@ luhnImpl :: Bool -> [Int] -> [Int]
luhnImpl b ws =
let xs = zipWith (*) ws (cycle' (bool [1,2] [2,1] b))
in map (ifM (>=10) (subtract 9) id) xs
- -- in map (\w -> if w>=10 then w-9 else w) xs
diff --git a/src/Predicate/Data/Foldable.hs b/src/Predicate/Data/Foldable.hs
index d5a2ae4..52dd504 100644
--- a/src/Predicate/Data/Foldable.hs
+++ b/src/Predicate/Data/Foldable.hs
@@ -56,7 +56,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import qualified GHC.Exts as GE
import Data.List (findIndex)
-- $setup
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
diff --git a/src/Predicate/Data/IO.hs b/src/Predicate/Data/IO.hs
index 8c6ac4b..26d84a2 100644
--- a/src/Predicate/Data/IO.hs
+++ b/src/Predicate/Data/IO.hs
@@ -64,7 +64,7 @@ import qualified Data.ByteString.Char8 as BS8
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | similar to 'System.IO.readFile'
--
diff --git a/src/Predicate/Data/Index.hs b/src/Predicate/Data/Index.hs
index fe1aad8..a548857 100644
--- a/src/Predicate/Data/Index.hs
+++ b/src/Predicate/Data/Index.hs
@@ -43,7 +43,7 @@ import Data.Proxy (Proxy(..))
-- >>> import qualified Data.Map.Strict as M
-- >>> import qualified Data.Set as Set
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- | index a value in an 'Ixed' container and if not found return the given default value
diff --git a/src/Predicate/Data/Iterator.hs b/src/Predicate/Data/Iterator.hs
index 5bee915..7a7f195 100644
--- a/src/Predicate/Data/Iterator.hs
+++ b/src/Predicate/Data/Iterator.hs
@@ -56,7 +56,7 @@ import Control.Arrow (Arrow((&&&)))
import Data.Void (Void)
-- $setup
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
@@ -354,6 +354,7 @@ instance ( PP q a ~ s
let ret = fst <$> catMaybes vals
in mkNode opts (Val ret) (show3' opts msg1 ret "s=" q) (hh qq : map (hh . prefixNumberToTT) itts)
+-- | calculate the return type for 'Unfoldr'
type family UnfoldrT (mbs :: Type) where
UnfoldrT (Maybe (b, _)) = b
UnfoldrT o = GL.TypeError (
@@ -499,8 +500,6 @@ instance ( KnownNat n
pp <- eval (Proxy @p) opts a
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 ->
let ret = [b]
in mkNode opts (Val ret) (msgbase1 <> " " <> showL opts ret <> showVerbose opts " | " a) [hh pp]
diff --git a/src/Predicate/Data/Json.hs b/src/Predicate/Data/Json.hs
index 1694939..504ab32 100644
--- a/src/Predicate/Data/Json.hs
+++ b/src/Predicate/Data/Json.hs
@@ -43,7 +43,7 @@ import Data.Bool (bool)
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | parse json data using the type @t@
data ParseJson' t p deriving Show
diff --git a/src/Predicate/Data/Lifted.hs b/src/Predicate/Data/Lifted.hs
index 6309925..4847ace 100644
--- a/src/Predicate/Data/Lifted.hs
+++ b/src/Predicate/Data/Lifted.hs
@@ -99,7 +99,7 @@ import Data.Coerce (Coercible)
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> import Data.Functor.Identity
-- >>> import Data.These
@@ -763,6 +763,7 @@ 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))
+-- | calculates the return type for 'Dot'
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
@@ -783,6 +784,7 @@ 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))
+-- | calculates the return type for 'RDot'
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
@@ -1120,6 +1122,9 @@ instance ( P p x
-- >>> pz @(FPair (EnumFromTo Fst Snd) ('LT ... 'GT)) (10,11)
-- Val [(10,LT),(10,EQ),(10,GT),(11,LT),(11,EQ),(11,GT)]
--
+-- >>> pz @(FPair '[ '() ] (1 ... 5)) True
+-- Val [((),1),((),2),((),3),((),4),((),5)]
+--
data FPair p q deriving Show
instance ( Applicative n
diff --git a/src/Predicate/Data/List.hs b/src/Predicate/Data/List.hs
index 152ceb7..d7637d9 100644
--- a/src/Predicate/Data/List.hs
+++ b/src/Predicate/Data/List.hs
@@ -47,7 +47,6 @@ module Predicate.Data.List (
, ZipR
, Zip
, ZipWith
- , ZipCartesian
, ZipPad
-- ** higher order methods
@@ -112,7 +111,6 @@ import Control.Arrow (Arrow((***), (&&&)))
import qualified Data.Sequence as Seq
import Data.Bool (bool)
import qualified Data.Map.Strict as M
-import Control.Applicative (liftA2)
import Data.Containers.ListUtils (nubOrd)
import qualified Data.List.NonEmpty as NE
-- $setup
@@ -125,7 +123,7 @@ import qualified Data.List.NonEmpty as NE
-- >>> import qualified Data.Semigroup as SG
-- >>> import qualified Data.Text as T
-- >>> import Data.These
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | similar to (++)
--
@@ -2118,37 +2116,6 @@ instance ( x ~ [a]
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 ((_,p),(_,q)) ->
- let d = liftA2 (,) p q
- in mkNode opts (Val d) (show3' opts msg0 d "p=" p <> showVerbose opts " | q=" q) hhs
-
-- | 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
--
diff --git a/src/Predicate/Data/Maybe.hs b/src/Predicate/Data/Maybe.hs
index 058b95c..2006e84 100644
--- a/src/Predicate/Data/Maybe.hs
+++ b/src/Predicate/Data/Maybe.hs
@@ -57,7 +57,7 @@ import qualified GHC.TypeLits as GL
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Map.Strict as M
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- | similar to 'Data.Maybe.fromJust'
@@ -381,6 +381,7 @@ instance ( Show a
Left e -> e
Right c -> mkNodeCopy opts pp (show3 opts msg1 c a) hhs
+-- | calculate the return type for 'MaybeIn'
type family MaybeInT (p :: k) (y :: Type) (ma :: Type) where
MaybeInT p y (Maybe a) = PP p (y,a)
MaybeInT _ _ o = GL.TypeError (
diff --git a/src/Predicate/Data/Monoid.hs b/src/Predicate/Data/Monoid.hs
index 8ae632a..70fd0e0 100644
--- a/src/Predicate/Data/Monoid.hs
+++ b/src/Predicate/Data/Monoid.hs
@@ -41,7 +41,7 @@ import Data.List.NonEmpty (NonEmpty(..))
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> import Data.Functor.Identity
diff --git a/src/Predicate/Data/Numeric.hs b/src/Predicate/Data/Numeric.hs
index ee59199..78fc4d8 100644
--- a/src/Predicate/Data/Numeric.hs
+++ b/src/Predicate/Data/Numeric.hs
@@ -85,7 +85,7 @@ import Control.Lens
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> import Data.Time
@@ -1108,7 +1108,7 @@ 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': doesn't enforce that the values are in range of the given base
+-- | reverse 'ShowBaseN': does not enforce that the values are in range of the given base
--
-- >>> pz @(UnShowBaseN 2 Id) [1,0,0,1,0]
-- Val 18
diff --git a/src/Predicate/Data/Ordering.hs b/src/Predicate/Data/Ordering.hs
index 1b9aeae..d39952a 100644
--- a/src/Predicate/Data/Ordering.hs
+++ b/src/Predicate/Data/Ordering.hs
@@ -68,7 +68,7 @@ import Data.Function (on)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- | compare if expression @p@ is greater than @q@
--
diff --git a/src/Predicate/Data/Proxy.hs b/src/Predicate/Data/Proxy.hs
index 5074df4..9fb06e2 100644
--- a/src/Predicate/Data/Proxy.hs
+++ b/src/Predicate/Data/Proxy.hs
@@ -35,9 +35,9 @@ module Predicate.Data.Proxy (
, Proxy2TT
, Pop0T
, Pop1T
- , Pop1'T
+ , Pop1T'
, Pop2T
- , Pop2'T
+ , Pop2T'
, PAppT
, PApp2T
, ProxifyT
@@ -54,7 +54,7 @@ import Control.Lens
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import Control.Lens
-- >>> import Control.Lens.Action
-- >>> import qualified Data.Semigroup as SG
@@ -128,6 +128,7 @@ instance P Proxy2T x where
let b = Proxy @(Proxy2TT x)
in pure $ mkNode opts (Val b) "Proxy2T" []
+-- | calculate the resulting type for 'Proxy2T'
type family Proxy2TT (x :: Type) :: (Type -> Type) where
Proxy2TT (t a _) = t a
@@ -210,6 +211,7 @@ instance ( P q x
Right _z -> mkNodeCopy opts zz (joinStrings msg0 (zz ^. ttString)) [hh qq]
-- the key is to pass all the vars into the type family so ghc can figure stuff out
+-- | calculate the resulting type for 'Pop0'
type family Pop0T (p :: Type) (q :: Type) :: Type where
Pop0T (Proxy z) q = PP z q
Pop0T (_proxy z) q = PP z q
@@ -270,6 +272,7 @@ instance ( P r x
Left e -> e
Right _z -> mkNodeCopy opts zz (joinStrings msg0 (zz ^. ttString)) [hh rr]
+-- | calculate the resulting type for 'Pop1'
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
@@ -320,7 +323,7 @@ instance ( P r x
, 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)
+ type PP (Pop1' p q r) x = Pop1T' (PP p x) (PP q x) (PP r x)
eval _ opts x = do
let msg0 = "Pop1'"
rr <- eval (Proxy @r) opts x
@@ -332,12 +335,13 @@ instance ( P r x
Left e -> e
Right _z -> mkNodeCopy opts zz (joinStrings msg0 (zz ^. ttString)) [hh rr]
-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 =
+-- | calculate the resulting type for 'Pop1''
+type family Pop1T' (p :: Type) (q :: Type) (r :: Type) :: Type where
+ Pop1T' (Proxy z) (Proxy w) r = PP (z w) r
+-- Pop1T' (Proxy (z :: k -> k1)) (Proxy (w :: k)) r = PP (z w :: k1) r
+ Pop1T' p q r =
GL.TypeError (
- 'GL.Text "Pop1'T: requires 'Proxy z' and z must be a function requiring one parameter!!"
+ '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
@@ -370,6 +374,7 @@ instance ( P s x
Right _z -> mkNodeCopy opts zz (joinStrings msg0 (zz ^. ttString)) [hh ss]
-- pass all the arguments in!!! else ghc gets confused
+-- | calculate the resulting type for 'Pop2'
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
@@ -401,7 +406,7 @@ instance ( P s x
, 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)
+ type PP (Pop2' p q r s) x = Pop2T' (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
@@ -414,12 +419,13 @@ instance ( P s x
Right _z -> mkNodeCopy opts zz (joinStrings msg0 (zz ^. ttString)) [hh ss]
-- 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 =
+-- | calculate the resulting type for 'Pop2''
+type family Pop2T' (p :: Type) (q :: Type) (r :: Type) (s :: Type) :: Type where
+ Pop2T' (Proxy z) (Proxy w) (Proxy v) s = PP (z w v) s
+-- Pop2T' (Proxy (z :: k -> k1 -> k2)) (Proxy (w :: k)) (Proxy (v :: k1)) s = PP (z w v :: k2) s
+ Pop2T' p q r s =
GL.TypeError (
- 'GL.Text "Pop2'T: requires 'Proxy z' and z must be a function requiring one parameter!!"
+ '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
@@ -482,6 +488,7 @@ instance ( PP p x ~ Proxy (z :: k -> k1)
eval _ opts _ =
pure $ mkNode opts (Val Proxy) "PApp" []
+-- | calculate the resulting type for '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)
@@ -516,6 +523,7 @@ instance ( PP p x ~ Proxy (z :: k -> k1 -> k2)
eval _ opts _ =
pure $ mkNode opts (Val Proxy) "PApp2" []
+-- | calculate the resulting type for '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)
@@ -561,6 +569,7 @@ instance PP p x ~ proxy (z :: k)
eval _ opts _ =
pure $ mkNode opts (Val Proxy) "Proxify" []
+-- | calculate the resulting type for 'Proxify'
type family ProxifyT p where
ProxifyT (_proxy z) = Proxy z
ProxifyT p = GL.TypeError (
diff --git a/src/Predicate/Data/ReadShow.hs b/src/Predicate/Data/ReadShow.hs
index 464e25b..785875e 100644
--- a/src/Predicate/Data/ReadShow.hs
+++ b/src/Predicate/Data/ReadShow.hs
@@ -47,7 +47,7 @@ import Data.Typeable (Typeable)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import Data.Time
-- | similar to 'show'
diff --git a/src/Predicate/Data/Regex.hs b/src/Predicate/Data/Regex.hs
index 1684752..a8af5ee 100644
--- a/src/Predicate/Data/Regex.hs
+++ b/src/Predicate/Data/Regex.hs
@@ -49,7 +49,7 @@ import Data.Bool (bool)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import Safe (readNote)
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import Data.Time
-- | runs a regular expression with given regex options and returns a boolean: see 'RH.=~'
diff --git a/src/Predicate/Data/String.hs b/src/Predicate/Data/String.hs
index 76010e0..1ea6bdf 100644
--- a/src/Predicate/Data/String.hs
+++ b/src/Predicate/Data/String.hs
@@ -60,7 +60,7 @@ import qualified Data.List.Lens
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text as T
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Sequence as Seq
data TrimImpl (th :: These () ()) deriving Show
@@ -70,7 +70,7 @@ instance ( GetThese th
) => P (TrimImpl th) x where
type PP (TrimImpl th) x = x
eval _ opts x =
- let (vv,fn) = case getThese @_ @_ @th of
+ let (vv,fn) = case getThese @th of
These () () -> ("Both", dropWhile isSpace . dropWhileEnd isSpace)
This () -> ("L", dropWhile isSpace)
That () -> ("R", dropWhileEnd isSpace)
diff --git a/src/Predicate/Data/These.hs b/src/Predicate/Data/These.hs
index 0ec764e..55caaa4 100644
--- a/src/Predicate/Data/These.hs
+++ b/src/Predicate/Data/These.hs
@@ -74,7 +74,7 @@ import GHC.TypeLits (ErrorMessage((:$$:),(:<>:)))
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- | similar to 'Data.These.partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract
@@ -288,7 +288,7 @@ instance ( x ~ These a b
type PP (IsTh th) x = Bool
eval _ opts x =
let msg0 = "Is"
- th = getThese @_ @_ @th
+ th = getThese @th
fn = case th of
This () -> TheseC.isThis
That () -> TheseC.isThat
@@ -867,6 +867,7 @@ instance ( Show a
Left e -> e
Right c -> mkNodeCopy opts rr (show3' opts msg0 c "" (These a b)) hhs
+-- | calculate the return type for 'TheseIn'
type family TheseInT r y elr where
TheseInT r y (These a b) = PP r (y,(a,b))
TheseInT _ _ o = GL.TypeError (
diff --git a/src/Predicate/Data/Tuple.hs b/src/Predicate/Data/Tuple.hs
index 233e585..68c68dd 100644
--- a/src/Predicate/Data/Tuple.hs
+++ b/src/Predicate/Data/Tuple.hs
@@ -65,7 +65,7 @@ import Data.Kind (Type)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> import Predicate.Prelude
+-- >>> import Predicate
-- >>> import qualified Data.Semigroup as SG
-- >>> :m + Data.These
-- >>> :m + Data.Ratio
diff --git a/src/Predicate/Elr.hs b/src/Predicate/Elr.hs
index f77821b..e40fd0b 100644
--- a/src/Predicate/Elr.hs
+++ b/src/Predicate/Elr.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -15,7 +17,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoStarIsType #-}
-{-# LANGUAGE EmptyDataDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -23,7 +25,7 @@
{-# LANGUAGE DeriveLift #-}
-- | Elr definition
module Predicate.Elr (
- -- definition
+ -- ** definition
Elr(..)
-- ** prisms
@@ -43,7 +45,6 @@ module Predicate.Elr (
, isEBoth
-- ** type families
- , ENoneT
, ELeftT
, ERightT
, EBothT
@@ -52,6 +53,7 @@ module Predicate.Elr (
, getBifoldInfo
, showElr
, GetElr(..)
+ , getElr
, partitionElr
, fromElr
, mergeElrWith
@@ -63,23 +65,36 @@ import GHC.TypeLits (ErrorMessage((:$$:),(:<>:)))
import Control.Lens
import Data.Bitraversable (Bitraversable(..))
import Data.Bifoldable (Bifoldable(bifoldMap))
-import GHC.Generics (Generic)
-import Control.DeepSeq (NFData)
+import GHC.Generics (Generic,Generic1)
+import Control.DeepSeq (NFData(..), NFData1(..), NFData2(..), rnf1)
import Control.Monad (ap)
-import qualified Language.Haskell.TH.Lift as TH
import Data.These (These(..))
+import Data.Data (Data)
+import qualified Language.Haskell.TH.Syntax as TH
-- $setup
--- >>> import Predicate.Prelude
--- >>> import qualified Data.Semigroup as SG
+-- >>> import Predicate
--- | similar to 'Data.These' with an additional empty constructor to support a Monoid instance
+-- | combination of values for two types @a@ and @b@
data Elr a b =
- ENone -- ^ empty constructor
- | ELeft !a -- ^ similar to 'Data.These.This'
- | ERight !b -- ^ similar to 'Data.These.That'
- | EBoth !a !b -- ^ similar to 'Data.These.These'
- deriving stock (Show,Eq,Ord,Foldable,Functor,Traversable,Generic,TH.Lift)
- deriving anyclass NFData
+ ENone -- ^ no value
+ | ELeft a -- ^ left value
+ | ERight b -- ^ right value
+ | EBoth a b -- ^ both left and a right value
+ deriving stock (Show,Eq,Ord,Foldable,Functor,Traversable,Generic,Generic1,Data)
+
+instance (NFData a, NFData b) => NFData (Elr a b) where
+ rnf = rnf1
+
+instance NFData a => NFData1 (Elr a) where
+ liftRnf = liftRnf2 rnf
+
+instance NFData2 Elr where
+ liftRnf2 _l _r ENone = ()
+ liftRnf2 l _r (ELeft a) = l a
+ liftRnf2 _l r (ERight b) = r b
+ liftRnf2 l r (EBoth a b) = l a `seq` r b
+
+deriving instance (TH.Lift a, TH.Lift b) => TH.Lift (Elr a b)
makePrisms ''Elr
@@ -148,16 +163,20 @@ showElr = \case
EBoth {} -> "EBoth"
-- | get 'Elr' from typelevel [type application order is a b then th if explicit kind for th else is first parameter!
-class GetElr (th :: Elr k k1) where
- getElr :: (String, Elr w v -> Bool)
+class GetElr (elr :: Elr k k1) where
+ getElr' :: Elr () ()
instance GetElr 'ENone where
- getElr = ("ENone", isENone)
+ getElr' = ENone
instance GetElr ('ELeft x) where
- getElr = ("ELeft", isELeft)
+ getElr' = ELeft ()
instance GetElr ('ERight y) where
- getElr = ("ERight", isERight)
+ getElr' = ERight ()
instance GetElr ('EBoth x y) where
- getElr = ("EBoth", isEBoth)
+ getElr' = EBoth () ()
+
+-- | get 'Elr' from the typelevel
+getElr :: forall th . GetElr th => Elr () ()
+getElr = getElr' @_ @_ @th
isENone, isELeft, isERight, isEBoth :: Elr a b -> Bool
-- | predicate on ENone
@@ -176,15 +195,7 @@ isERight _ = False
isEBoth EBoth {} = True
isEBoth _ = False
--- | extract the relevant type for 'ENone'
-type family ENoneT lr where
- ENoneT (Elr _ _) = ()
- ENoneT o = GL.TypeError (
- 'GL.Text "ENoneT: expected 'Elr a b' "
- ':$$: 'GL.Text "o = "
- ':<>: 'GL.ShowType o)
-
--- | extract the relevant type for 'ELeft'
+-- | extract the type from 'ELeft'
type family ELeftT lr where
ELeftT (Elr a _) = a
ELeftT o = GL.TypeError (
@@ -192,7 +203,7 @@ type family ELeftT lr where
':$$: 'GL.Text "o = "
':<>: 'GL.ShowType o)
--- | extract the relevant type for 'ERight'
+-- | extract the type from 'ERight'
type family ERightT lr where
ERightT (Elr _ b) = b
ERightT o = GL.TypeError (
@@ -200,7 +211,7 @@ type family ERightT lr where
':$$: 'GL.Text "o = "
':<>: 'GL.ShowType o)
--- | extract the relevant types for 'EBoth'
+-- | extract the types as a tuple from 'EBoth'
type family EBothT lr where
EBothT (Elr a b) = (a,b)
EBothT o = GL.TypeError (
@@ -248,7 +259,7 @@ _elr2These = iso fw bw
Just (That b) -> ERight b
Just (These a b) -> EBoth a b
--- | iso from 'Elr' to a pair of 'Maybe's
+-- | iso from 'Elr' to a 'Maybe' pair
--
-- >>> ENone ^. _elr2Maybe
-- (Nothing,Nothing)
@@ -273,7 +284,6 @@ _elr2Maybe = iso fw bw
(Nothing, Just b) -> ERight b
(Just a, Just b) -> EBoth a b
--- | 'GetLen' instances for 'Elr'
instance GetLen 'ENone where
getLen = 0
instance GetLen ('ELeft a) where
@@ -283,7 +293,6 @@ instance GetLen ('ERight b) where
instance GetLen ('EBoth a b) where
getLen = 1
--- | 'AssocC' instances for 'Elr'
instance AssocC Elr where
assoc ENone = ENone
assoc (ELeft ENone) = ENone
@@ -325,6 +334,16 @@ getBifoldInfo bi =
EBoth () () -> "(B)"
-- | similar to 'elr' without a separate EBoth combinator
+--
+-- >>> mergeElrWith [] (:[]) (pure . read) (++) (ELeft 123)
+-- [123]
+--
+-- >>> mergeElrWith [] (:[]) (pure . read) (++) (EBoth 123 "11")
+-- [123,11]
+--
+-- >>> mergeElrWith [999] (:[]) (pure . read) (++) ENone
+-- [999]
+--
mergeElrWith :: c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> Elr a b -> c
mergeElrWith c fa fb fcc =
\case
@@ -334,6 +353,16 @@ mergeElrWith c fa fb fcc =
EBoth a b -> fcc (fa a) (fb b)
-- | destruct 'Elr'
+--
+-- >>> elr Nothing (Just . This) (Just . That) ((Just .) . These) (ELeft 10)
+-- Just (This 10)
+--
+-- >>> elr Nothing (Just . This) (Just . That) ((Just .) . These) (EBoth 'x' 99)
+-- Just (These 'x' 99)
+--
+-- >>> elr Nothing (Just . This) (Just . That) ((Just .) . These) ENone
+-- Nothing
+--
elr :: c -> (a -> c) -> (b -> c) -> (a -> b -> c) -> Elr a b -> c
elr c fa fb fab =
\case
diff --git a/src/Predicate/Examples/Common.hs b/src/Predicate/Examples/Common.hs
index c5dc8b8..9788fee 100644
--- a/src/Predicate/Examples/Common.hs
+++ b/src/Predicate/Examples/Common.hs
@@ -30,7 +30,7 @@ module Predicate.Examples.Common (
, Hmsfmt
, HmsRE
- -- ** credit cards
+ -- ** luhn check
, Luhnip
, Luhnop
, Luhnfmt
@@ -67,7 +67,7 @@ module Predicate.Examples.Common (
, Isbn13op
, Isbn13fmt
) where
-import Predicate.Prelude
+import Predicate
import GHC.TypeLits (Nat)
import Data.Time (Day, UTCTime, ZonedTime)
@@ -159,44 +159,52 @@ type Ip6op = Msg "count is bad:" (Len == 8)
-- | @fmt@ type for formatting an ip6 address
type Ip6fmt = PrintL 8 "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x" Id
-
+-- | isbn 10 converter
type Isbn10ip = Resplit "-"
>> Concat
>> 'Just Unsnoc
>> Map (ReadP Int (Singleton Id)) *** If (Singleton Id ==~ "X") 10 (ReadP Int (Singleton Id))
+-- | isbn 10 validator
type Isbn10op = GuardSimple ((Fst >> All (0 <..> 9)) && Between 0 10 Snd)
>> ZipWith (Fst * Snd) (1...10 >> Reverse) (Fst +: Snd)
>> Sum
>> GuardBool "mod 0 oops" (Id `Mod` 11 == 0)
+-- | isbn 10 formatter
type Isbn10fmt = ConcatMap (ShowP Id) Id *** If (Id == 10) "X" (ShowP Id)
>> Fst <> "-" <> Snd -- no standard format: just hyphen before checkdigit
+-- | isbn 13 converter
type Isbn13ip = Resplit "-"
>> Concat
>> Map (ReadP Int (Singleton Id))
+-- | isbn 13 validator
type Isbn13op = ZipWith (Fst * Snd) (Cycle 13 [1,3] >> Reverse) Id
>> Sum
>> '(Id,Id `Mod` 10)
>> GuardBool (PrintT "sum=%d mod 10=%d" Id) (Snd == 0)
+-- | isbn 13 formatter
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"
+-- | selected date formats used in the examples
type DateFmts = '["%Y-%m-%d", "%m/%d/%y", "%B %d %Y"]
-- | @ip@ type for reading one of many date formats from 'DateFmts'
type DateNip = ParseTimes Day DateFmts Id
+-- | selected datetime formats used in the examples
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'
type DateTimeNip = ParseTimes UTCTime DateTimeFmts Id
-- ParseTimeP is easier and accurate
+-- | simple date regular expression
type DdmmyyyyRE = "^(\\d{2})-(\\d{2})-(\\d{4})$"
{-
type Ddmmyyyyop =
@@ -206,10 +214,13 @@ type Ddmmyyyyop =
>> '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]
+-- | date validator for a three value list containing day month and year using GuardsDetail
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
+-- | date validator for a three value list containing day month and year using Bools
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]
+-- | luhn check digit validator
type Luhnop' (n :: Nat) =
Guard (PrintT "incorrect number of digits found %d but expected %d in [%s]" '(Len, n, ShowP Id)) (Len == n)
>> Do '[
@@ -219,6 +230,7 @@ type Luhnop' (n :: Nat) =
]
>> Guard (PrintT "expected %d mod 10 = 0 but found %d" '(Id, Id `Mod` 10)) (Mod Id 10 == 0)
+-- | luhn check digit validator (alternate version)
type Luhn' (n :: Nat) =
Msg "Luhn'" (Do
'[Guard (PrintT "incorrect length: found %d but expected %d in [%s]" '(Len, n, Id)) (Len == n)
diff --git a/src/Predicate/Examples/Refined2.hs b/src/Predicate/Examples/Refined2.hs
index b5cf93a..84402ca 100644
--- a/src/Predicate/Examples/Refined2.hs
+++ b/src/Predicate/Examples/Refined2.hs
@@ -10,7 +10,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoStarIsType #-}
--- | Contains prepackaged 4-tuples to use with 'Refined2'
+-- | Contains prepackaged 4-tuples to use with 'Predicate.Refined2.Refined2'
module Predicate.Examples.Refined2 (
-- ** datetime
DateTime1
@@ -25,10 +25,8 @@ module Predicate.Examples.Refined2 (
, hms
, Hms
, HmsR
- , Hms'
- , HmsR'
- -- ** credit cards
+ -- ** luhn check
, Luhn
, luhn11
@@ -42,10 +40,6 @@ module Predicate.Examples.Refined2 (
, Ip4
, Ip4R
- , ip4'
- , Ip4'
- , Ip4R'
-
-- ** ipv6
, ip6
, Ip6
@@ -63,7 +57,6 @@ module Predicate.Examples.Refined2 (
-- ** base n
, BaseN
- , BaseN'
, BaseIJ
, BaseIJ'
, BaseIJip
@@ -84,9 +77,8 @@ import Data.Proxy (Proxy(..))
-- >>> :set -XTypeApplications
-- >>> :m + Data.Time
-- >>> :m + Control.Lens
--- >>> :m + Text.Show.Functions
--- | credit card with luhn algorithm
+-- | credit card check using luhn algorithm
--
-- >>> newRefined2 @OZ @Luhnip @(Luhnop 11) "1234-5678-901"
-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit
@@ -100,8 +92,22 @@ import Data.Proxy (Proxy(..))
-- >>> pz @(Luhnip >> Luhnop 10) "79927398713"
-- Fail "expected 10 digits but found 11"
--
+-- >>> newRefined2P (luhn11 @OZ) "1234-5678-903"
+-- Right (Refined2 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903")
+--
+-- >>> newRefined2 @OZ @Luhnip @(Luhnop 4) "1230"
+-- Right (Refined2 [1,2,3,0] "1230")
+--
+-- >>> newRefined2 @OL @Luhnip @(Luhnop 4) "1234"
+-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit
+--
+luhn11 :: Proxy (Luhn opts 11)
+luhn11 = Proxy
+
+-- | luhn checkdigit validator for @n@ digits
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"
@@ -110,21 +116,31 @@ type Luhn (opts :: Opt) (n :: Nat) = '(opts, Luhnip, Luhnop n, String)
-- >>> newRefined2 @OL @(Dtip LocalTime) @'True "2018-09-99 12:12:12"
-- Left Step 1. Failed Initial Conversion(ip) | ParseTimeP LocalTime (%F %T) failed to parse
--
+-- >>> newRefined2P (datetime1 @OZ @LocalTime) "2018-09-14 02:57:04"
+-- Right (Refined2 2018-09-14 02:57:04 "2018-09-14 02:57:04")
+--
datetime1 :: Proxy (DateTime1 opts t)
datetime1 = mkProxy2
+-- | datetime validator with default predicate of true
type DateTime1 (opts :: Opt) (t :: Type) = '(opts, Dtip t, 'True, String)
+-- | proxy for 'DateTimeN'
datetimen :: OptC opts => Proxy (DateTimeN opts)
datetimen = mkProxy2'
--- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07"
+-- valid dates for for DateFmts eg "2001-01-01" "Jan 24 2009" and "03/29/07"
+-- | date validator which tries to match against multiple date formats
type DateN (opts :: Opt) = '(opts,ParseTimes Day DateFmts Id, 'True, String)
+-- | proxy for 'DateN'
daten :: OptC opts => Proxy (DateN opts)
daten = mkProxy2'
+-- | 'Predicate.Refined2.Refined2' type signature for 'DateTimeN'
type DateTimeNR (opts :: Opt) = MakeR2 (DateTimeN opts)
+
+-- | datetime validator which tries to match against multiple datetime formats
type DateTimeN (opts :: Opt) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, String)
-- | read in an ssn
@@ -138,11 +154,16 @@ type DateTimeN (opts :: Opt) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True
-- >>> newRefined2 @OL @Ssnip @Ssnop "667-00-2211"
-- Left Step 2. Failed Boolean Check(op) | Bool(1) [number for group 1 invalid: found 0] (1 <= 0)
--
-
+-- >>> newRefined2P (ssn @OL) "667-00-2211"
+-- Left Step 2. Failed Boolean Check(op) | Bool(1) [number for group 1 invalid: found 0] (1 <= 0)
+--
ssn :: OptC opts => Proxy (Ssn opts)
ssn = mkProxy2'
+-- | 'Predicate.Refined2.Refined2' signature for 'Ssn'
type SsnR (opts :: Opt) = MakeR2 (Ssn opts)
+
+-- | ssn validator
type Ssn (opts :: Opt) = '(opts, Ssnip, Ssnop, String)
@@ -157,19 +178,19 @@ type Ssn (opts :: Opt) = '(opts, Ssnip, Ssnop, String)
-- >>> newRefined2 @OL @Hmsip @Hmsop' "26:13:59"
-- Left Step 2. Failed Boolean Check(op) | Bool(0) [hours] (26 <= 23)
--
+-- >>> newRefined2P (hms @OL) "23:13:59"
+-- Right (Refined2 [23,13,59] "23:13:59")
+--
hms :: OptC opts => Proxy (Hms opts)
hms = mkProxy2'
+-- | 'Predicate.Refined2.Refined2' type signature for 'Hms'
type HmsR (opts :: Opt) = MakeR2 (Hms opts)
-type Hms (opts :: Opt) = '(opts, Hmsip, Hmsop, String)
-
---hms' :: Proxy (Hms' OZ)
---hms' = mkProxy2'
-type HmsR' (opts :: Opt) = MakeR2 (Hms' opts)
-type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', String)
+-- | time validator
+type Hms (opts :: Opt) = '(opts, Hmsip, Hmsop, String)
--- | read in an ipv4 address and validate it
+-- | read in an ipv4 address and validate it using guards
--
-- >>> newRefined2 @OZ @Ip4ip @Ip4op' "001.223.14.1"
-- Right (Refined2 [1,223,14,1] "001.223.14.1")
@@ -186,25 +207,25 @@ type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', String)
-- >>> newRefined2P (ip4 @OL) "001.257.14.1"
-- Left Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257
--
-type Ip4R (opts :: Opt) = MakeR2 (Ip4 opts)
-type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, String) -- guards
-
ip4 :: Proxy (Ip4 opts)
ip4 = Proxy
-type Ip4R' (opts :: Opt) = MakeR2 (Ip4' opts)
-type Ip4' (opts :: Opt) = '(opts, Ip4ip, Ip4op', String) -- boolean predicates
+-- | validator for ipv4 addresses
+type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, String)
-ip4' :: Proxy (Ip4' opts)
-ip4' = Proxy
+-- | 'Predicate.Refined2.Refined2' type signature for 'Ip4'
+type Ip4R (opts :: Opt) = MakeR2 (Ip4 opts)
+-- | 'Predicate.Refined2.Refined2' type signature for 'Ip6'
type Ip6R (opts :: Opt) = MakeR2 (Ip6 opts)
-type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, String) -- guards
+-- | validator for ipv6 using guards
+type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, String)
+-- | proxy for 'Ip6'
ip6 :: Proxy (Ip6 opts)
ip6 = Proxy
--- | validate isbn10
+-- | validate isbn10 using guards
--
-- >>> newRefined2P (isbn10 @OZ) "0-306-40611-X"
-- Right (Refined2 ([0,3,0,6,4,0,6,1,1],10) "0-306-40611-X")
@@ -212,12 +233,15 @@ ip6 = Proxy
-- >>> newRefined2P (isbn10 @OZ) "0-306-40611-9"
-- Left Step 2. Failed Boolean Check(op) | mod 0 oops
--
-type Isbn10R (opts :: Opt) = MakeR2 (Isbn10 opts)
-type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, String) -- guards
-
isbn10 :: Proxy (Isbn10 opts)
isbn10 = Proxy
+-- | validator for isbn10
+type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, String)
+
+-- | 'Predicate.Refined2.Refined2' type signature for 'Isbn10'
+type Isbn10R (opts :: Opt) = MakeR2 (Isbn10 opts)
+
-- | validate isbn13
--
-- >>> newRefined2P (isbn13 @OZ) "978-0-306-40615-7"
@@ -226,44 +250,16 @@ isbn10 = Proxy
-- >>> newRefined2P (isbn13 @OZ) "978-0-306-40615-8"
-- Left Step 2. Failed Boolean Check(op) | sum=101 mod 10=1
--
-type Isbn13R (opts :: Opt) = MakeR2 (Isbn13 opts)
-type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, String) -- guards
-
isbn13 :: Proxy (Isbn13 opts)
isbn13 = Proxy
+-- | validate isbn13 using guards
+type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, String)
+-- | 'Predicate.Refined2.Refined2' type signature for 'Isbn10'
+type Isbn13R (opts :: Opt) = MakeR2 (Isbn13 opts)
-
-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) @'True "00fe"
--- Right (Refined2 254 "00fe")
---
--- >>> newRefined2 @OZ @(ReadBase Int 16) @(Between 100 400 Id) "00fe"
--- Right (Refined2 254 "00fe")
---
--- >>> 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 < 400) "f0fe" -- todo: why different parens vs braces
--- 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, String)
-
-
--- | Luhn check
---
--- >>> newRefined2 @OZ @Luhnip @(Luhnop 4) "1230"
--- Right (Refined2 [1,2,3,0] "1230")
---
--- >>> newRefined2 @OL @Luhnip @(Luhnop 4) "1234"
--- Left Step 2. Failed Boolean Check(op) | invalid checkdigit
---
--- | uses builtin 'IsLuhn'
+-- | 4-tuple for reading for base @n@
+type BaseN (opts :: Opt) (n :: Nat) p = '(opts, ReadBase Int n, p, String)
-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string
--
@@ -278,58 +274,8 @@ type BaseN' (opts :: Opt) (n :: Nat) p = '(opts,ReadBase Int n, p, String)
--
type BaseIJip (i :: Nat) (j :: Nat) = ReadBase Int i >> ShowBase j
-type BaseIJ (i :: Nat) (j :: Nat) = BaseIJ' i j 'True
+-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string with a predicate \'p\'
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 (13 % 3) "13 % 3")
---
--- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "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 (13 % 3) "13 % 3")
---
--- >>> newRefined2 @OZ @(ReadP Rational Id) @(11 -% 2 <..> 3 -% 1) "-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
---
--- >>> 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
---
--- >>> newRefined2 @OZ @(ReadP UTCTime Id) @'True "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 (String "jsonstring") "String \"jsonstring\"")
---
--- >>> newRefined2 @OZ @(ReadP Value Id) @'True "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
--- \ No newline at end of file
+-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string
+type BaseIJ (i :: Nat) (j :: Nat) = BaseIJ' i j 'True
diff --git a/src/Predicate/Examples/Refined3.hs b/src/Predicate/Examples/Refined3.hs
index 0775f8f..0845a74 100644
--- a/src/Predicate/Examples/Refined3.hs
+++ b/src/Predicate/Examples/Refined3.hs
@@ -10,7 +10,7 @@
{-# 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 'Predicate.Refined3.Refined3'
module Predicate.Examples.Refined3 (
-- ** datetime
datetime1
@@ -28,15 +28,14 @@ module Predicate.Examples.Refined3 (
, Hms'
, HmsR'
- -- ** credit cards
+ -- ** luhn check
, luhn
- , luhn'
, Luhn
, luhn11
, Luhn11
, LuhnR
, LuhnT
- -- *** sim card
+ -- ** sim card check
, SimT
-- ** ssn
@@ -49,9 +48,7 @@ module Predicate.Examples.Refined3 (
, Ip4
, Ip4R
- , ip4'
, Ip4'
- , Ip4R'
-- ** ipv6
, ip6
@@ -72,11 +69,7 @@ module Predicate.Examples.Refined3 (
, basen
, base2
, base16
- , basen'
- , base2'
- , base16'
, BaseN
- , BaseN'
, BaseIJ
, BaseIJ'
@@ -105,7 +98,7 @@ import Predicate.Examples.Common
import Predicate.Refined3
import Predicate
import Data.Proxy (Proxy(..))
-import GHC.TypeLits (KnownNat, Nat)
+import GHC.TypeLits (Nat)
import Data.Kind (Type)
import Data.Time (Day, UTCTime)
@@ -117,7 +110,7 @@ import Data.Time (Day, UTCTime)
-- >>> :set -XTypeApplications
-- >>> :m + Data.Time
--- | credit card with luhn algorithm
+-- | credit card validator using the luhn algorithm
--
-- >>> newRefined3P (luhn11 @OZ) "1234-5678-901"
-- Left Step 2. Failed Boolean Check(op) | invalid checkdigit
@@ -131,25 +124,19 @@ import Data.Time (Day, UTCTime)
-- >>> pz @(Luhnip >> Luhnop 10) "79927398713"
-- Fail "expected 10 digits but found 11"
--
+luhn11 :: OptC opts => Proxy (Luhn opts '[4,4,3])
+luhn11 = mkProxy3'
+-- | credit card validator using the luhn algorithm
type Luhn (opts :: Opt) (ns :: [Nat]) = '(opts, Luhnip, Luhnop (SumT ns), Luhnfmt ns, String)
+-- | credit card validator using the luhn algorithm with format nnnn-nnnn-nnn
type Luhn11 (opts :: Opt) = Luhn opts '[4,4,3]
+-- | proxy for 'Luhn'
luhn :: Proxy (Luhn opts ns)
luhn = mkProxy3
--- works but have to add all the constraints
-luhn' :: ( OptC opts
- , PP ns String ~ [Integer]
- , KnownNat (SumT ns)
- , P ns String
- ) => Proxy (Luhn opts ns)
-luhn' = 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"
@@ -162,22 +149,24 @@ datetime1 :: Proxy (DateTime1 opts t)
datetime1 = mkProxy3
-- now that time is actually validated we dont need Dtop*
+-- | datetime validator
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
--- ZonedTime LocalTime and TimeOfDay don't do validation and allow invalid stuff through : eg 99:98:97 is valid
+-- ZonedTime LocalTime and TimeOfDay dont do validation and allow invalid stuff through : eg 99:98:97 is valid
-- UTCTime will do the same but any overages get tacked on to the day and time as necessary: makes the time valid! 99:98:97 becomes 04:39:37
-- 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"
+-- | date validator which tries to match against multiple date formats
type DateN (opts :: Opt) = '(opts, ParseTimes Day DateFmts Id, 'True, FormatTimeP "%Y-%m-%d", String)
+-- | 'Predicate.Refined3.Refined3' type signature for 'DateTimeN'
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 :: OptC opts => Proxy (Ssn opts)
-ssn = mkProxy3'
+-- | datetime validator which matches against multiple datetime formats
+type DateTimeN (opts :: Opt) = '(opts, ParseTimes UTCTime DateTimeFmts Id, 'True, FormatTimeP "%Y-%m-%d %H:%M:%S" , String)
-- | read in an ssn
--
@@ -190,7 +179,13 @@ ssn = mkProxy3'
-- >>> newRefined3P (ssn @OL) "667-00-2211"
-- Left Step 2. Failed Boolean Check(op) | Bool(1) [number for group 1 invalid: found 0] (1 <= 0)
--
+ssn :: OptC opts => Proxy (Ssn opts)
+ssn = mkProxy3'
+
+-- | ssn validator
type Ssn (opts :: Opt) = '(opts, Ssnip, Ssnop, Ssnfmt, String)
+
+-- | 'Predicate.Refined3.Refined3' type signature for 'Ssn'
type SsnR (opts :: Opt) = MakeR3 (Ssn opts)
-- | read in a time and validate it
--
@@ -206,14 +201,19 @@ type SsnR (opts :: Opt) = MakeR3 (Ssn opts)
hms :: OptC opts => Proxy (Hms opts)
hms = mkProxy3'
+-- | 'Predicate.Refined3.Refined3' type signature for 'Hms'
type HmsR (opts :: Opt) = MakeR3 (Hms opts)
+-- | validator for time
type Hms (opts :: Opt) = '(opts, Hmsip, Hmsop, Hmsfmt, String)
+-- | 'Predicate.Refined3.Refined3' type signature for 'HmsR'
type HmsR' (opts :: Opt) = MakeR3 (Hms' opts)
+
+-- | alternate validator for time
type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', Hmsfmt, String)
--- | read in an ipv4 address and validate it
+-- | read in an ipv4 address and validate it using guards
--
-- >>> newRefined3P (ip4 @OZ) "001.223.14.1"
-- Right (Refined3 [1,223,14,1] "001.223.014.001")
@@ -227,25 +227,28 @@ type Hms' (opts :: Opt) = '(opts, Hmsip, Hmsop', Hmsfmt, String)
-- >>> newRefined3P (ip4 @OL) "001.257.14.1"
-- Left Step 2. Failed Boolean Check(op) | octet 1 out of range 0-255 found 257
--
-type Ip4R (opts :: Opt) = MakeR3 (Ip4 opts)
-type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, Ip4fmt, String) -- guards
-
ip4 :: OptC opts => Proxy (Ip4 opts)
ip4 = mkProxy3'
-type Ip4R' (opts :: Opt) = MakeR3 (Ip4' opts)
-type Ip4' (opts :: Opt) = '(opts, Ip4ip, Ip4op', Ip4fmt, String) -- boolean predicates
+-- | ipv4 validator using guards
+type Ip4 (opts :: Opt) = '(opts, Ip4ip, Ip4op, Ip4fmt, String)
+
+-- | 'Predicate.Refined3.Refined3' type signature for 'Ip4'
+type Ip4R (opts :: Opt) = MakeR3 (Ip4 opts)
-ip4' :: OptC opts => Proxy (Ip4' opts)
-ip4' = mkProxy3'
+-- | alternate ipv4 validator using boolean predicates
+type Ip4' (opts :: Opt) = '(opts, Ip4ip, Ip4op', Ip4fmt, String)
+-- | 'Predicate.Refined3.Refined3' signature for 'Ip6'
type Ip6R (opts :: Opt) = MakeR3 (Ip6 opts)
-type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, Ip6fmt, String) -- guards
+-- | Ipv6 validator using guards
+type Ip6 (opts :: Opt) = '(opts, Ip6ip, Ip6op, Ip6fmt, String)
+-- | proxy for 'Ip6'
ip6 :: Proxy (Ip6 opts)
ip6 = Proxy
--- | validate isbn10
+-- | validate isbn10 using guards
--
-- >>> newRefined3P (isbn10 @OZ) "0-306-40611-X"
-- Right (Refined3 ([0,3,0,6,4,0,6,1,1],10) "030640611-X")
@@ -253,13 +256,16 @@ ip6 = Proxy
-- >>> newRefined3P (isbn10 @OZ) "0-306-40611-9"
-- Left Step 2. Failed Boolean Check(op) | mod 0 oops
--
-type Isbn10R (opts :: Opt) = MakeR3 (Isbn10 opts)
-type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, Isbn10fmt, String) -- guards
-
isbn10 :: Proxy (Isbn10 opts)
isbn10 = Proxy
--- | validate isbn13
+-- | validate isbn10 using guards
+type Isbn10 (opts :: Opt) = '(opts, Isbn10ip, Isbn10op, Isbn10fmt, String)
+
+-- | 'Predicate.Refined3.Refined3' type signature for 'Isbn10'
+type Isbn10R (opts :: Opt) = MakeR3 (Isbn10 opts)
+
+-- | validate isbn13 using guards
--
-- >>> newRefined3P (isbn13 @OZ) "978-0-306-40615-7"
-- Right (Refined3 [9,7,8,0,3,0,6,4,0,6,1,5,7] "978030640615-7")
@@ -267,57 +273,56 @@ isbn10 = Proxy
-- >>> newRefined3P (isbn13 @OZ) "978-0-306-40615-8"
-- Left Step 2. Failed Boolean Check(op) | sum=101 mod 10=1
--
-type Isbn13R (opts :: Opt) = MakeR3 (Isbn13 opts)
-type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, Isbn13fmt, String) -- guards
-
isbn13 :: Proxy (Isbn13 opts)
isbn13 = Proxy
--- | convert a string from a given base \'i\' and store it internally as an base 10 integer
+-- | validate isbn13 using guards
+type Isbn13 (opts :: Opt) = '(opts, Isbn13ip, Isbn13op, Isbn13fmt, String)
+
+-- | 'Predicate.Refined3.Refined3' signature for 'Isbn13'
+type Isbn13R (opts :: Opt) = MakeR3 (Isbn13 opts)
+
+-- | base 16 validator with a predicate @p@
--
--- >>> newRefined3P (base16 @OZ) "00fe"
+-- >>> newRefined3P (base16 @OZ @'True) "00fe"
-- Right (Refined3 254 "fe")
--
--- >>> newRefined3P (basen' @OZ @16 @(100 <..> 400)) "00fe"
+base16 :: Proxy (BaseN opts 16 p)
+base16 = basen
+
+-- | read show for base @n@ with a predicate
+--
+-- >>> newRefined3P (basen @OZ @16 @(100 <..> 400)) "00fe"
-- Right (Refined3 254 "fe")
--
--- >>> newRefined3P (basen' @OZ @16 @(GuardSimple (Id < 400) >> 'True)) "f0fe"
+-- >>> newRefined3P (basen @OZ @16 @(GuardSimple (Id < 400) >> 'True)) "f0fe"
-- Left Step 2. Failed Boolean Check(op) | (61694 < 400)
--
--- >>> newRefined3P (basen' @OZ @16 @(GuardBool (PrintF "oops bad hex=%d" Id) (Id < 400))) "f0fe"
+-- >>> 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
--
--- >>> newRefined3P (basen' @OL @16 @(Id < 400)) "f0fe"
+-- >>> 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
+basen :: Proxy (BaseN opts n p)
+basen = mkProxy3
-base16' :: Proxy (BaseN' opts 16 p)
-base16' = basen'
+-- | read show for base @n@
+type BaseN (opts :: Opt) (n :: Nat) p = '(opts, ReadBase Int n, p, ShowBase n, String)
-base2 :: Proxy (BaseN opts 2)
+-- | base 2 validator with a predicate @p@
+base2 :: Proxy (BaseN opts 2 p)
base2 = basen
-base2' :: Proxy (BaseN' opts 2 p)
-base2' = basen'
-
-basen :: Proxy (BaseN opts n)
-basen = mkProxy3
-
-basen' :: Proxy (BaseN' opts n p)
-basen' = mkProxy3
-
+-- | proxy for the 'DateN' validator
daten :: OptC opts => Proxy (DateN opts)
daten = mkProxy3'
+-- | proxy for the 'DateTimeN' validator
datetimen :: OptC opts => Proxy (DateTimeN opts)
datetimen = mkProxy3'
--- | ensures that two numbers are in a given range (emulates 'Refined.Refined')
+-- | ensures that two numbers are in a given range (emulates 'Predicate.Refined.Refined')
--
-- >>> newRefined3P (between @OZ @10 @16) 14
-- Right (Refined3 14 14)
@@ -341,8 +346,10 @@ datetimen = mkProxy3'
between :: Proxy (BetweenN opts m n)
between = mkProxy3
+-- | validate an int is between @m@ and @n@
type BetweenN (opts :: Opt) m n = '(opts, Id, Between m n Id, Id, Int)
+-- | luhn check a string of a given length @n@
type LuhnR (opts :: Opt) (n :: Nat) = MakeR3 (LuhnT opts n)
-- | Luhn check using builtin 'Predicate.Data.Extra.IsLuhn'
@@ -389,18 +396,29 @@ type SimT (opts :: Opt) =
-- | noop true
type Ok (opts :: Opt) (t :: Type) = '(opts, Id, 'True, Id, t)
+-- | 'Predicate.Refined3.Refined3' signature for 'Ok'
type OkR (opts :: Opt) (t :: Type) = MakeR3 (Ok opts t)
+-- | noop true proxy
ok :: Proxy (Ok opts t)
ok = mkProxy3
-- | noop false
type OkNot (t :: Type) = '(OAN, Id, 'False, Id, t)
+-- | 'Predicate.Refined3.Refined3' signature for 'OkNot'
type OkNotR (t :: Type) = MakeR3 (OkNot t)
+-- | noop false proxy
oknot :: Proxy (OkNot t)
oknot = mkProxy3
+-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string with a predicate \'p\'
+--
+-- >>> newRefined3P (Proxy @(BaseIJ' OL 16 2 (ReadBase Int 2 < 1000))) "ffe"
+-- Left Step 2. False Boolean Check(op) | {4094 < 1000}
+--
+type BaseIJ' (opts :: Opt) (i :: Nat) (j :: Nat) p = '(opts, ReadBase Int i >> ShowBase j, p, ReadBase Int j >> ShowBase i, String)
+
-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string
--
-- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fe"
@@ -409,13 +427,9 @@ oknot = mkProxy3
-- >>> newRefined3P (Proxy @(BaseIJ OZ 16 2)) "fge"
-- Left Step 1. Failed Initial Conversion(ip) | invalid base 16
--
--- >>> newRefined3P (Proxy @(BaseIJ' OL 16 2 (ReadBase Int 2 < 1000))) "ffe"
--- Left Step 2. False Boolean Check(op) | {4094 < 1000}
---
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'
+-- | take any valid Read/Show instance and turn it into a valid 'Predicate.Refined3.Refined3'
--
-- >>> :m + Data.Ratio
-- >>> newRefined3P (readshow @OZ @Rational) "13 % 3"
@@ -427,18 +441,6 @@ type BaseIJ' (opts :: Opt) (i :: Nat) (j :: Nat) p = '(opts, ReadBase Int i >> S
-- >>> newRefined3P (readshow' @OZ @Rational @(3 % 1 <..> 5 % 1)) "13 % 3"
-- Right (Refined3 (13 % 3) "13 % 3")
--
--- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (11 -% 2 <..> 3 -% 1))) "-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
---
--- >>> 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
---
-- >>> newRefined3P (readshow @OZ @UTCTime) "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")
--
@@ -449,15 +451,35 @@ type BaseIJ' (opts :: Opt) (i :: Nat) (j :: Nat) p = '(opts, ReadBase Int i >> S
-- >>> newRefined3P (readshow @OZ @Value) "Number 123.4"
-- Right (Refined3 (Number 123.4) "Number 123.4")
--
+readshow :: Proxy (ReadShow opts t)
+readshow = mkProxy3
+
+-- | take any valid Read/Show instance and turn it into a valid 'Predicate.Refined3.Refined3'
type ReadShow (opts :: Opt) (t :: Type) = '(opts, ReadP t Id, 'True, ShowP Id, String)
+
+-- | 'Predicate.Refined3.Refined3' signature for 'ReadShow'
type ReadShowR (opts :: Opt) (t :: Type) = MakeR3 (ReadShow opts t)
+-- | take any valid Read/Show instance and turn it into a valid 'Predicate.Refined3.Refined3' with a given predicate @p@
+--
+-- >>> :m + Data.Ratio
+-- >>> newRefined3P (Proxy @(ReadShow' OZ Rational (11 -% 2 <..> 3 -% 1))) "-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
+--
+-- >>> 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
+--
type ReadShow' (opts :: Opt) (t :: Type) p = '(opts, ReadP t Id, p, ShowP Id, String)
+-- | 'Predicate.Refined3.Refined3' signature for 'ReadShow''
type ReadShowR' (opts :: Opt) (t :: Type) p = MakeR3 (ReadShow' opts t p)
-readshow :: Proxy (ReadShow opts t)
-readshow = mkProxy3
-
+-- | simple read show proxy with a predicate
readshow' :: Proxy (ReadShow' opts t p)
readshow' = mkProxy3
@@ -467,17 +489,14 @@ readshow' = mkProxy3
-- Present [1,2,3,4] (Map [1,2,3,4] | ["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 (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
-- Fail "Guards:invalid length(5) expected 4"
--
---
-- >>> pl @(T5_4 (Ip4 OL)) [141,513,9,4]
-- Present "141.513.009.004" ((>>) "141.513.009.004" | {PrintI [141.513.009.004] | s=%03d.%03d.%03d.%03d})
-- Val "141.513.009.004"
diff --git a/src/Predicate/Misc.hs b/src/Predicate/Misc.hs
index 892bc4f..a87134b 100644
--- a/src/Predicate/Misc.hs
+++ b/src/Predicate/Misc.hs
@@ -17,7 +17,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE MultiParamTypeClasses #-}
--- | Utility methods for Predicate / methods for displaying the evaluation tree
+-- | helper methods
module Predicate.Misc (
-- ** useful type families
AndT
@@ -54,6 +54,7 @@ module Predicate.Misc (
, GetBool(..)
, GetLen(..)
, GetThese(..)
+ , getThese
, GetOrdering(..)
, OrderingP(..)
, GetOrd(..)
@@ -106,6 +107,10 @@ module Predicate.Misc (
, SColor(..)
, GetColor(..)
+ -- ** styles
+ , SStyle(..)
+ , GetStyle(..)
+
-- ** miscellaneous
, SwapC(..)
, showTK
@@ -137,7 +142,7 @@ 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 System.Console.Pretty (Color(..), Style(..))
import GHC.Exts (Constraint)
import qualified Text.Regex.PCRE.Heavy as RH
import qualified Text.Regex.PCRE.Light as RL
@@ -251,15 +256,19 @@ showThese = \case
That {} -> "That"
These {} -> "These"
--- | get 'These' from typelevel
+-- | get 'These' from the typelevel
class GetThese (th :: These a b) where
- getThese :: These () ()
+ getThese' :: These () ()
instance GetThese ('This x) where
- getThese = This ()
+ getThese' = This ()
instance GetThese ('That y) where
- getThese = That ()
+ getThese' = That ()
instance GetThese ('These x y) where
- getThese = These () ()
+ getThese' = These () ()
+
+-- | get 'These' from the typelevel
+getThese :: forall th . GetThese th => These () ()
+getThese = getThese' @_ @_ @th
-- | get ordering from the typelevel
class GetOrdering (cmp :: Ordering) where
@@ -296,6 +305,7 @@ type family RepeatT (n :: Nat) (p :: k) :: [k] where
RepeatT 1 p = p ': '[]
RepeatT n p = p ': RepeatT (n GN.- 1) p
+-- | type operator for appending a type level symbol
type s <%> t = GL.AppendSymbol s t
infixr 7 <%>
@@ -478,6 +488,7 @@ instance ToITupleListC 12 a where
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"
+-- | reverse an inductive tuple
class ReverseITupleC (x :: Type) (xs :: Type) (ys :: Type) where
type ReverseITupleT x xs ys
reverseITupleC :: x -> xs -> ys -> ReverseITupleT x xs ys
@@ -641,6 +652,7 @@ type family FnT ab :: Type where
':$$: 'GL.Text "ab = "
':<>: 'GL.ShowType ab)
+-- | combine two containers
type family JoinT x y where
JoinT (t a) (t b) = t (a, b)
JoinT ta tb = GL.TypeError (
@@ -650,6 +662,7 @@ type family JoinT x y where
':$$: 'GL.Text "t b = "
':<>: 'GL.ShowType tb)
+-- | replace the type inside a container using @b@
type family ApplyConstT (ta :: Type) (b :: Type) :: Type where
ApplyConstT (t _) b = t b
ApplyConstT ta b = GL.TypeError (
@@ -659,6 +672,7 @@ type family ApplyConstT (ta :: Type) (b :: Type) :: Type where
':$$: 'GL.Text "b = "
':<>: 'GL.ShowType b)
+-- | fail with a programmer error
errorInProgram :: HasCallStack => String -> x
errorInProgram s = error $ "programmer error:" <> s
@@ -737,8 +751,8 @@ class ExtractL3C (tp :: Type) where
type ExtractL3T tp
extractL3C :: tp -> ExtractL3T tp
instance ExtractL3C (a,b) where
- type ExtractL3T (a,b) = GL.TypeError ('GL.Text "L3 doesn't work for 2-tuples")
- extractL3C _ = errorInProgram "L3 doesn't work for 2-tuples"
+ type ExtractL3T (a,b) = GL.TypeError ('GL.Text "L3 invalid for 2-tuples")
+ extractL3C _ = errorInProgram "L3 invalid for 2-tuples"
instance ExtractL3C (a,b,c) where
type ExtractL3T (a,b,c) = c
extractL3C (_,_,c) = c
@@ -763,11 +777,11 @@ class ExtractL4C (tp :: Type) 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"
+ type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 invalid for 2-tuples")
+ extractL4C _ = errorInProgram "L4 invalid 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"
+ type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 invalid for 3-tuples")
+ extractL4C _ = errorInProgram "L4 invalid for 3-tuples"
instance ExtractL4C (a,b,c,d) where
type ExtractL4T (a,b,c,d) = d
extractL4C (_,_,_,d) = d
@@ -789,14 +803,14 @@ class ExtractL5C (tp :: Type) 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"
+ type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 invalid for 2-tuples")
+ extractL5C _ = errorInProgram "L5 invalid 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"
+ type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 invalid for 3-tuples")
+ extractL5C _ = errorInProgram "L5 invalid 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"
+ type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 invalid for 4-tuples")
+ extractL5C _ = errorInProgram "L5 invalid for 4-tuples"
instance ExtractL5C (a,b,c,d,e) where
type ExtractL5T (a,b,c,d,e) = e
extractL5C (_,_,_,_,e) = e
@@ -815,17 +829,17 @@ class ExtractL6C (tp :: Type) 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"
+ type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 invalid for 2-tuples")
+ extractL6C _ = errorInProgram "L6 invalid 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"
+ type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 invalid for 3-tuples")
+ extractL6C _ = errorInProgram "L6 invalid 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"
+ type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 invalid for 4-tuples")
+ extractL6C _ = errorInProgram "L6 invalid 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"
+ type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 invalid for 5-tuples")
+ extractL6C _ = errorInProgram "L6 invalid for 5-tuples"
instance ExtractL6C (a,b,c,d,e,f) where
type ExtractL6T (a,b,c,d,e,f) = f
extractL6C (_,_,_,_,_,f) = f
@@ -841,20 +855,20 @@ class ExtractL7C (tp :: Type) 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"
+ type ExtractL7T (a,b) = GL.TypeError ('GL.Text "L7 invalid for 2-tuples")
+ extractL7C _ = errorInProgram "L7 invalid 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"
+ type ExtractL7T (a,b,c) = GL.TypeError ('GL.Text "L7 invalid for 3-tuples")
+ extractL7C _ = errorInProgram "L7 invalid 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"
+ type ExtractL7T (a,b,c,d) = GL.TypeError ('GL.Text "L7 invalid for 4-tuples")
+ extractL7C _ = errorInProgram "L7 invalid 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"
+ type ExtractL7T (a,b,c,d,e) = GL.TypeError ('GL.Text "L7 invalid for 5-tuples")
+ extractL7C _ = errorInProgram "L7 invalid 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"
+ type ExtractL7T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L7 invalid for 6-tuples")
+ extractL7C _ = errorInProgram "L7 invalid 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
@@ -867,23 +881,23 @@ class ExtractL8C (tp :: Type) 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"
+ type ExtractL8T (a,b) = GL.TypeError ('GL.Text "L8 invalid for 2-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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"
+ type ExtractL8T (a,b,c) = GL.TypeError ('GL.Text "L8 invalid for 3-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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"
+ type ExtractL8T (a,b,c,d) = GL.TypeError ('GL.Text "L8 invalid for 4-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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"
+ type ExtractL8T (a,b,c,d,e) = GL.TypeError ('GL.Text "L8 invalid for 5-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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"
+ type ExtractL8T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L8 invalid for 6-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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"
+ type ExtractL8T (a,b,c,d,e,f,g) = GL.TypeError ('GL.Text "L8 invalid for 7-tuples")
+ extractL8C _ = errorInProgram "L8 invalid 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
@@ -1231,27 +1245,71 @@ instance GetColor 'White where
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
+-- | wrapper for a Show instance around 'Color'
+newtype SStyle = SStyle Style
+ deriving newtype Enum
+instance Bounded SStyle where
+ minBound = SStyle Normal
+ maxBound = SStyle Reverse
+
+instance Show SStyle where
+ show (SStyle c) =
+ case c of
+ Normal -> "Normal"
+ Bold -> "Bold"
+ Faint -> "Faint"
+ Italic -> "Italic"
+ Underline -> "Underline"
+ SlowBlink -> "SlowBlink"
+ ColoredNormal -> "ColoredNormal"
+ Reverse -> "Reverse"
+
+-- | get 'Style' from the typelevel
+class GetStyle (a :: Style) where
+ getStyle :: Style
+instance GetStyle 'Normal where
+ getStyle = Normal
+instance GetStyle 'Bold where
+ getStyle = Bold
+instance GetStyle 'Faint where
+ getStyle = Faint
+instance GetStyle 'Italic where
+ getStyle = Italic
+instance GetStyle 'Underline where
+ getStyle = Underline
+instance GetStyle 'SlowBlink where
+ getStyle = SlowBlink
+instance GetStyle 'ColoredNormal where
+ getStyle = ColoredNormal
+instance GetStyle 'Reverse where
+ getStyle = Reverse
+
+-- | return the second value if the first is not empty
+unlessNull :: (AsEmpty t, Monoid m) => t -> m -> m
+unlessNull t m | has _Empty t = mempty
| otherwise = m
-unlessNullM :: (Foldable t, Applicative m) => t a -> (t a -> m ()) -> m ()
+-- | return the result of the second value if the first is not empty
+unlessNullM :: (AsEmpty t, Applicative m) => t -> (t -> m ()) -> m ()
unlessNullM t f
- | null t = pure ()
+ | has _Empty t = pure ()
| otherwise = f t
+-- | append a space if the given value is not empty
nullSpace :: String -> String
nullSpace = nullIf " "
+-- | combine the two values if the first is not empty
nullIf :: String -> String -> String
nullIf s t
| all isSpace t = ""
| otherwise = s <> t
+-- | catch an exception: for use in testing
pureTryTest :: a -> IO (Either () a)
pureTryTest = fmap (left (const ())) . E.try @E.SomeException . E.evaluate
+-- | catch an exception and the use a predicate to determine if it is the one we want: for use in testing
pureTryTestPred :: (String -> Bool)
-> a
-> IO (Either String (Either () a))
@@ -1300,6 +1358,7 @@ removeAnsiImpl =
_Id :: Lens (Identity a) (Identity b) a b
_Id afb (Identity a) = Identity <$> afb a
+-- | swap values in a bifunctor
class Bifunctor p => SwapC p where
swapC :: p a b -> p b a
instance SwapC Either where
@@ -1349,10 +1408,11 @@ ifM mb mt mf = do
b <- mb
if b then mt else mf
-
+-- | associate and unassociate certain two parameter types
class AssocC p where
assoc :: p (p a b) c -> p a (p b c)
unassoc :: p a (p b c) -> p (p a b) c
+
instance AssocC Either where
assoc (Left (Left a)) = Left a
assoc (Left (Right b)) = Right (Left b)
@@ -1361,6 +1421,7 @@ instance AssocC Either where
unassoc (Left a) = Left (Left a)
unassoc (Right (Left b)) = Left (Right b)
unassoc (Right (Right b)) = Right b
+
instance AssocC These where
assoc (This (This a)) = This a
assoc (This (That b)) = That (This b)
diff --git a/src/Predicate/Prelude.hs b/src/Predicate/Prelude.hs
deleted file mode 100644
index 766578e..0000000
--- a/src/Predicate/Prelude.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | Dsl for evaluating and displaying type level expressions
-module Predicate.Prelude (
- module Predicate.Core
- , module Predicate.Elr
- , module Predicate.Misc
- , module Predicate.Util
- , module Predicate.Data.Bits
- , module Predicate.Data.Char
- , module Predicate.Data.Condition
- , module Predicate.Data.DateTime
- , module Predicate.Data.Either
- , module Predicate.Data.Elr
- , module Predicate.Data.Enum
- , module Predicate.Data.Extra
- , module Predicate.Data.Foldable
- , module Predicate.Data.Index
- , 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
- , module Predicate.Data.These
- , module Predicate.Data.Tuple
- ) where
-import Predicate.Core
-import Predicate.Elr
-import Predicate.Misc
-import Predicate.Util
-import Predicate.Data.Bits
-import Predicate.Data.Char
-import Predicate.Data.Condition
-import Predicate.Data.DateTime
-import Predicate.Data.Either
-import Predicate.Data.Elr
-import Predicate.Data.Enum
-import Predicate.Data.Extra
-import Predicate.Data.Foldable
-import Predicate.Data.Index
-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
-import Predicate.Data.These
-import Predicate.Data.Tuple
diff --git a/src/Predicate/Refined.hs b/src/Predicate/Refined.hs
index df0089c..a60cb4b 100644
--- a/src/Predicate/Refined.hs
+++ b/src/Predicate/Refined.hs
@@ -67,7 +67,7 @@ import GHC.Generics (Generic)
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
-- >>> :set -XNoOverloadedLists
--- >>> :m + Predicate.Prelude
+-- >>> :m + Predicate
-- >>> :m + Control.Arrow
-- >>> :m + Text.Show.Functions
diff --git a/src/Predicate/Refined2.hs b/src/Predicate/Refined2.hs
index 765e0f7..3fd87d3 100644
--- a/src/Predicate/Refined2.hs
+++ b/src/Predicate/Refined2.hs
@@ -90,7 +90,7 @@ import GHC.Generics (Generic)
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> :m + Predicate.Prelude
+-- >>> :m + Predicate
-- >>> :m + Data.Time
-- | Refinement type for specifying an input type that is different from the output type
@@ -447,6 +447,54 @@ newRefined2P' _ i = do
-- >>> 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}
--
+-- >>> :m + Data.Ratio
+-- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "13 % 3"
+-- Right (Refined2 (13 % 3) "13 % 3")
+--
+-- >>> newRefined2 @OZ @(ReadP Rational Id) @'True "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 (13 % 3) "13 % 3")
+--
+-- >>> newRefined2 @OZ @(ReadP Rational Id) @(11 -% 2 <..> 3 -% 1) "-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
+--
+-- >>> 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
+--
+-- >>> newRefined2 @OZ @(ReadP UTCTime Id) @'True "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 (String "jsonstring") "String \"jsonstring\"")
+--
+-- >>> newRefined2 @OZ @(ReadP Value Id) @'True "Number 123.4"
+-- Right (Refined2 (Number 123.4) "Number 123.4")
+--
+-- >>> :m + Text.Show.Functions
+-- >>> 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
+--
newRefined2 :: forall opts ip op i
. ( Refined2C opts ip op i
, Show (PP ip i)
diff --git a/src/Predicate/Refined3.hs b/src/Predicate/Refined3.hs
index ebca30b..a33196f 100644
--- a/src/Predicate/Refined3.hs
+++ b/src/Predicate/Refined3.hs
@@ -24,12 +24,9 @@
{-# LANGUAGE NoStarIsType #-}
-- |
-- Refinement type allowing the external type to differ from the internal type
--- see 'Refined3'
--
-- @
--- similar to 'Predicate.Refined2.Refined2' but also provides:
--- * quickCheck methods
--- * a canonical output value using the \'fmt\' parameter
+-- like 'Predicate.Refined2.Refined2' but also supports a canonical output value using the \'fmt\' parameter
-- @
--
module Predicate.Refined3 (
@@ -97,7 +94,7 @@ import GHC.Generics (Generic)
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> :m + Predicate.Prelude
+-- >>> :m + Predicate
-- >>> :m + Data.Time
-- | Like 'Predicate.Refined2' but additionally reconstructs the output value to a standardized format
diff --git a/src/Predicate/Refined5.hs b/src/Predicate/Refined5.hs
index a55bfd5..7a8bf6c 100644
--- a/src/Predicate/Refined5.hs
+++ b/src/Predicate/Refined5.hs
@@ -26,7 +26,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE NoStarIsType #-}
--- | refinement type allowing the external type to differ from the internal type
+-- | refinement type allowing the external type to differ from the internal type but throws away the original value
module Predicate.Refined5 (
-- ** Refined5
@@ -84,7 +84,7 @@ import GHC.Generics (Generic)
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XOverloadedStrings
--- >>> :m + Predicate.Prelude
+-- >>> :m + Predicate
-- >>> :m + Predicate.Refined2
-- >>> :m + Data.Time
diff --git a/src/Predicate/TH_Orphans.hs b/src/Predicate/TH_Orphans.hs
deleted file mode 100644
index 56a4d49..0000000
--- a/src/Predicate/TH_Orphans.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# OPTIONS -Wno-orphans #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE PolyKinds #-}
--- | orphan Lift instances for Data.Time
-module Predicate.TH_Orphans () where
-import Language.Haskell.TH.Syntax (Lift)
-import Data.Time
-import Data.Fixed (Fixed(..))
-import qualified Language.Haskell.TH.Lift as TL
-import Data.Proxy (Proxy)
-import Data.These (These(..))
-
-deriving instance Lift Day
-deriving instance Lift LocalTime
-deriving instance Lift ZonedTime
-deriving instance Lift TimeZone
-deriving instance Lift TimeOfDay
-deriving instance Lift (Fixed a)
-deriving instance Lift Ordering
-deriving instance (Lift a, Lift b) => Lift (These a b)
-
-$(TL.deriveLift ''DiffTime)
-
-deriving instance Lift UTCTime
-
-$(TL.deriveLift ''Proxy)
-
-
-
diff --git a/src/Predicate/Util.hs b/src/Predicate/Util.hs
index b8ec440..1959100 100644
--- a/src/Predicate/Util.hs
+++ b/src/Predicate/Util.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -21,9 +19,10 @@
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
--- | utility methods for Predicate / methods for displaying the evaluation tree
+-- | utility methods
module Predicate.Util (
-- ** Val
Val(..)
@@ -142,7 +141,7 @@ 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 System.Console.Pretty (Style(..), Color(..))
import qualified System.Console.Pretty as C
import qualified Control.Exception as E
import Control.DeepSeq (NFData, ($!!))
@@ -160,9 +159,8 @@ import qualified Safe (initSafe, fromJustNote)
import Control.Monad (ap)
import Data.Bool (bool)
import GHC.Generics (Generic, Generic1)
-import qualified Language.Haskell.TH.Lift as TH
-import Instances.TH.Lift ()
import Data.Kind (Type)
+import Data.Data (Data)
-- $setup
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
@@ -175,16 +173,14 @@ data ValP =
| FalseP -- ^ False predicate
| TrueP -- ^ True predicate
| ValP -- ^ Any value
- deriving stock (Show, Ord, Eq, Read, Generic)
- deriving TH.Lift
+ deriving stock (Show, Ord, Eq, Read, Generic, Data)
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)
- deriving TH.Lift
+ } deriving stock (Show, Read, Eq, Generic, Data)
makeLenses ''PE
@@ -252,8 +248,7 @@ instance Monoid ValP where
-- | 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)
- deriving TH.Lift
+ deriving stock (Show, Eq, Ord, Read, Functor, Foldable, Traversable, Generic, Generic1, Data)
makePrisms ''Val
@@ -330,8 +325,7 @@ 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)
- deriving stock TH.Lift
+ } deriving stock (Functor, Read, Show, Eq, Foldable, Traversable, Generic, Generic1, Data)
-- dont expose lenses for _ttValP and _ttVal as they must be kept in sync: see ttVal
makeLensesFor [("_ttString","ttString"),("_ttForest","ttForest")] ''TT
@@ -474,7 +468,7 @@ data HOpts f =
, oRecursion :: !(HKD f Int) -- ^ max recursion for small values
, oRecursionLarge :: !(HKD f Int) -- ^ max recursion for large values eg for Text
, oLarge :: !(HKD f Bool) -- ^ use large value recursion
- , oOther :: !(HKD f (Bool, SColor, SColor)) -- ^ other message effects
+ , oOther :: !(HKD f (SStyle, SColor, SColor)) -- ^ other message effects
, oNoColor :: !(HKD f Bool) -- ^ no colors
}
@@ -489,7 +483,7 @@ deriving stock instance
, Show (HKD f Disp)
, Show (HKD f (String, PColor))
, Show (HKD f Bool)
- , Show (HKD f (Bool, SColor, SColor))
+ , Show (HKD f (SStyle, SColor, SColor))
) => Show (HOpts f)
-- | convert to a usable option using defaults to fill in any gaps
@@ -533,7 +527,7 @@ setLarge :: Bool -> HOpts Last
setLarge b = mempty { oLarge = pure b }
-- | set color of title message
-setOther :: Bool
+setOther :: Style
-> Color
-> Color
-> HOpts Last
@@ -611,8 +605,8 @@ defOpts = HOpts
}
-- | default title message color and boundaries between multipart refine messages
-otherDef :: (Bool, SColor, SColor)
-otherDef = coerce (True, Default, Default)
+otherDef :: (SStyle, SColor, SColor)
+otherDef = coerce (Normal, Default, Default)
nocolor, colorDef :: (String, PColor)
-- | skip colors
@@ -644,9 +638,9 @@ type Color4 = 'OColor "color4" 'Default 'Red 'Red 'Default 'Green 'Default 'Blac
type Color5 = 'OColor "color5" 'Blue 'Default 'Red 'Default 'Cyan 'Default 'Yellow 'Default
-- | color palette for effects used in 'Predicate.Core.Msg' and the refined modules
-type Other1 = 'OOther 'True 'Yellow 'Default
+type Other1 = 'OOther 'Underline 'Yellow 'Default
-- | color palette for effects used in 'Predicate.Core.Msg' and the refined modules
-type Other2 = 'OOther 'True 'Default 'Default
+type Other2 = 'OOther 'Underline 'Default 'Default
-- | display a message and three values where the last one is displayed in verbose mode
show3 :: (Show a1, Show a2)
@@ -943,7 +937,7 @@ data Opt =
| ORecursionLarge !Nat -- ^ set recursion limit for large fields
| OLarge !Bool -- ^ use large recursion
| OOther -- ^ set effects for messages
- !Bool -- ^ set underline
+ !Style -- ^ set style
!Color -- ^ set foreground color
!Color -- ^ set background color
| !Opt :# !Opt -- ^ mappend
@@ -992,11 +986,11 @@ instance KnownNat n => OptC ('ORecursionLarge n) where
getOptC = setRecursionLarge (nat @n)
instance GetBool b => OptC ('OLarge b) where
getOptC = setLarge (getBool @b)
-instance ( GetBool b
+instance ( GetStyle s
, GetColor c1
, GetColor c2
- ) => OptC ('OOther b c1 c2) where
- getOptC = setOther (getBool @b) (getColor @c1) (getColor @c2)
+ ) => OptC ('OOther s c1 c2) where
+ getOptC = setOther (getStyle @s) (getColor @c1) (getColor @c2)
instance OptC 'OEmpty where
getOptC = mempty
instance ( OptC a
@@ -1098,8 +1092,8 @@ type OUNV = 'OUNV -- 'OUnicode ':# 'OColorOff ':# 'OVerbose ':# 'OWidth 200
-- >>> oMsg (getOpt @('OMsg "abc" ':# 'OMsg "def"))
-- ["abc","def"]
--
--- >>> oOther (getOpt @('OOther 'False 'Red 'White ':# 'OOther 'True 'Red 'Black))
--- (True,Red,Black)
+-- >>> oOther (getOpt @('OOther 'Normal 'Red 'White ':# 'OOther 'Underline 'Red 'Black))
+-- (Underline,Red,Black)
--
-- >>> a = show (getOpt @('OEmpty ':# OU))
-- >>> b = show (getOpt @(OU ':# 'OEmpty));
@@ -1157,8 +1151,8 @@ 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
+ (Normal, Default, Default) -> id
+ (s, c1, c2) -> C.style s . C.color c1 . C.bgColor c2
-- | mconcat 'Opt' options at the type level
--
diff --git a/src/Predicate/Util_TH.hs b/src/Predicate/Util_TH.hs
index 4f82db8..bad3d52 100644
--- a/src/Predicate/Util_TH.hs
+++ b/src/Predicate/Util_TH.hs
@@ -8,7 +8,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoStarIsType #-}
--- | Template Haskell methods for creating Refined, Refined2, and Refined3 refinement types
+-- | Template Haskell methods for creating Refined* refinement types
module Predicate.Util_TH (
-- ** Refined
refinedTH
@@ -42,7 +42,7 @@ import qualified Language.Haskell.TH.Syntax as TH
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XTemplateHaskell
--- >>> :m + Predicate.Prelude
+-- >>> :m + Predicate
-- | creates a 'Refined.Refined' refinement type
--
diff --git a/test/TastyExtras.hs b/test/TastyExtras.hs
index 206a437..298d838 100644
--- a/test/TastyExtras.hs
+++ b/test/TastyExtras.hs
@@ -1,4 +1,5 @@
{-# OPTIONS -Wno-compat #-}
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
diff --git a/test/TestJson.hs b/test/TestJson.hs
index 4f48486..7510b82 100644
--- a/test/TestJson.hs
+++ b/test/TestJson.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
@@ -10,7 +11,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoStarIsType #-}
module TestJson where
---module TestJson (suite) where
import TastyExtras
import Test.Tasty
import Test.Tasty.HUnit
diff --git a/test/TestPredicate.hs b/test/TestPredicate.hs
index 941549c..f7cdc42 100644
--- a/test/TestPredicate.hs
+++ b/test/TestPredicate.hs
@@ -1,4 +1,5 @@
{-# OPTIONS -Wno-type-defaults #-}
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
@@ -11,7 +12,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoStarIsType #-}
module TestPredicate where
---module TestPredicate (suite) where
import TastyExtras
import Test.Tasty
import Test.Tasty.HUnit
diff --git a/test/TestRefined.hs b/test/TestRefined.hs
index b863969..9ff6d47 100644
--- a/test/TestRefined.hs
+++ b/test/TestRefined.hs
@@ -1,4 +1,5 @@
{-# OPTIONS -Wno-type-defaults #-}
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
@@ -10,7 +11,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoStarIsType #-}
module TestRefined where
---module TestRefined (suite) where
import TastyExtras
import Test.Tasty
import Test.Tasty.HUnit
diff --git a/test/TestRefined2.hs b/test/TestRefined2.hs
index 80cba2d..2b40467 100644
--- a/test/TestRefined2.hs
+++ b/test/TestRefined2.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
@@ -11,7 +12,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoStarIsType #-}
module TestRefined2 where
---module TestRefined2 (suite) where
import TastyExtras
import Test.Tasty
import Test.Tasty.HUnit
@@ -49,7 +49,6 @@ namedTests =
, 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"))
@@ -153,9 +152,7 @@ unnamedTests = [
, 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"
@@ -215,7 +212,6 @@ tst0a =
, 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) (() <$)
@@ -286,9 +282,6 @@ expect2 :: (HasCallStack, Show i, Show r, Eq i, Eq r)
expect2 lhs (rhs,mr) =
(@?=) (maybe (Left $ toRResults2 rhs) Right mr) lhs
-test2a :: Either Msg2 (MakeR2 (BaseN OAN 16))
-test2a = newRefined2 "0000fe"
-
test2b :: Either Msg2 (Refined2 OAN
(Rescan "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" >> Head >> Snd >> Map (ReadP Int Id))
(All (0 <..> 0xff))
diff --git a/test/TestRefined3.hs b/test/TestRefined3.hs
index 99e8007..87bc021 100644
--- a/test/TestRefined3.hs
+++ b/test/TestRefined3.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -Wno-missing-export-lists #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
@@ -11,7 +12,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoStarIsType #-}
module TestRefined3 where
---module TestRefined3 (suite) where
import TastyExtras
import Test.Tasty
import Test.Tasty.HUnit
@@ -49,7 +49,7 @@ namedTests =
, 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 "base16" $ (@?=) (newRefined3 "12f" :: Either Msg3 (MakeR3 (BaseN OAN 16 'True))) (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"))
@@ -162,10 +162,10 @@ unnamedTests = [
, 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 (Left $ XTF [1,2,3,4,5] "Bools:invalid length(5) expected 4") $ runIdentity $ eval3P (mkProxy3 @(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 (mkProxy3 @(Ip4' OZ)) "1.2.300.4"
+ , expect3 (Left (XTF [1,2,300,4] "Bool(2) [octet 2 out of range 0-255 found 300] (300 <= 255)")) $ runIdentity $ eval3P (mkProxy3 @(Ip4' OL)) "1.2.300.4"
- , 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"
diff --git a/test/TestSpec.hs b/test/TestSpec.hs
index c375564..084f626 100644
--- a/test/TestSpec.hs
+++ b/test/TestSpec.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -Wno-missing-export-lists #-}
module Main where
import qualified TestPredicate
import qualified TestJson