predicate-typed 0.6.0.0 → 0.6.0.1

raw patch · 4 files changed

+195/−21 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• predicate-typed.cabal +2/−2
• src/Predicate/Core.hs +155/−6
• src/Predicate/Prelude.hs +36/−12
• test/TestPredicate.hs +2/−1

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 91077e765e3f765a00629565212c20b373d1e8cd724f4f9c4f381835f0e4f561+-- hash: f1f9e40a4b553c8230e185e0f814bef7d0729733e864694a8ccff37ce4306c6f  name:           predicate-typed-version:        0.6.0.0+version:        0.6.0.1 synopsis:       Predicates, Refinement types and Dsl description:    Please see the README on GitHub at <https://github.com/gbwey/predicate-typed#readme> category:       Data

@@ -245,11 +245,13 @@     case lr of
       Left e -> pure e
       Right (p,q,pp,qq) -> do
-         let hhs = [hh pp, hh qq]
+         let hhs0 = [hh pp, hh qq]
          rr <- eval (Proxy @r) opts a
-         pure $ case getValueLR opts msg rr hhs of
+         pure $ case getValueLR opts msg rr hhs0 of
            Left e -> e
-           Right r -> mkNode opts (PresentT (p,q,r)) [msg] (hhs <> [hh rr])
+           Right r ->
+             let hhs1 = hhs0 <> [hh rr]
+             in mkNode opts (PresentT (p,q,r)) [msg] hhs1
 
 -- | run the predicates in a promoted 4-tuple
 --
@@ -264,16 +266,163 @@         ) => P '(p,q,r,s) a where
   type PP '(p,q,r,s) a = (PP p a, PP q a, PP r a, PP s a)
   eval _ opts a = do
-    let msg = "'(,,)"
+    let msg = "'(,,,)"
     lr <- runPQ msg (Proxy @p) (Proxy @q) opts a []
     case lr of
       Left e -> pure e
       Right (p,q,pp,qq) -> do
-        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a [hh pp, hh qq]
+        let hhs0 = [hh pp, hh qq]
+        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0
         pure $ case lr1 of
           Left e -> e
           Right (r,s,rr,ss) ->
-            mkNode opts (PresentT (p,q,r,s)) [msg] [hh pp, hh qq, hh rr, hh ss]
+            let hhs1 = hhs0 ++ [hh rr, hh ss]
+            in mkNode opts (PresentT (p,q,r,s)) [msg] hhs1
+
+-- | run the predicates in a promoted 5-tuple
+--
+-- >>> pz @'(4, Id, "inj", 999, 'LT) "hello"
+-- Present (4,"hello","inj",999,LT)
+-- PresentT (4,"hello","inj",999,LT)
+--
+instance (P p a
+        , P q a
+        , P r a
+        , P s a
+        , P t a
+        ) => P '(p,q,r,s,t) a where
+  type PP '(p,q,r,s,t) a = (PP p a, PP q a, PP r a, PP s a, PP t a)
+  eval _ opts a = do
+    let msg = "'(,,,,)"
+    lr <- runPQ msg (Proxy @p) (Proxy @q) opts a []
+    case lr of
+      Left e -> pure e
+      Right (p,q,pp,qq) -> do
+        let hhs0 = [hh pp, hh qq]
+        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0
+        case lr1 of
+          Left e -> pure e
+          Right (r,s,rr,ss) -> do
+            let hhs1 = hhs0 ++ [hh rr, hh ss]
+            tt <- eval (Proxy @t) opts a
+            pure $ case getValueLR opts msg tt hhs1 of
+              Left e -> e
+              Right t ->
+                let hhs2 = hhs1 <> [hh tt]
+                in mkNode opts (PresentT (p,q,r,s,t)) [msg] hhs2
+
+-- | run the predicates in a promoted 6-tuple
+--
+-- >>> pz @'(4, Id, "inj", 999, 'LT, 1) "hello"
+-- Present (4,"hello","inj",999,LT,1)
+-- PresentT (4,"hello","inj",999,LT,1)
+--
+instance (P p a
+        , P q a
+        , P r a
+        , P s a
+        , P t a
+        , P u a
+        ) => P '(p,q,r,s,t,u) a where
+  type PP '(p,q,r,s,t,u) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a)
+  eval _ opts a = do
+    let msg = "'(,,,,,)"
+    lr <- runPQ msg (Proxy @p) (Proxy @q) opts a []
+    case lr of
+      Left e -> pure e
+      Right (p,q,pp,qq) -> do
+        let hhs0 = [hh pp, hh qq]
+        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0
+        case lr1 of
+          Left e -> pure e
+          Right (r,s,rr,ss) -> do
+            let hhs1 = hhs0 ++ [hh rr, hh ss]
+            lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1
+            pure $ case lr2 of
+              Left e -> e
+              Right (t,u,tt,uu) ->
+                let hhs2 = hhs1 ++ [hh tt, hh uu]
+                in mkNode opts (PresentT (p,q,r,s,t,u)) [msg] hhs2
+
+-- | run the predicates in a promoted 7-tuple
+--
+-- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2) "hello"
+-- Present (4,"hello","inj",999,LT,1,2)
+-- PresentT (4,"hello","inj",999,LT,1,2)
+--
+instance (P p a
+        , P q a
+        , P r a
+        , P s a
+        , P t a
+        , P u a
+        , P v a
+        ) => P '(p,q,r,s,t,u,v) a where
+  type PP '(p,q,r,s,t,u,v) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a)
+  eval _ opts a = do
+    let msg = "'(,,,,,,)"
+    lr <- runPQ msg (Proxy @p) (Proxy @q) opts a []
+    case lr of
+      Left e -> pure e
+      Right (p,q,pp,qq) -> do
+        let hhs0 = [hh pp, hh qq]
+        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0
+        case lr1 of
+          Left e -> pure e
+          Right (r,s,rr,ss) -> do
+            let hhs1 = hhs0 ++ [hh rr, hh ss]
+            lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1
+            case lr2 of
+              Left e -> pure e
+              Right (t,u,tt,uu) -> do
+                vv <- eval (Proxy @v) opts a
+                let hhs2 = hhs1 ++ [hh tt, hh uu]
+                pure $ case getValueLR opts msg vv hhs2 of
+                  Left e -> e
+                  Right v ->
+                    let hhs3 = hhs2 ++ [hh vv]
+                    in mkNode opts (PresentT (p,q,r,s,t,u,v)) [msg] hhs3
+
+-- | run the predicates in a promoted 8-tuple
+--
+-- >>> pz @'(4, Id, "inj", 999, 'LT, 1, 2, 3) "hello"
+-- Present (4,"hello","inj",999,LT,1,2,3)
+-- PresentT (4,"hello","inj",999,LT,1,2,3)
+--
+instance (P p a
+        , P q a
+        , P r a
+        , P s a
+        , P t a
+        , P u a
+        , P v a
+        , P w a
+        ) => P '(p,q,r,s,t,u,v,w) a where
+  type PP '(p,q,r,s,t,u,v,w) a = (PP p a, PP q a, PP r a, PP s a, PP t a, PP u a, PP v a, PP w a)
+  eval _ opts a = do
+    let msg = "'(,,,,,,,)"
+    lr <- runPQ msg (Proxy @p) (Proxy @q) opts a []
+    case lr of
+      Left e -> pure e
+      Right (p,q,pp,qq) -> do
+        let hhs0 = [hh pp, hh qq]
+        lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a hhs0
+        case lr1 of
+          Left e -> pure e
+          Right (r,s,rr,ss) -> do
+            let hhs1 = hhs0 ++ [hh rr, hh ss]
+            lr2 <- runPQ msg (Proxy @t) (Proxy @u) opts a hhs1
+            case lr2 of
+              Left e -> pure e
+              Right (t,u,tt,uu) -> do
+                let hhs2 = hhs1 ++ [hh tt, hh uu]
+                lr3 <- runPQ msg (Proxy @v) (Proxy @w) opts a hhs2
+                pure $ case lr3 of
+                  Left e -> e
+                  Right (v,w,vv,ww) ->
+                     let hhs3 = hhs2 ++ [hh vv, hh ww]
+                     in mkNode opts (PresentT (p,q,r,s,t,u,v,w)) [msg] hhs3
+
 
 -- | extracts the value level representation of the promoted 'Ordering'
 --

@@ -1384,16 +1384,6 @@ -- False
 -- FalseT
 --
--- | predicate for determining if a string is all lowercase
---
--- >>> pz @IsLower '1'
--- False
--- FalseT
---
--- >>> pz @IsLower 'a'
--- True
--- TrueT
---
 data IsCharSet (cs :: CharSet)
 
 instance (x ~ Char, GetCharSet cs) => P (IsCharSet cs) x where
@@ -1404,6 +1394,20 @@         b = f c
     in pure $ mkNodeB opts b [msg0 <> show1 opts " | " [c]] []
 
+-- | predicate for determining if a character is lowercase
+--
+-- >>> pz @IsLower '1'
+-- False
+-- FalseT
+--
+-- >>> pz @IsLower 'a'
+-- True
+-- TrueT
+--
+-- >>> pz @(Map '(IsControl, IsLatin1, IsHexDigit, IsOctDigit, IsNumber, IsPunctuation, IsSeparator, IsSpace) Id) "abc134"
+-- Present [(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False)]
+-- PresentT [(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,False,False,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False),(False,True,True,True,True,False,False,False)]
+--
 data IsLower
 type IsLowerT = IsCharSet 'CLower
 
@@ -1418,7 +1422,7 @@   type PP IsUpper x = PP IsUpperT x
   eval _ = evalBool (Proxy @IsUpperT)
 
--- | predicate for determining if the string is all digits
+-- | predicate for determining if the character is a digit
 --
 -- >>> pz @IsNumber 'g'
 -- False
@@ -1534,6 +1538,26 @@ -- True ((>>) True | {True (&*) True})
 -- TrueT
 --
+-- >>> pz @( '(IsControlAll, IsLatin1All , IsHexDigitAll , IsOctDigitAll , IsNumberAll , IsPunctuationAll , IsSeparatorAll , IsSpaceAll ) ) "abc134"
+-- Present (False,True,True,False,False,False,False,False)
+-- PresentT (False,True,True,False,False,False,False,False)
+--
+-- >>> pl @(SplitAts [1,2,10] Id >> Para '[IsLowerAll, IsNumberAll, IsUpperAll ]) "abdefghi"
+-- Present [True,False,False] ((>>) [True,False,False] | {Para(0) [True,False,False] | ["a","bd","efghi"]})
+-- PresentT [True,False,False]
+--
+-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsNumberAll, IsUpperAll ]) "a98efghi"
+-- False ((>>) False | {Bool(2) [] (IsUpperAll | "efghi")})
+-- FalseT
+--
+-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsNumberAll, IsUpperAll || IsLowerAll ]) "a98efghi"
+-- True ((>>) True | {Bools})
+-- TrueT
+--
+-- >>> pl @(SplitAts [1,2,10] Id >> BoolsQuick "" '[IsLowerAll, IsNumberAll, IsUpperAll || IsLowerAll ]) "a98efgHi"
+-- False ((>>) False | {Bool(2) [] (False || False | (IsUpperAll | "efgHi") || (IsLowerAll | "efgHi"))})
+-- FalseT
+--
 data IsCharSetAll (cs :: CharSet)
 
 instance (GetCharSet cs
@@ -8446,7 +8470,7 @@ 
 -- | similar to 'readFile'
 --
--- >>> pz @(ReadFile ".ghci" >> 'Just Id >> Len > 0) ()
+-- >>> pz @(ReadFile "LICENSE" >> 'Just Id >> Len > 0) ()
 -- True
 -- TrueT
 --

@@ -521,7 +521,6 @@   , expectPE (PresentT "lhs = 123 rhs = asdf") $ pl @(PrintT "lhs = %d rhs = %s" Id) (123::Int,"asdf"::String)
   , expectPE TrueT $ pl @(DirExists ".") ()
   , expectPE FalseT $ pl @(DirExists "xxy") ()
-  , expectPE TrueT $ pl @(FileExists ".ghci") ()
   , expectPE FalseT $ pl @(FileExists "xxy") ()
   , expectPE TrueT $ pl @(IsInfix "ab" Id) "xyzabw"
   , expectPE FalseT $ pl @(IsInfix "aB" Id) "xyzAbw"
@@ -839,6 +838,8 @@   , expectPE (PresentT (4,"helo","oleh")) $ pl @'(Len, Id, Reverse) "helo"
   , expectPE (PresentT [1,2,3,1000,998]) $ pl @'[W 1, W 2, W 3, Succ Id, Pred Id] 999
   , expectPE (PresentT [3996,998]) $ pl @'[Id * 4, Pred Id] 999
+
+  , expectPE (PresentT (These [1,2,3,4] "Abcdef")) $ pz @(MkThat _ "Abc" <> MkThis _ '[1,2] <> MkThese [3,4] "def") ()
   ]
 
 type Fizzbuzz = '(Id,  If (Id `Mod` 3==0) "fizz" "" <> If (Id `Mod` 5==0) "buzz" "")