haskus-utils 0.7.0.0 → 0.8.0.0

raw patch · 16 files changed

+1876/−658 lines, 16 filesdep ~basedep ~containersdep ~extrasetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, extra, file-embed, list-t, mtl, stm, stm-containers, tasty, tasty-quickcheck, template-haskell, transformers, vector

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• haskus-utils.cabal +73/−77
• src/lib/Haskus/Utils/Embed.hs +104/−0
• src/lib/Haskus/Utils/Flow.hs +133/−133
• src/lib/Haskus/Utils/List.hs +2/−0
• src/lib/Haskus/Utils/Map/Strict.hs +7/−0
• src/lib/Haskus/Utils/Maybe.hs +6/−1
• src/lib/Haskus/Utils/Parser.hs +17/−17
• src/lib/Haskus/Utils/Solver.hs +555/−0
• src/lib/Haskus/Utils/Tuple.hs +7/−1
• src/lib/Haskus/Utils/Types.hs +23/−6
• src/lib/Haskus/Utils/Types/List.hs +73/−35
• src/lib/Haskus/Utils/Variant.hs +580/−350
• src/tests/Haskus/Tests/Utils.hs +2/−0
• src/tests/Haskus/Tests/Utils/Solver.hs +240/−0
• src/tests/Haskus/Tests/Utils/Variant.hs +54/−36

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,83 +1,79 @@-name:                haskus-utils-version:             0.7.0.0-synopsis:            Haskus utility modules-license:             BSD3-license-file:        LICENSE-author:              Sylvain Henry-maintainer:          sylvain@haskus.fr-homepage:            http://www.haskus.org/system-copyright:           Sylvain Henry 2017-category:            System-build-type:          Simple-cabal-version:       >=1.20-+name: haskus-utils+version: 0.8.0.0+cabal-version: >=1.20+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Sylvain Henry 2018+maintainer: sylvain@haskus.fr+homepage: http://www.haskus.org/system+synopsis: Haskus utility modules description:-   Various utility modules used by Haskus packages.+    Various utility modules used by Haskus packages.+category: System+author: Sylvain Henry  source-repository head-  type: git-  location: git://github.com/haskus/haskus-utils.git+    type: git+    location: git://github.com/haskus/haskus-utils.git  library-  exposed-modules:-    Haskus.Utils.ContFlow-    Haskus.Utils.Variant-    Haskus.Utils.Monad-    Haskus.Utils.Parser-    Haskus.Utils.HArray-    Haskus.Utils.Flow-    Haskus.Utils.MultiState-    Haskus.Utils.HList-    Haskus.Utils.Embed-    Haskus.Utils.List-    Haskus.Utils.Map-    Haskus.Utils.Maybe-    Haskus.Utils.Types-    Haskus.Utils.Types.List-    Haskus.Utils.Types.Generics-    Haskus.Utils.STM-    Haskus.Utils.STM.TEq-    Haskus.Utils.STM.TMap-    Haskus.Utils.STM.TSet-    Haskus.Utils.STM.TList-    Haskus.Utils.STM.TTree-    Haskus.Utils.STM.Future-    Haskus.Utils.STM.TGraph-    Haskus.Utils.Tuple--  other-modules:--  build-depends:       -         base                      >= 4.9 && < 4.10-      ,  containers                >= 0.5-      ,  list-t                    >= 0.4-      ,  stm                       >= 2.4-      ,  stm-containers            >= 0.2-      ,  vector                    >= 0.11-      ,  transformers              >= 0.4-      ,  mtl                       >= 2.2-      ,  template-haskell          >= 2.10-      ,  file-embed                >= 0.0.10-      ,  extra                     >= 1.4--  build-tools: -  ghc-options:          -Wall-  default-language:     Haskell2010-  hs-source-dirs:       src/lib--test-suite tests-   type:                exitcode-stdio-1.0-   main-is:             Main.hs-   hs-source-dirs:      src/tests-   ghc-options:         -O2 -Wall -threaded-   default-language:    Haskell2010-   other-modules:-         Haskus.Tests.Utils-      ,  Haskus.Tests.Utils.HArray-      ,  Haskus.Tests.Utils.Variant+    exposed-modules:+        Haskus.Utils.Solver+        Haskus.Utils.ContFlow+        Haskus.Utils.Variant+        Haskus.Utils.Monad+        Haskus.Utils.Parser+        Haskus.Utils.HArray+        Haskus.Utils.Flow+        Haskus.Utils.MultiState+        Haskus.Utils.HList+        Haskus.Utils.Embed+        Haskus.Utils.List+        Haskus.Utils.Map+        Haskus.Utils.Map.Strict+        Haskus.Utils.Maybe+        Haskus.Utils.Types+        Haskus.Utils.Types.List+        Haskus.Utils.Types.Generics+        Haskus.Utils.STM+        Haskus.Utils.STM.TEq+        Haskus.Utils.STM.TMap+        Haskus.Utils.STM.TSet+        Haskus.Utils.STM.TList+        Haskus.Utils.STM.TTree+        Haskus.Utils.STM.Future+        Haskus.Utils.STM.TGraph+        Haskus.Utils.Tuple+    build-depends:+        base >=4.9 && <4.11,+        containers ==0.5.*,+        list-t >=0.4 && <1.1,+        stm ==2.4.*,+        stm-containers ==0.2.*,+        vector >=0.11 && <0.13,+        transformers >=0.4 && <0.6,+        mtl ==2.2.*,+        template-haskell >=2.10 && <2.13,+        file-embed >=0.0.10 && <0.1,+        extra >=1.4 && <1.7+    default-language: Haskell2010+    hs-source-dirs: src/lib+    ghc-options: -Wall -   build-depends:    -         base-      ,  haskus-utils-      ,  tasty                   >= 0.11-      ,  tasty-quickcheck        >= 0.8+test-suite  tests+    type: exitcode-stdio-1.0+    main-is: Main.hs+    build-depends:+        base >=4.10.1.0 && <4.11,+        haskus-utils -any,+        tasty ==0.11.*,+        tasty-quickcheck >=0.8 && <0.10+    default-language: Haskell2010+    hs-source-dirs: src/tests+    other-modules:+        Haskus.Tests.Utils+        Haskus.Tests.Utils.HArray+        Haskus.Tests.Utils.Variant+        Haskus.Tests.Utils.Solver+    ghc-options: -Wall -threaded

@@ -2,13 +2,117 @@ module Haskus.Utils.Embed    ( embedBytes    , module Data.FileEmbed+   -- | Raw text quasiquoter+   , raw+   , rawQ    ) where  import Language.Haskell.TH+import Language.Haskell.TH.Quote import Data.FileEmbed import Data.Word  -- | Embed bytes in a C array, return an Addr# embedBytes :: [Word8] -> Q Exp embedBytes bs = return $ LitE (StringPrimL bs)++++{-| Adapted from the raw-strings-qq package (BSD3)++A quasiquoter for raw string literals - that is, string literals that don't+recognise the standard escape sequences (such as @\'\\n\'@). Basically, they+make your code more readable by freeing you from the responsibility to escape+backslashes. They are useful when working with regular expressions, DOS/Windows+paths and markup languages (such as XML).++Don't forget the @LANGUAGE QuasiQuotes@ pragma if you're using this+module in your code.++Usage:++@+    ghci> :set -XQuasiQuotes+    ghci> import Text.RawString.QQ+    ghci> let s = [raw|\\w+\@[a-zA-Z_]+?\\.[a-zA-Z]{2,3}|]+    ghci> s+    \"\\\\w+\@[a-zA-Z_]+?\\\\.[a-zA-Z]{2,3}\"+    ghci> [raw|C:\\Windows\\SYSTEM|] ++ [raw|\\user32.dll|]+    \"C:\\\\Windows\\\\SYSTEM\\\\user32.dll\"+@++Multiline raw string literals are also supported:++@+    multiline :: String+    multiline = [raw|\<HTML\>+    \<HEAD\>+    \<TITLE\>Auto-generated html formated source\</TITLE\>+    \<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\"\>+    \</HEAD\>+    \<BODY LINK=\"#0000ff\" VLINK=\"#800080\" BGCOLOR=\"#ffffff\"\>+    \<P\> \</P\>+    \<PRE\>|]+@++Caveat: since the @\"|]\"@ character sequence is used to terminate the+quasiquotation, you can't use it inside the raw string literal. Use 'rawQ' if you+want to embed that character sequence inside the raw string.+-}+raw :: QuasiQuoter+raw = QuasiQuoter {+    -- Extracted from dead-simple-json.+    quoteExp  = return . LitE . StringL . normaliseNewlines,++    quotePat  = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a pattern)",+    quoteType = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a type)",+    quoteDec  = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a declaration)"+}++{-| A variant of 'raw' that interprets the @\"|~]\"@ sequence as @\"|]\"@,+@\"|~~]\"@ as @\"|~]\"@ and, in general, @\"|~^n]\"@ as @\"|~^(n-1)]\"@+for n >= 1.++Usage:++@+    ghci> [rawQ||~]|~]|]+    \"|]|]\"+    ghci> [rawQ||~~]|]+    \"|~]\"+    ghci> [rawQ||~~~~]|]+    \"|~~~]\"+@+-}+rawQ :: QuasiQuoter+rawQ = QuasiQuoter {+    quoteExp  = return . LitE . StringL . escape_rQ . normaliseNewlines,++    quotePat  = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a pattern)",+    quoteType = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a type)",+    quoteDec  = \_ -> fail "illegal raw string QuasiQuote \+                           \(allowed as expression only, used as a declaration)"+}++escape_rQ :: String -> String+escape_rQ [] = []+escape_rQ ('|':'~':xs) =+  let (tildas, rest) = span (== '~') xs+  in case rest of+    []       -> '|':'~':tildas+    (']':rs) -> '|':tildas ++ ']':escape_rQ rs+    rs       -> '|':'~':tildas ++ escape_rQ rs+escape_rQ (x:xs) = x : escape_rQ xs++-- See https://github.com/23Skidoo/raw-strings-qq/issues/1 and+-- https://ghc.haskell.org/trac/ghc/ticket/11215.+normaliseNewlines :: String -> String+normaliseNewlines []             = []+normaliseNewlines ('\r':'\n':cs) = '\n':normaliseNewlines cs+normaliseNewlines (c:cs)         = c:normaliseNewlines cs

@@ -27,8 +27,8 @@    , flowTraverseFilter    , flowForFilter    , Liftable-   , Catchable-   , MaybeCatchable+   , Popable+   , MaybePopable    -- * Non-variant single operations    , (|>)    , (<|)@@ -128,7 +128,7 @@    , (>..~!>)    , (..~!!>)    , (>..~!!>)-   -- * Tail catch operations+   -- * Tail pop operations    , (..%~^>)    , (>..%~^>)    , (..%~^^>)@@ -230,12 +230,12 @@    , KnownNat n    ) => Index n xs -> Flow m xs {-# INLINE flowSetN #-}-flowSetN = return . setVariantN @n+flowSetN = return . toVariantAt @n  -- | Return in the first well-typed element flowSet :: (Member x xs, Monad m) => x -> Flow m xs {-# INLINE flowSet #-}-flowSet = return . setVariant+flowSet = return . toVariant  -- | Return a single element flowSingle :: Monad m => x -> Flow m '[x]@@ -293,7 +293,7 @@ -- | Extract single flow result flowRes :: Functor m => Flow m '[x] -> m x {-# INLINE flowRes #-}-flowRes = fmap singleVariant+flowRes = fmap variantToValue   -- | Lift an operation on a Variant into an operation on a flow@@ -362,7 +362,7 @@ -- | Match a value in a flow flowMatch :: forall x xs zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs {-# INLINE flowMatch #-}@@ -371,7 +371,7 @@ -- | Match a value in a flow and use a non-returning failure in this case flowMatchFail :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) {-# INLINE flowMatchFail #-} flowMatchFail = (>%~!!>)@@ -510,7 +510,7 @@    ( Monad m    ) => Variant (a ': l) -> (a -> m ()) -> Flow m (a ': l) {-# INLINE (.~=>) #-}-(.~=>) v f = case headVariant v of+(.~=>) v f = case popVariantHead v of    Right u -> f u >> return v    Left  _ -> return v @@ -530,7 +530,7 @@    ( Monad m    ) => Variant (a ': l) -> (a -> m ()) -> m () {-# INLINE (.~!>) #-}-(.~!>) v f = case headVariant v of+(.~!>) v f = case popVariantHead v of    Right u -> f u    Left  _ -> return () @@ -550,7 +550,7 @@    ( Monad m    ) => Variant (a ': l) -> (a -> m ()) -> m (Variant l) {-# INLINE (.~!!>) #-}-(.~!!>) v f = case headVariant v of+(.~!!>) v f = case popVariantHead v of    Right u -> f u >> error ".~!!> error"    Left  l -> return l @@ -836,7 +836,7 @@    ( Monad m    ) => Variant (a ': l) -> (Variant l -> a) -> m a {-# INLINE (..-.>) #-}-(..-.>) v f = case headVariant v of+(..-.>) v f = case popVariantHead v of    Right u -> return u    Left  l -> return (f l) @@ -856,7 +856,7 @@    ( Monad m    ) => Variant (a ': l) -> (Variant l -> Variant xs) -> Flow m (a ': xs) {-# INLINE (..-..>) #-}-(..-..>) v f = case headVariant v of+(..-..>) v f = case popVariantHead v of    Right u -> flowSetN @0 u    Left  l -> return (prependVariant @'[a] (f l)) @@ -876,7 +876,7 @@    ( Monad m    ) => Variant (a ': l) -> (Variant l -> Flow m xs) -> Flow m (a ': xs) {-# INLINE (..~..>) #-}-(..~..>) v f = case headVariant v of+(..~..>) v f = case popVariantHead v of    Right u -> flowSetN @0 u    Left  l -> prependVariant @'[a] <$> f l @@ -897,7 +897,7 @@    , Liftable xs (a ': zs)    ) => Variant (a ': l) -> (Variant l -> Flow m xs) -> Flow m (a ': zs) {-# INLINE (..~^^>) #-}-(..~^^>) v f = case headVariant v of+(..~^^>) v f = case popVariantHead v of    Right u -> flowSetN @0 u    Left  l -> liftVariant <$> f l @@ -919,7 +919,7 @@    , Member a zs    ) => Variant (a ': l) -> (Variant l -> Flow m zs) -> Flow m zs {-# INLINE (..~^>) #-}-(..~^>) v f = case headVariant v of+(..~^>) v f = case popVariantHead v of    Right u -> flowSet u    Left  l -> f l @@ -938,7 +938,7 @@ -- | Match in the tail, connect to the expected result (..?~^>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) ys    ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) {-# INLINE (..?~^>) #-}@@ -949,7 +949,7 @@ -- | Match in the tail, connect to the expected result (>..?~^>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) ys    ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) {-# INLINE (>..?~^>) #-}@@ -960,7 +960,7 @@ -- | Match in the tail, connect to the expected result (..%~^>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) ys    ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) {-# INLINE (..%~^>) #-}@@ -971,7 +971,7 @@ -- | Match in the tail, connect to the expected result (>..%~^>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) ys    ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) {-# INLINE (>..%~^>) #-}@@ -982,7 +982,7 @@ -- | Match in the tail, lift to the expected result (..?~^^>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) zs    , Liftable ys zs    ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)@@ -994,7 +994,7 @@ -- | Match in the tail, lift to the expected result (>..?~^^>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) zs    , Liftable ys zs    ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)@@ -1006,7 +1006,7 @@ -- | Match in the tail, lift to the expected result (..%~^^>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) zs    , Liftable ys zs    ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)@@ -1018,7 +1018,7 @@ -- | Match in the tail, lift to the expected result (>..%~^^>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) zs    , Liftable ys zs    ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)@@ -1030,11 +1030,11 @@ -- | Match in the tail, keep the same types (..?~$>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) (x ': xs)    ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) {-# INLINE (..?~$>) #-}-(..?~$>) v f = case headVariant v of+(..?~$>) v f = case popVariantHead v of    Right _ -> return v    Left xs -> xs ?~^> f @@ -1043,7 +1043,7 @@ -- | Match in the tail, keep the same types (>..?~$>) ::    ( Monad m-   , MaybeCatchable a xs+   , MaybePopable a xs    , Liftable (Filter a xs) (x ': xs)    ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) {-# INLINE (>..?~$>) #-}@@ -1054,11 +1054,11 @@ -- | Match in the tail, keep the same types (..%~$>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) (x ': xs)    ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) {-# INLINE (..%~$>) #-}-(..%~$>) v f = case headVariant v of+(..%~$>) v f = case popVariantHead v of    Right _ -> return v    Left xs -> xs %~^> f @@ -1067,7 +1067,7 @@ -- | Match in the tail, keep the same types (>..%~$>) ::    ( Monad m-   , Catchable a xs+   , Popable a xs    , Liftable (Filter a xs) (x ': xs)    ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) {-# INLINE (>..%~$>) #-}@@ -1081,7 +1081,7 @@    ( Monad m    ) => Variant (x ': xs) -> (Variant xs -> m ()) -> Flow m (x ': xs) {-# INLINE (..~=>) #-}-(..~=>) v f = case headVariant v of+(..~=>) v f = case popVariantHead v of    Right _ -> return v    Left  l -> f l >> return v @@ -1101,7 +1101,7 @@    ( Monad m    ) => Variant (x ': xs) -> (Variant xs -> m ()) -> m () {-# INLINE (..~!>) #-}-(..~!>) v f = case headVariant v of+(..~!>) v f = case popVariantHead v of    Right _ -> return ()    Left  l -> f l @@ -1121,7 +1121,7 @@    ( Monad m    ) => Variant (x ': xs) -> (Variant xs -> m ()) -> m x {-# INLINE (..~!!>) #-}-(..~!!>) v f = case headVariant v of+(..~!!>) v f = case popVariantHead v of    Right x -> return x    Left xs -> f xs >> error "..~!!> error" @@ -1139,7 +1139,7 @@ -- | Match in the tail and perform an effect (..?~!!>) ::    ( Monad m-   , MaybeCatchable y xs+   , MaybePopable y xs    ) => Variant (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) {-# INLINE (..?~!!>) #-} (..?~!!>) v f = v ..~..> (\xs -> xs ?~!!> f)@@ -1149,7 +1149,7 @@ -- | Match in the tail and perform an effect (>..?~!!>) ::    ( Monad m-   , MaybeCatchable y xs+   , MaybePopable y xs    ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) {-# INLINE (>..?~!!>) #-} (>..?~!!>) = liftm (..?~!!>)@@ -1159,7 +1159,7 @@ -- | Match in the tail and perform an effect (..%~!!>) ::    ( Monad m-   , Catchable y xs+   , Popable y xs    ) => Variant (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) {-# INLINE (..%~!!>) #-} (..%~!!>) v f = v ..~..> (\xs -> xs %~!!> f)@@ -1169,7 +1169,7 @@ -- | Match in the tail and perform an effect (>..%~!!>) ::    ( Monad m-   , Catchable y xs+   , Popable y xs    ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) {-# INLINE (>..%~!!>) #-} (>..%~!!>) = liftm (..%~!!>)@@ -1179,10 +1179,10 @@ -- | Match in the tail and perform an effect (..?~!>) ::    ( Monad m-   , MaybeCatchable y xs+   , MaybePopable y xs    ) => Variant (x ': xs) -> (y -> m ()) -> m () {-# INLINE (..?~!>) #-}-(..?~!>) v f = case headVariant v of+(..?~!>) v f = case popVariantHead v of    Right _ -> return ()    Left xs -> xs ?~!> f @@ -1191,7 +1191,7 @@ -- | Match in the tail and perform an effect (>..?~!>) ::    ( Monad m-   , MaybeCatchable y xs+   , MaybePopable y xs    ) => Flow m (x ': xs) -> (y -> m ()) -> m () {-# INLINE (>..?~!>) #-} (>..?~!>) = liftm (..?~!>)@@ -1201,10 +1201,10 @@ -- | Match in the tail and perform an effect (..%~!>) ::    ( Monad m-   , Catchable y xs+   , Popable y xs    ) => Variant (x ': xs) -> (y -> m ()) -> m () {-# INLINE (..%~!>) #-}-(..%~!>) v f = case headVariant v of+(..%~!>) v f = case popVariantHead v of    Right _ -> return ()    Left xs -> xs %~!> f @@ -1213,7 +1213,7 @@ -- | Match in the tail and perform an effect (>..%~!>) ::    ( Monad m-   , Catchable y xs+   , Popable y xs    ) => Flow m (x ': xs) -> (y -> m ()) -> m () {-# INLINE (>..%~!>) #-} (>..%~!>) = liftm (..%~!>)@@ -1224,69 +1224,69 @@ -- Caught element operations ---------------------------------------------------------- --- | Catch element, set the first value+-- | Pop element, set the first value (?~.>) :: forall x xs y ys m.    ( ys ~ Filter x xs    , Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Variant xs -> (x -> m y) -> Flow m (y ': ys) {-# INLINE (?~.>) #-}-(?~.>) v f = case catchVariantMaybe v of+(?~.>) v f = case popVariantMaybe v of    Right x -> flowSetN @0 =<< f x    Left ys -> prependVariant @'[y] <$> return ys  infixl 0 ?~.> --- | Catch element, set the first value+-- | Pop element, set the first value (>?~.>) ::    ( ys ~ Filter x xs    , Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys) {-# INLINE (>?~.>) #-} (>?~.>) = liftm (?~.>)  infixl 0 >?~.> --- | Catch element, set the first value+-- | Pop element, set the first value (%~.>) :: forall x xs y ys m.    ( ys ~ Filter x xs    , Monad m-   , Catchable x xs+   , Popable x xs    ) => Variant xs -> (x -> m y) -> Flow m (y ': ys) {-# INLINE (%~.>) #-} (%~.>) = (?~.>)  infixl 0 %~.> --- | Catch element, set the first value+-- | Pop element, set the first value (>%~.>) ::    ( ys ~ Filter x xs    , Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys) {-# INLINE (>%~.>) #-} (>%~.>) = liftm (%~.>)  infixl 0 >%~.> --- | Catch element, concat the result+-- | Pop element, concat the result (?~+>) :: forall x xs ys m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , KnownNat (Length ys)    ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) {-# INLINE (?~+>) #-}-(?~+>) v f = case catchVariantMaybe v of+(?~+>) v f = case popVariantMaybe v of    Right x -> appendVariant  @(Filter x xs) <$> f x    Left ys -> prependVariant @ys            <$> return ys  infixl 0 ?~+> --- | Catch element, concat the result+-- | Pop element, concat the result (>?~+>) :: forall x xs ys m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , KnownNat (Length ys)    ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) {-# INLINE (>?~+>) #-}@@ -1294,10 +1294,10 @@  infixl 0 >?~+> --- | Catch element, concat the result+-- | Pop element, concat the result (%~+>) :: forall x xs ys m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , KnownNat (Length ys)    ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) {-# INLINE (%~+>) #-}@@ -1305,10 +1305,10 @@  infixl 0 %~+> --- | Catch element, concat the result+-- | Pop element, concat the result (>%~+>) :: forall x xs ys m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , KnownNat (Length ys)    ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) {-# INLINE (>%~+>) #-}@@ -1316,24 +1316,24 @@  infixl 0 >%~+> --- | Catch element, lift the result+-- | Pop element, lift the result (?~^^>) :: forall x xs ys zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    ) => Variant xs -> (x -> Flow m ys) -> Flow m zs {-# INLINE (?~^^>) #-}-(?~^^>) v f = case catchVariantMaybe v of+(?~^^>) v f = case popVariantMaybe v of    Right x -> liftVariant <$> f x    Left ys -> liftVariant <$> return ys  infixl 0 ?~^^> --- | Catch element, lift the result+-- | Pop element, lift the result (>?~^^>) :: forall x xs ys zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs@@ -1342,10 +1342,10 @@  infixl 0 >?~^^> --- | Catch element, lift the result+-- | Pop element, lift the result (%~^^>) :: forall x xs ys zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    ) => Variant xs -> (x -> Flow m ys) -> Flow m zs@@ -1354,10 +1354,10 @@  infixl 0 %~^^> --- | Catch element, lift the result+-- | Pop element, lift the result (>%~^^>) :: forall x xs ys zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs@@ -1366,23 +1366,23 @@  infixl 0 >%~^^> --- | Catch element, connect to the expected output+-- | Pop element, connect to the expected output (?~^>) :: forall x xs zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    ) => Variant xs -> (x -> Flow m zs) -> Flow m zs {-# INLINE (?~^>) #-}-(?~^>) v f = case catchVariantMaybe v of+(?~^>) v f = case popVariantMaybe v of    Right x -> f x    Left ys -> return (liftVariant ys)  infixl 0 ?~^> --- | Catch element, connect to the expected output+-- | Pop element, connect to the expected output (>?~^>) :: forall x xs zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs {-# INLINE (>?~^>) #-}@@ -1390,10 +1390,10 @@  infixl 0 >?~^> --- | Catch element, connect to the expected output+-- | Pop element, connect to the expected output (%~^>) :: forall x xs zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    ) => Variant xs -> (x -> Flow m zs) -> Flow m zs {-# INLINE (%~^>) #-}@@ -1401,10 +1401,10 @@  infixl 0 %~^> --- | Catch element, connect to the expected output+-- | Pop element, connect to the expected output (>%~^>) :: forall x xs zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs {-# INLINE (>%~^>) #-}@@ -1412,67 +1412,67 @@  infixl 0 >%~^> --- | Catch element, use the same output type+-- | Pop element, use the same output type (?~$>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Variant xs -> (x -> Flow m xs) -> Flow m xs {-# INLINE (?~$>) #-}-(?~$>) v f = case catchVariantMaybe v of+(?~$>) v f = case popVariantMaybe v of    Right x -> f x    Left _  -> return v  infixl 0 ?~$> --- | Catch element, use the same output type+-- | Pop element, use the same output type (>?~$>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs {-# INLINE (>?~$>) #-} (>?~$>) = liftm (?~$>)  infixl 0 >?~$> --- | Catch element, use the same output type+-- | Pop element, use the same output type (%~$>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Variant xs -> (x -> Flow m xs) -> Flow m xs {-# INLINE (%~$>) #-} (%~$>) = (?~$>)  infixl 0 %~$> --- | Catch element, use the same output type+-- | Pop element, use the same output type (>%~$>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs {-# INLINE (>%~$>) #-} (>%~$>) = liftm (%~$>)  infixl 0 >%~$> --- | Catch element, fusion the result+-- | Pop element, fusion the result (?~|>) :: forall x xs ys zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    , zs ~ Union (Filter x xs) ys    ) => Variant xs -> (x -> Flow m ys) -> Flow m zs {-# INLINE (?~|>) #-}-(?~|>) v f = case catchVariantMaybe v of+(?~|>) v f = case popVariantMaybe v of    Right x -> liftVariant <$> f x    Left ys -> return (liftVariant ys)  infixl 0 ?~|> --- | Catch element, fusion the result+-- | Pop element, fusion the result (>?~|>) :: forall x xs ys zs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    , zs ~ Union (Filter x xs) ys@@ -1482,10 +1482,10 @@  infixl 0 >?~|> --- | Catch element, fusion the result+-- | Pop element, fusion the result (%~|>) :: forall x xs ys zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    , zs ~ Union (Filter x xs) ys@@ -1495,10 +1495,10 @@  infixl 0 %~|> --- | Catch element, fusion the result+-- | Pop element, fusion the result (>%~|>) :: forall x xs ys zs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    , Liftable (Filter x xs) zs    , Liftable ys zs    , zs ~ Union (Filter x xs) ys@@ -1508,126 +1508,126 @@  infixl 0 >%~|> --- | Catch element and perform effect. Passthrough the input value.+-- | Pop element and perform effect. Passthrough the input value. (?~=>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Variant xs -> (x -> m ()) -> Flow m xs {-# INLINE (?~=>) #-}-(?~=>) v f = case catchVariantMaybe v of+(?~=>) v f = case popVariantMaybe v of    Right x -> f x >> return v    Left _  -> return v  infixl 0 ?~=> --- | Catch element and perform effect. Passthrough the input value.+-- | Pop element and perform effect. Passthrough the input value. (>?~=>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Flow m xs -> (x -> m ()) -> Flow m xs {-# INLINE (>?~=>) #-} (>?~=>) = liftm (?~=>)  infixl 0 >?~=> --- | Catch element and perform effect. Passthrough the input value.+-- | Pop element and perform effect. Passthrough the input value. (%~=>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Variant xs -> (x -> m ()) -> Flow m xs {-# INLINE (%~=>) #-} (%~=>) = (?~=>)  infixl 0 %~=> --- | Catch element and perform effect. Passthrough the input value.+-- | Pop element and perform effect. Passthrough the input value. (>%~=>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> m ()) -> Flow m xs {-# INLINE (>%~=>) #-} (>%~=>) = liftm (%~=>)  infixl 0 >%~=> --- | Catch element and perform effect.+-- | Pop element and perform effect. (?~!>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Variant xs -> (x -> m ()) -> m () {-# INLINE (?~!>) #-}-(?~!>) v f = case catchVariantMaybe v of+(?~!>) v f = case popVariantMaybe v of    Right x -> f x    Left _  -> return ()  infixl 0 ?~!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (>?~!>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Flow m xs -> (x -> m ()) -> m () {-# INLINE (>?~!>) #-} (>?~!>) = liftm (?~!>)  infixl 0 >?~!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (%~!>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Variant xs -> (x -> m ()) -> m () {-# INLINE (%~!>) #-} (%~!>) = (?~!>)  infixl 0 %~!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (>%~!>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> m ()) -> m () {-# INLINE (>%~!>) #-} (>%~!>) = liftm (%~!>)  infixl 0 >%~!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (?~!!>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs) {-# INLINE (?~!!>) #-}-(?~!!>) v f = case catchVariantMaybe v of+(?~!!>) v f = case popVariantMaybe v of    Right x -> f x >> error "?~!!> error"    Left u  -> return u  infixl 0 ?~!!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (>?~!!>) :: forall x xs m.    ( Monad m-   , MaybeCatchable x xs+   , MaybePopable x xs    ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) {-# INLINE (>?~!!>) #-} (>?~!!>) = liftm (?~!!>)  infixl 0 >?~!!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (%~!!>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs) {-# INLINE (%~!!>) #-} (%~!!>) = (?~!!>)  infixl 0 %~!!> --- | Catch element and perform effect.+-- | Pop element and perform effect. (>%~!!>) :: forall x xs m.    ( Monad m-   , Catchable x xs+   , Popable x xs    ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) {-# INLINE (>%~!!>) #-} (>%~!!>) = liftm (%~!!>)@@ -1661,7 +1661,7 @@ -- | Select the first value selectFirst :: Variant (x ': xs) -> Either (Variant xs) (Variant '[x]) {-# INLINE selectFirst #-}-selectFirst = fmap (setVariantN @0) . headVariant+selectFirst = fmap (toVariantAt @0) . popVariantHead  -- | Select the tail selectTail :: Variant (x ': xs) -> Either (Variant '[x]) (Variant xs)@@ -1673,10 +1673,10 @@  -- | Select by type selectType ::-   ( Catchable x xs+   ( Popable x xs    ) => Variant xs -> Either (Variant (Filter x xs)) (Variant '[x]) {-# INLINE selectType #-}-selectType = fmap (setVariantN @0) . catchVariant+selectType = fmap (toVariantAt @0) . popVariant  -- | Const application applyConst :: Flow m ys -> (Variant xs -> Flow m ys)@@ -1696,12 +1696,12 @@ -- | Lift a monadic function applyVM :: Monad m => (Variant a -> m b) -> Variant a -> Flow m '[b] {-# INLINE applyVM #-}-applyVM f = fmap (setVariantN @0) . f+applyVM f = fmap (toVariantAt @0) . f  -- | Lift a monadic function applyF :: (a -> Flow m b) -> Variant '[a] -> Flow m b {-# INLINE applyF #-}-applyF f = f . singleVariant+applyF f = f . variantToValue  -- | Set the first value (the "correct" one) combineFirst :: forall x xs. Either (Variant xs) (Variant '[x]) -> Variant (x ': xs)@@ -1767,14 +1767,14 @@ combineSingle :: Either (Variant '[x]) (Variant '[x]) -> x {-# INLINE combineSingle #-} combineSingle = \case-   Right x -> singleVariant x-   Left  x -> singleVariant x+   Right x -> variantToValue x+   Left  x -> variantToValue x   -- | Lift a pure function into a Variant to Variant function liftV :: (a -> b) -> Variant '[a] -> Variant '[b]-liftV = updateVariantN @0+liftV = updateVariantAt @0  -- | Lift a function into a Flow liftF :: Monad m => (a -> m b) -> Variant '[a] -> Flow m '[b]-liftF = updateVariantM @0+liftF = updateVariantFirstM @0

@@ -1,10 +1,12 @@ module Haskus.Utils.List    ( checkLength    , module Data.List+   , module Data.List.Extra    ) where  import Data.List+import Data.List.Extra  -- | Check that a list has the given length (support infinite lists) checkLength :: Word -> [a] -> Bool

@@ -0,0 +1,7 @@+module Haskus.Utils.Map.Strict+   ( module Data.Map.Strict+   )+where++import Data.Map.Strict+

@@ -5,6 +5,7 @@    ( onNothing    , onNothingM    , fromMaybeM+   , headMaybe    , module Data.Maybe    ) where@@ -24,4 +25,8 @@ fromMaybeM v f = f >>= \case    Nothing -> v    Just x  -> return x-   ++-- | Get the head of the list if the latter is not empty+headMaybe :: [a] -> Maybe a+headMaybe []    = Nothing+headMaybe (x:_) = Just x

@@ -54,7 +54,7 @@       ( x ~ Flow m xs       , y ~ Flow m ys       , z ~ Flow m zs-      , Catchable a xs+      , Popable a xs       , Liftable ys zs       , Liftable (Filter a xs) zs       , zs ~ Union (Filter a xs) ys@@ -86,7 +86,7 @@ many ::    ( zs ~ Filter ParseError xs    , Monad m-   , Catchable ParseError xs+   , Popable ParseError xs    ) => Flow m xs -> Flow m '[[Variant zs]] many f = manyBounded Nothing Nothing f             >%~^> \(_ :: ParseError) -> flowSingle []@@ -96,7 +96,7 @@ manyAtMost ::    ( zs ~ Filter ParseError xs    , Monad m-   , Catchable ParseError xs+   , Popable ParseError xs    ) => Word -> Flow m xs -> Flow m '[[Variant zs]] manyAtMost max f = manyBounded Nothing (Just max) f                      >%~^> \(_ :: ParseError) -> flowSingle []@@ -106,25 +106,25 @@ manyAtMost' ::    ( zs ~ Filter ParseError xs    , Monad m-   , Catchable ParseError xs+   , Popable ParseError xs    ) => Word -> Flow m xs -> m [Variant zs]-manyAtMost' max f = singleVariant <$> manyAtMost max f+manyAtMost' max f = variantToValue <$> manyAtMost max f  -- | Apply the action zero or more times (up to max) until a ParseError result -- is returned manyAtMost'' ::    ( '[x] ~ Filter ParseError xs    , Monad m-   , Catchable ParseError xs+   , Popable ParseError xs    ) => Word -> Flow m xs -> m [x]-manyAtMost'' max f = fmap singleVariant <$> manyAtMost' max f+manyAtMost'' max f = fmap variantToValue <$> manyAtMost' max f  -- | Apply the action at least n times or more times (until a ParseError -- result is returned) manyAtLeast ::    ( zs ~ Filter ParseError xs    , Monad m-   , Catchable ParseError xs+   , Popable ParseError xs    ) => Word -> Flow m xs -> Flow m '[[Variant zs],ParseError] manyAtLeast min = manyBounded (Just min) Nothing @@ -136,18 +136,18 @@    ( zs ~ Filter ParseError xs    , zs' ~ Filter ParseError ys    , Monad m-   , MaybeCatchable ParseError xs-   , Catchable ParseError ys+   , MaybePopable ParseError xs+   , Popable ParseError ys    ) => Flow m xs -> Flow m ys -> Flow m '[([Variant zs],Variant zs'),ParseError] manyTill f g = go []    where       go xs = do          v <- g-         case catchVariant v of+         case popVariant v of             Right EndOfInput  -> flowSet EndOfInput             Right SyntaxError -> do                u <- f-               case catchVariantMaybe u of+               case popVariantMaybe u of                   Right (e :: ParseError) -> flowSet e                   Left x                  -> go (x:xs)             Left x            -> flowSet (reverse xs,x)@@ -159,8 +159,8 @@ manyTill' ::    ( zs ~ Filter ParseError xs    , Monad m-   , MaybeCatchable ParseError xs-   , Catchable ParseError ys+   , MaybePopable ParseError xs+   , Popable ParseError ys    ) => Flow m xs -> Flow m ys -> Flow m '[[Variant zs],ParseError] manyTill' f g = manyTill f g >.-.> fst @@ -170,20 +170,20 @@ manyBounded :: forall zs xs m.    ( zs ~ Filter ParseError xs    , Monad m-   , MaybeCatchable ParseError xs+   , MaybePopable ParseError xs    ) => Maybe Word -> Maybe Word -> Flow m xs -> Flow m '[[Variant zs],ParseError] manyBounded _ (Just 0) _   = flowSet ([] :: [Variant zs]) manyBounded (Just 0) max f = manyBounded Nothing max f manyBounded min max f      = do    v <- f-   case catchVariantMaybe v of+   case popVariantMaybe v of       Right (e :: ParseError) -> case min of          Just n | n > 0 -> flowSet e          _              -> flowSet ([] :: [Variant zs])       Left x           -> do          let minus1 = fmap (\k -> k - 1)          xs <- manyBounded (minus1 min) (minus1 max) f-         case toEither xs of+         case variantToEither xs of             Left (e :: ParseError) -> flowSet e             Right xs'              -> flowSet (x : xs') 

@@ -0,0 +1,555 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf #-}++-- | Simple Constraint solver+module Haskus.Utils.Solver+   (+   -- * Oracle+     PredState (..)+   , PredOracle+   , makeOracle+   , oraclePredicates+   , emptyOracle+   , predIsSet+   , predIsUnset+   , predIsUndef+   , predIs+   , predState+   -- * Constraint+   , Constraint (..)+   , simplifyConstraint+   , constraintReduce+   -- * Rule+   , Rule (..)+   , orderedNonTerminal+   , mergeRules+   , evalsTo+   , MatchResult (..)+   -- * Predicated data+   , Predicated (..)+   , createPredicateTable+   , initP+   , applyP+   , resultP+   )+where++import Haskus.Utils.Maybe+import Haskus.Utils.Flow+import Haskus.Utils.List+import Haskus.Utils.Map.Strict (Map)+import qualified Haskus.Utils.Map.Strict as Map++import Data.Bits+import Control.Arrow (first,second)++import Prelude hiding (pred)++-------------------------------------------------------+-- Constraint+-------------------------------------------------------++-- | Predicate state+data PredState+   = SetPred       -- ^ Set predicate+   | UnsetPred     -- ^ Unset predicate+   | UndefPred     -- ^ Undefined predicate+   deriving (Show,Eq,Ord)++-- | Predicate oracle+type PredOracle p = Map p PredState++-- | Ask an oracle if a predicate is set+predIsSet :: Ord p => PredOracle p -> p -> Bool+predIsSet oracle p = predIs oracle p SetPred++-- | Ask an oracle if a predicate is unset+predIsUnset :: Ord p => PredOracle p -> p -> Bool+predIsUnset oracle p = predIs oracle p UnsetPred++-- | Ask an oracle if a predicate is undefined+predIsUndef :: Ord p => PredOracle p -> p -> Bool+predIsUndef oracle p = predIs oracle p UndefPred++-- | Check the state of a predicate+predIs :: Ord p => PredOracle p -> p -> PredState -> Bool+predIs oracle p s = predState oracle p == s++-- | Get predicate state+predState :: Ord p => PredOracle p -> p -> PredState+predState oracle p = case p `Map.lookup` oracle of+   Just s  -> s+   Nothing -> UndefPred++-- | Create an oracle from a list+makeOracle :: Ord p => [(p,PredState)] -> PredOracle p+makeOracle = Map.fromList++-- | Get a list of predicates from an oracle+oraclePredicates :: Ord p => PredOracle p -> [(p,PredState)]+oraclePredicates = filter (\(_,s) -> s /= UndefPred) . Map.toList++-- | Oracle that always answer Undef+emptyOracle :: PredOracle p+emptyOracle = Map.empty++-------------------------------------------------------+-- Constraint+-------------------------------------------------------++data Constraint e p+   = Predicate p+   | Not (Constraint e p)+   | And [Constraint e p]+   | Or  [Constraint e p]+   | Xor [Constraint e p]+   | CBool Bool+   deriving (Show,Eq,Ord)++instance Functor (Constraint e) where+   fmap f (Predicate p)  = Predicate (f p)+   fmap _ (CBool b)      = CBool b+   fmap f (Not c)        = Not (fmap f c)+   fmap f (And cs)       = And (fmap (fmap f) cs)+   fmap f (Or cs)        = Or (fmap (fmap f) cs)+   fmap f (Xor cs)       = Xor (fmap (fmap f) cs)++-- | Reduce a constraint+constraintReduce :: (Ord p, Eq p, Eq e) => PredOracle p -> Constraint e p -> Constraint e p+constraintReduce oracle c = case simplifyConstraint c of+   Predicate p  -> case predState oracle p of+                      UndefPred -> Predicate p+                      SetPred   -> CBool True+                      UnsetPred -> CBool False+   Not c'       -> case constraintReduce oracle c' of+                      CBool v -> CBool (not v)+                      c''     -> Not c''+   And cs       -> case fmap (constraintReduce oracle) cs of+                      []                                     -> error "Empty And constraint"+                      cs' | all (constraintIsBool True)  cs' -> CBool True+                      cs' | any (constraintIsBool False) cs' -> CBool False+                      cs' -> case filter (not . constraintIsBool True) cs' of+                        [c'] -> c'+                        cs'' -> And cs''+   Or cs        -> case fmap (constraintReduce oracle) cs of+                      []                                      -> error "Empty Or constraint"+                      cs' | all (constraintIsBool False)  cs' -> CBool False+                      cs' | any (constraintIsBool True)   cs' -> CBool True+                      cs' -> case filter (not . constraintIsBool False) cs' of+                        [c'] -> c'+                        cs'' -> Or cs''+   Xor cs       -> case fmap (constraintReduce oracle) cs of+                      []  -> error "Empty Xor constraint"+                      cs' -> simplifyConstraint (Xor cs')+   c'@(CBool _) -> c'++-- | Check that a constraint is evaluated to a given boolean value+constraintIsBool :: Bool -> Constraint e p -> Bool+constraintIsBool v (CBool v') = v == v'+constraintIsBool _ _          = False++-- | Get predicates used in a constraint+getConstraintPredicates :: Constraint e p -> [p]+getConstraintPredicates = \case+   Predicate p  -> [p]+   Not c        -> getConstraintPredicates c+   And cs       -> concatMap getConstraintPredicates cs+   Or  cs       -> concatMap getConstraintPredicates cs+   Xor cs       -> concatMap getConstraintPredicates cs+   CBool _      -> []++-- | Get constraint terminals+getConstraintTerminals :: Constraint e p -> [Bool]+getConstraintTerminals = \case+   Predicate _  -> [True,False]+   CBool v      -> [v]+   Not c        -> fmap not (getConstraintTerminals c)+   And cs       -> let cs' = fmap getConstraintTerminals cs+                   in if | null cs                -> []+                         | any (False `elem`) cs' -> [False]+                         | all (sing True)    cs' -> [True]+                         | otherwise              -> [True,False]+   Or  cs       -> let cs' = fmap getConstraintTerminals cs+                   in if | null cs                -> []+                         | any (True `elem`) cs'  -> [True]+                         | all (sing False)   cs' -> [False]+                         | otherwise              -> [True,False]+   Xor cs       -> let cs' = fmap getConstraintTerminals cs+                   in if | null cs                -> []+                         | otherwise              -> xo False cs'+   where+      xo t     []           = [t]+      xo False ([True]:xs)  = xo True xs+      xo True  ([True]:_)   = [False]+      xo False ([False]:xs) = xo False xs+      xo True  ([False]:xs) = xo True xs+      xo _     ([]:_)       = []+      xo _     _            = [True,False]++      sing v [v'] = v == v'+      sing _ _    = False+++-------------------------------------------------------+-- Rule+-------------------------------------------------------++data Rule e p a+   = Terminal a+   | NonTerminal [(Constraint e p, Rule e p a)]+   | Fail e+   deriving (Show,Eq,Ord)++instance Functor (Rule e p) where+   fmap f (Terminal a)     = Terminal (f a)+   fmap f (NonTerminal xs) = NonTerminal (fmap (second (fmap f)) xs)+   fmap _ (Fail e)         = Fail e+++-- | NonTerminal whose constraints are evaluated in order+--+-- Earlier constraints must be proven false for the next ones to be considered+orderedNonTerminal :: [(Constraint e p, Rule e p a)] -> Rule e p a+orderedNonTerminal = NonTerminal . go []+   where+      go _  []          = []+      go [] ((c,r):xs)  = (simplifyConstraint c,r) : go [c] xs+      go cs ((c,r):xs)  = (simplifyConstraint (And (c:fmap Not cs)),r) : go (c:cs) xs++-- | Simplify a constraint+simplifyConstraint :: Constraint e p -> Constraint e p+simplifyConstraint x = case x of+   Predicate _       -> x+   CBool _           -> x+   Not (Predicate _) -> x+   Not (CBool v)     -> CBool (not v)+   Not (Not c)       -> simplifyConstraint c+   Not (Or cs)       -> simplifyConstraint (And (fmap Not cs))+   Not (And cs)      -> simplifyConstraint (Or (fmap Not cs))+   Not (Xor cs)      -> case simplifyConstraint (Xor cs) of+                           Xor cs' -> Not (Xor cs')+                           r       -> simplifyConstraint (Not r)+   And [c]           -> simplifyConstraint c+   Or  [c]           -> simplifyConstraint c+   Xor [c]           -> let c' = simplifyConstraint c+                        in if | constraintIsBool True c'  -> CBool True+                              | constraintIsBool False c' -> CBool False+                              | otherwise                 -> c'+   And cs            -> let cs' = fmap simplifyConstraint cs+                        in if | any (constraintIsBool False) cs' -> CBool False+                              | all (constraintIsBool True)  cs' -> CBool True+                              | otherwise                        -> And cs'+   Or cs             -> let cs' = fmap simplifyConstraint cs+                        in if | any (constraintIsBool True) cs'  -> CBool True+                              | all (constraintIsBool False) cs' -> CBool False+                              | otherwise                        -> Or cs'+   Xor cs            -> let cs'        = fmap simplifyConstraint cs+                            countTrue  = length (filter (constraintIsBool True) cs')+                            countFalse = length (filter (constraintIsBool False) cs')+                            countAll   = length cs'+                        in if | countTrue > 1                                        -> CBool False+                              | countTrue == 1 && countTrue + countFalse == countAll -> CBool True+                              | countAll == countFalse                               -> CBool False+                              | otherwise                                            -> Xor cs'++-- | Merge two rules together+mergeRules :: Rule e p a -> Rule e p b -> Rule e p (a,b)+mergeRules = go+   where+      go (Fail e)           _                = Fail e+      go _                  (Fail e)         = Fail e+      go (Terminal a)       (Terminal b)     = Terminal (a,b)+      go (Terminal a)       (NonTerminal bs) = NonTerminal (fl (Terminal a) bs)+      go (NonTerminal as)   (Terminal b)     = NonTerminal (fr (Terminal b) as)+      go (NonTerminal as)   b                = NonTerminal (fr b            as)++      fl x = fmap (second (x `mergeRules`))+      fr x = fmap (second (`mergeRules` x))+++-- | Reduce a rule+ruleReduce :: forall e p a.+   ( Ord p, Eq e, Eq p, Eq a) => PredOracle p -> Rule e p a -> MatchResult e (Rule e p a) a+ruleReduce oracle r = case r of+   Terminal a     -> Match a+   Fail e         -> MatchFail [e]+   NonTerminal rs -> +      let+         rs' :: [(Constraint e p, Rule e p a)]+         rs' = rs+               -- reduce constraints+               |> fmap (first (constraintReduce oracle))+               -- filter non matching rules+               |> filter (not . constraintIsBool False . fst)++         (matchingRules,mayMatchRules) = partition (constraintIsBool True . fst) rs'+         matchingResults               = nub $ fmap snd $ matchingRules+++         (failingResults,terminalResults,nonTerminalResults) = go [] [] [] matchingResults+         go fr tr ntr = \case+            []                 -> (fr,tr,ntr)+            (Fail x:xs)        -> go (x:fr) tr ntr xs+            (Terminal x:xs)    -> go fr (x:tr) ntr xs+            (NonTerminal x:xs) -> go fr tr (x:ntr) xs++         divergence = case terminalResults of+            -- results are already "nub"ed.+            -- More than 1 results => divergence+            (_:_:_) -> True+            _       -> False+      in+      case rs' of+         []                                 -> NoMatch+         _  | not (null failingResults)     -> MatchFail failingResults+            | divergence                    -> MatchDiverge (fmap Terminal terminalResults)+            | not (null nonTerminalResults) ->+               -- fold matching nested NonTerminals+               ruleReduce oracle+                  <| NonTerminal +                  <| (fmap (\x -> (CBool True, Terminal x)) terminalResults+                      ++ mayMatchRules+                      ++ concat nonTerminalResults)++            | otherwise                     ->+               case (matchingResults,mayMatchRules) of+                  ([Terminal a], [])    -> Match a+                  _                     -> DontMatch (NonTerminal rs')+++-- | Get possible resulting terminals+getRuleTerminals :: Rule e p a -> [a]+getRuleTerminals (Fail _)         = []+getRuleTerminals (Terminal a)     = [a]+getRuleTerminals (NonTerminal xs) = concatMap (getRuleTerminals . snd) xs++-- | Get predicates used in a rule+getRulePredicates :: Eq p => Rule e p a -> [p]+getRulePredicates (Fail _)         = []+getRulePredicates (Terminal _)     = []+getRulePredicates (NonTerminal xs) = nub $ concatMap (\(x,y) -> getConstraintPredicates x ++ getRulePredicates y) xs++-- | Constraint checking that a predicated value evaluates to some terminal+evalsTo :: (Ord (Pred a), Eq a, Eq (PredTerm a), Eq (Pred a), Predicated a) => a -> PredTerm a -> Constraint e (Pred a)+evalsTo s a = case createPredicateTable s (const True) True of+   Left x   -> CBool (x == a)+   Right xs -> orConstraints <| fmap andPredicates+                             <| fmap oraclePredicates+                             <| fmap fst+                             <| filter ((== a) . snd)+                             <| xs+   where++      andPredicates []  = CBool True+      andPredicates [x] = makePred x+      andPredicates xs  = And (fmap makePred xs)++      orConstraints []  = CBool True+      orConstraints [x] = x+      orConstraints xs  = Or xs++      makePred (p, UnsetPred) = Not (Predicate p)+      makePred (p, SetPred)   = Predicate p+      makePred (_, UndefPred) = undefined -- shouldn't be possible given we use+                                          -- get the predicates from the oracle itself+++-------------------------------------------------------+-- Predicated data+-------------------------------------------------------++++-- | Predicated data+--+-- @+-- data T+-- data NT+-- +-- type family RuleT e p a s :: * where+--    RuleT e p a T   = a+--    RuleT e p a NT  = Rule e p a+--+-- data PD t = PD+--    { p1 :: RuleT () Bool Int t+--    , p2 :: RuleT () Bool String t+--    }+--+-- deriving instance Eq (PD T)+-- deriving instance Show (PD T)+-- deriving instance Ord (PD T)+-- deriving instance Eq (PD NT)+-- deriving instance Show (PD NT)+-- deriving instance Ord (PD NT)+--+-- +-- instance Predicated (PD NT) where+--    type PredErr (PD NT)  = ()+--    type Pred (PD NT)     = Bool+--    type PredTerm (PD NT) = PD T+-- +--    liftTerminal (PD a b) = PD (liftTerminal a) (liftTerminal b)+-- +--    reducePredicates oracle (PD a b) =+--       initP PD PD+--          |> (`applyP` reducePredicates oracle a)+--          |> (`applyP` reducePredicates oracle b)+--          |> resultP+--+--    getTerminals (PD as bs) = [ PD a b | a <- getTerminals as+--                                       , b <- getTerminals bs+--                              ]+--   +--    getPredicates (PD a b) = concat+--                               [ getPredicates a+--                               , getPredicates b+--                               ]+-- @+class Predicated a where+   -- | Error type+   type PredErr a :: *++   -- | Predicate type+   type Pred a    :: *++   -- | Terminal type+   type PredTerm a    :: *++   -- | Build a non terminal from a terminal+   liftTerminal :: PredTerm a -> a++   -- | Reduce predicates+   reducePredicates :: PredOracle (Pred a) -> a -> MatchResult (PredErr a) a (PredTerm a)++   -- | Get possible resulting terminals+   getTerminals :: a -> [PredTerm a]++   -- | Get used predicates+   getPredicates :: a -> [Pred a]+++instance (Ord p, Eq e, Eq a, Eq p) => Predicated (Rule e p a) where+   type PredErr  (Rule e p a) = e+   type Pred     (Rule e p a) = p+   type PredTerm (Rule e p a) = a++   reducePredicates = ruleReduce+   liftTerminal     = Terminal+   getTerminals     = getRuleTerminals+   getPredicates    = getRulePredicates++instance (Ord p, Eq e, Eq p) => Predicated (Constraint e p) where+   type PredErr  (Constraint e p) = e+   type Pred     (Constraint e p) = p+   type PredTerm (Constraint e p) = Bool++   reducePredicates oracle c = case constraintReduce oracle c of+      CBool v -> Match v+      c'      -> DontMatch c'++   liftTerminal     = CBool+   getTerminals     = getConstraintTerminals+   getPredicates    = getConstraintPredicates+++-- | Reduction result+data MatchResult e nt t+   = NoMatch+   | Match t+   | DontMatch nt+   | MatchFail [e]+   | MatchDiverge [nt]+   deriving (Show,Eq,Ord)++instance Functor (MatchResult e nt) where+   fmap f x = case x of+      NoMatch         -> NoMatch+      MatchDiverge xs -> MatchDiverge xs+      MatchFail es    -> MatchFail es+      Match a         -> Match (f a)+      DontMatch a     -> DontMatch a++-- | Compose reduction results+--+-- We reuse the MatchResult data type:+--    * a "terminal" on the left can be used to build either a terminal or a non terminal+--    * a "non terminal" on the left can only be used to build a non terminal+applyP ::+   ( Predicated ntb+   ) => MatchResult e (ntb -> nt) (ntb -> nt, PredTerm ntb -> t) -> MatchResult e ntb (PredTerm ntb) -> MatchResult e nt (nt,t)+applyP NoMatch            _                 = NoMatch+applyP _                  NoMatch           = NoMatch++applyP (MatchFail xs)     (MatchFail ys)    = MatchFail (xs++ys)+applyP (MatchFail xs)     _                 = MatchFail xs+applyP _                  (MatchFail ys)    = MatchFail ys++applyP (MatchDiverge fs)  (MatchDiverge ys) = MatchDiverge [f y | f <- fs, y <- ys]+applyP (MatchDiverge fs)  (Match b)         = MatchDiverge [f (liftTerminal b) | f <- fs]+applyP (MatchDiverge fs)  (DontMatch b)     = MatchDiverge [f b | f <- fs]++applyP (DontMatch f)      (MatchDiverge ys) = MatchDiverge [f y | y <- ys]+applyP (DontMatch f)      (DontMatch b)     = DontMatch    (f b)+applyP (DontMatch f)      (Match b)         = DontMatch    (f (liftTerminal b))++applyP (Match (fnt,_))    (MatchDiverge ys) = MatchDiverge [fnt y | y <- ys]+applyP (Match (fnt,_))    (DontMatch b)     = DontMatch    (fnt b)+applyP (Match (fnt,ft))   (Match b)         = Match        (fnt (liftTerminal b), ft b)++-- | Initialise a reduction result (typically with two functions/constructors)+initP :: nt -> t -> MatchResult e nt (nt,t)+initP nt t = Match (nt,t)++-- | Fixup result (see initP and applyP)+resultP :: MatchResult e nt (nt,t) -> MatchResult e nt t+resultP = fmap snd++-- | Create a table of predicates that return a terminal+createPredicateTable ::+   ( Ord (Pred a)+   , Eq (Pred a)+   , Eq a+   , Predicated a+   , Predicated a+   , Pred a ~ Pred a+   ) => a -> (PredOracle (Pred a) -> Bool) -> Bool -> Either (PredTerm a) [(PredOracle (Pred a),PredTerm a)]+createPredicateTable s oracleChecker fullTable =+   -- we first check if the predicated value reduces to a terminal without any+   -- additional oracle+   case reducePredicates emptyOracle s of+      Match x -> Left x+      _       -> Right (mapMaybe matching oracles)+   where+      matching oracle = case reducePredicates oracle s of+         Match x -> Just (oracle,x)+         _       -> Nothing++      oracles = filter oracleChecker (fmap makeOracle predSets)++      preds        = sort (getPredicates s)++      predSets+         | fullTable = makeFullSets preds+         | otherwise = makeSets     preds [] ++      makeFullSets ps  = fmap (makeFullSet ps) ([0..2^(length ps)-1] :: [Word])+      makeFullSet ps n = fmap (setB n) (ps `zip` [0..])+      setB n (p,i)     = if testBit n i+         then (p,SetPred)+         else (p,UnsetPred)++      makeSets []     os  = os+      makeSets (p:ps) os = let ns = [(p,SetPred),(p,UnsetPred)]+                           in makeSets ps $ concat+                                 [ [ [n] | n <- ns ]+                                 , [(n:o) | o <- os, n <- ns]+                                 , os+                                 ]+++

@@ -8,7 +8,8 @@  -- | Tuple helpers module Haskus.Utils.Tuple-   ( uncurry4+   ( uncurry3+   , uncurry4    , take4    , fromTuple4    , module Data.Tuple@@ -25,6 +26,11 @@  import Data.Tuple import Haskus.Utils.Types++-- | Uncurry specialised for triple+uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e+{-# INLINE uncurry3 #-}+uncurry3 f (a,b,c) = f a b c  -- | Uncurry specialised for quadruple uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e

@@ -5,6 +5,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}  -- | Common type functions module Haskus.Utils.Types@@ -23,8 +24,8 @@    , type (-)    , type (*)    , type (^)+   , Assert    , If-   , IfNat    , Modulo    , Same    , Proxy (..)@@ -52,14 +53,30 @@ symbolValue = symbolVal (Proxy :: Proxy s)  -- | If-then-else-type family If c t e where+type family If (c :: Bool) (t :: k) (e :: k) where    If 'True  t e = t    If 'False t e = e --- | If-then-else-type family IfNat c (t :: Nat) (e :: Nat) where-   IfNat 'True  t e = t-   IfNat 'False t e = e++-- | Like: If cond t (TypeError msg)+--+-- The difference is that the TypeError doesn't appear in the RHS of the type+-- which lead to better error messages (see GHC #14771).+--+-- For instance:+--    type family F n where+--       F n = If (n <=? 8) Int8 (TypeError (Text "ERROR"))+--+--    type family G n where+--       G n = Assert (n <=? 8) Int8 (Text "ERROR")+--+--    If GHC cannot solve `F n ~ Word`, it shows: ERROR+--    If GHC cannot solve `G n ~ Word`, it shows:+--       can't match `Assert...` with `Word`+--+type family Assert (prop :: Bool) (val :: k) (msg :: ErrorMessage) where+   Assert 'True  val msg = val+   Assert 'False val msg = TypeError msg  -- | Modulo type family Modulo (a :: Nat) (b :: Nat) where

@@ -6,10 +6,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}  -- | Utils for type lists module Haskus.Utils.Types.List-   ( MapNat+   ( Map    , Max    , Tail    , Drop@@ -17,12 +18,15 @@    , Init    , Head    , Snoc+   , InsertAt    , ReplaceAt    , Replace    , ReplaceN+   , ReplaceNS    , Reverse    , RemoveAt    , RemoveAt1+   , RemoveAtN    , Concat    , Length    , Replicate@@ -37,6 +41,7 @@    , Nub    , NubHead    , IndexOf+   , IndexesOf    , MaybeIndexOf    , Index    , Union@@ -47,10 +52,10 @@  import Haskus.Utils.Types --- | Map a type function returning a Nat-type family MapNat (f :: * -> Nat) (xs :: [*]) where-   MapNat f '[]       = '[]-   MapNat f (x ': xs) = f x ': MapNat f xs+-- | Map a type function+type family Map (f :: a -> k) (xs :: [a]) where+   Map f '[]       = '[]+   Map f (x ': xs) = f x ': Map f xs  -- | Get the max of a list of Nats type family Max (xs :: [Nat]) where@@ -59,7 +64,7 @@ -- | Helper for Max type family Max' (x :: Nat) (xs :: [Nat]) where    Max' x '[]       = x-   Max' x (a ': xs) = Max' (IfNat (x <=? a) a x) xs+   Max' x (a ': xs) = Max' (If (x <=? a) a x) xs  -- | Tail of a list type family Tail (xs :: [*]) where@@ -97,14 +102,25 @@  -- | Get list length type family Length xs where-   Length '[]       = 0-   Length (x ': xs) = 1 + Length xs+   Length xs = Length' 0 xs +type family Length' n xs where+   Length' n '[]       = n+   Length' n (x ': xs) = Length' (n+1) xs+ -- | Replicate type family Replicate n s where-   Replicate 0 s = '[]-   Replicate n s = s ': Replicate (n-1) s+   Replicate n s = Replicate' s n '[] +type family Replicate' x n xs where+   Replicate' x 0 xs = xs+   Replicate' x n xs = Replicate' x (n-1) (x ': xs)++-- | Insert a list at n+type family InsertAt (n :: Nat) l l2 where+   InsertAt 0 xs ys        = Concat ys xs+   InsertAt n (x ': xs) ys = x ': InsertAt (n-1) xs ys+ -- | replace l[n] with l2 (folded) type family ReplaceAt (n :: Nat) l l2 where    ReplaceAt 0 (x ': xs) ys = Concat ys xs@@ -121,13 +137,18 @@    ReplaceN 0 t (x ': xs)  = (t ': xs)    ReplaceN n t (x ': xs)  = x ': ReplaceN (n-1) t xs +-- | replace types at offsets ns in l+type family ReplaceNS ns t l where+   ReplaceNS '[] t l       = l+   ReplaceNS (i ': is) t l = ReplaceNS is t (ReplaceN i t l)+ -- | Reverse a list type family Reverse (l :: [*]) where-   Reverse l = ReverseEx l '[]+   Reverse l = Reverse' l '[] -type family ReverseEx (l :: [*]) (l2 :: [*]) where-   ReverseEx '[] l       = l-   ReverseEx (x ': xs) l = ReverseEx xs (x ': l)+type family Reverse' (l :: [*]) (l2 :: [*]) where+   Reverse' '[] l       = l+   Reverse' (x ': xs) l = Reverse' xs (x ': l)   -- | Remove a type at index@@ -141,6 +162,11 @@    RemoveAt1 1 (x ': xs) = xs    RemoveAt1 n (x ': xs) = x ': RemoveAt1 (n-1) xs +-- | Remove types at several indexes+type family RemoveAtN (ns :: [Nat]) l where+   RemoveAtN '[] xs       = xs+   RemoveAtN (i ': is) xs = RemoveAtN is (RemoveAt i xs)+ -- | Apply Maybe to all the elements of the list type family MapMaybe l where    MapMaybe '[]       = '[]@@ -152,14 +178,14 @@    Generate n m = n ': Generate (n+1) m  -- | Check that a type is member of a type list-type family IsMember a l :: Bool where-   IsMember a l = IsMemberEx a l l+type family IsMember a (l :: [*]) :: Bool where+   IsMember a l = IsMember' l a l  -- | Check that a type is member of a type list-type family IsMemberEx a l (i :: [*]) :: Bool where-   IsMemberEx a (a ': l) i = 'True-   IsMemberEx a (b ': l) i = IsMemberEx a l i-   IsMemberEx a '[]      i = TypeError ( 'Text "`"+type family IsMember' (i :: [*]) a (l :: [*]) :: Bool where+   IsMember' i a (a ': l) = 'True+   IsMember' i a (b ': l) = IsMember' i a l+   IsMember' i a '[]      = TypeError ( 'Text "`"                                    ':<>: 'ShowType a                                    ':<>: 'Text "'"                                    ':<>: 'Text " is not a member of "@@ -169,16 +195,16 @@ -- | Check that a list is a subset of another type family IsSubset l1 l2 :: Bool where    IsSubset l1 l1 = 'True-   IsSubset l1 l2 = IsSubsetEx l1 l2 l2+   IsSubset l1 l2 = IsSubset' l2 l1 l2  -- | Helper for IsSubset-type family IsSubsetEx l1 l2 i :: Bool where-   IsSubsetEx '[] l2 i = 'True-   IsSubsetEx l1 '[] i = TypeError (     'ShowType l1+type family IsSubset' i l1 l2 :: Bool where+   IsSubset' i '[] l2 = 'True+   IsSubset' i l1 '[] = TypeError (     'ShowType l1                                    ':$$: 'Text "is not a subset of"                                    ':$$: 'ShowType i)-   IsSubsetEx (x ': xs) (x ': ys) i = IsSubsetEx xs i i-   IsSubsetEx (x ': xs) (y ': ys) i = IsSubsetEx (x ': xs) ys i+   IsSubset' i (x ': xs) (x ': ys) = IsSubset' i xs i+   IsSubset' i (x ': xs) (y ': ys) = IsSubset' i (x ': xs) ys  -- | Get list indexes type family Indexes (l :: [*]) where@@ -203,14 +229,17 @@ -- | Remove `a` in `l` type family Filter a (l :: [*]) where    Filter a '[]       = '[]-   Filter a (a ': xs) = Filter a xs-   Filter a (x ': xs) = x ': Filter a xs+   Filter a (a ': as) = Filter a as+   Filter a (b ': as) = b ': Filter a as  -- | Keep only a single value of each type type family Nub (l :: [*]) where-   Nub '[]       = '[]-   Nub (x ': xs) = x ': Nub (Filter x xs)+   Nub xs = Reverse (Nub' xs '[]) +type family Nub' as xs where+   Nub' '[]       xs = xs+   Nub' (x ': as) xs = Nub' (Filter x as) (x ': xs) + -- | Keep only a single value of the head type type family NubHead (l :: [*]) where    NubHead '[]       = '[]@@ -218,18 +247,27 @@  -- | Get the first index of a type type family IndexOf a (l :: [*]) :: Nat where-   IndexOf x xs = IndexOfEx x xs xs+   IndexOf x xs = IndexOf' x xs xs  -- | Get the first index of a type-type family IndexOfEx a (l :: [*]) (l2 :: [*]) :: Nat where-   IndexOfEx x (x ': xs) l2 = 0-   IndexOfEx y (x ': xs) l2 = 1 + IndexOfEx y xs l2-   IndexOfEx y '[]       l2 = TypeError ( 'Text "`"+type family IndexOf' a (l :: [*]) (l2 :: [*]) :: Nat where+   IndexOf' x (x ': xs) l2 = 0+   IndexOf' y (x ': xs) l2 = 1 + IndexOf' y xs l2+   IndexOf' y '[]       l2 = TypeError ( 'Text "`"                                     ':<>: 'ShowType y                                     ':<>: 'Text "'"                                     ':<>: 'Text " is not a member of "                                     ':<>: 'ShowType l2) +-- | Get all the indexes of a type+type family IndexesOf a (l :: [*]) :: [Nat] where+   IndexesOf x xs = IndexesOf' 0 x xs++-- | Get the first index of a type+type family IndexesOf' n a (l :: [*]) :: [Nat] where+   IndexesOf' n x '[]       = '[]+   IndexesOf' n x (x ': xs) = n ': IndexesOf' (n+1) x xs+   IndexesOf' n x (y ': xs) = IndexesOf' (n+1) x xs  -- | Get the first index (starting from 1) of a type or 0 if none type family MaybeIndexOf a (l :: [*]) where

@@ -11,46 +11,73 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-} --- | Typed Variant type (union)+-- | Open sum type module Haskus.Utils.Variant    ( Variant+   , V    , variantIndex-   , getVariantN-   , setVariantN-   , updateVariantN-   , setVariant-   , getVariant-   , updateVariant-   , updateVariantM-   , updateVariantFold-   , updateVariantFoldN-   , updateVariantFoldM-   , variantToHList-   , variantToTuple-   , liftEither-   , liftEitherM-   , variantRemoveType+   -- * Patterns+   , pattern V+   , pattern VMaybe+   -- * Operations by index+   , toVariantAt+   , toVariantHead+   , toVariantTail+   , fromVariantAt+   , popVariantAt+   , popVariantHead+   , updateVariantAt+   , foldMapVariantAt+   , foldMapVariantAtM+   -- * Operations by type+   , toVariant    , Member-   , Catchable-   , MaybeCatchable-   , Liftable-   , catchVariant-   , catchVariantMaybe-   , pickVariant-   , headVariant-   , singleVariant+   , Filter+   , Popable+   , MaybePopable+   , popVariant+   , popVariantMaybe+   , fromVariant+   , fromVariantMaybe+   , fromVariantFirst+   , updateVariantFirst+   , updateVariantFirstM+   , MappableVariant+   , mapVariant+   , foldMapVariantFirst+   , foldMapVariantFirstM+   , foldMapVariant+   -- * Generic operations with type classes+   , AlterVariant (..)+   , TraverseVariant (..)+   , NoConstraint+   , alterVariant+   , traverseVariant+   , traverseVariant_+   -- * Conversions between variants    , appendVariant    , prependVariant+   , Liftable    , liftVariant-   , liftVariantM-   , toEither+   , nubVariant+   -- * Conversions to/from other data types+   , variantToValue+   , variantToEither+   , variantFromEither+   , variantToHList+   , variantToTuple+   -- ** Continuations    , ContVariant (..)    ) where  import Unsafe.Coerce-import GHC.Exts (Any)+import GHC.Exts (Any,Constraint)  import Haskus.Utils.Monad import Haskus.Utils.Types@@ -63,14 +90,26 @@ -- list data Variant (l :: [*]) = Variant {-# UNPACK #-} !Word Any +type V = Variant+ -- | Make GHC consider `l` as a representational parameter to make coercions -- between Variant values unsafe type role Variant representational --- | Get Variant index-variantIndex :: Variant a -> Word-variantIndex (Variant n _) = n+-- | Pattern synonym for Variant+--+-- Usage: case v of+--          V (x :: Int)    -> ...+--          V (x :: String) -> ...+pattern V :: forall c cs. Popable c cs => c -> Variant cs+pattern V x <- (fromVariant -> Just x)+   where+      V x = toVariant x +-- | Statically unchecked matching on a Variant+pattern VMaybe :: forall c cs. (MaybePopable c cs) => c -> Variant cs+pattern VMaybe x <- (fromVariantMaybe -> Just x)+ instance Eq (Variant '[]) where    (==) = error "Empty variant" @@ -82,7 +121,7 @@       {-# INLINE (==) #-}       (==) v1@(Variant t1 _) v2@(Variant t2 _)          | t1 /= t2  = False-         | otherwise = case (headVariant v1, headVariant v2) of+         | otherwise = case (popVariantHead v1, popVariantHead v2) of             (Right a, Right b) -> a == b             (Left as, Left bs) -> as == bs             _                  -> False@@ -95,7 +134,7 @@    , Ord x    ) => Ord (Variant (x ': xs))    where-      compare v1 v2 = case (headVariant v1, headVariant v2) of+      compare v1 v2 = case (popVariantHead v1, popVariantHead v2) of          (Right a, Right b) -> compare a b          (Left as, Left bs) -> compare as bs          (Right _, Left _)  -> LT@@ -109,64 +148,219 @@    , Show x    ) => Show (Variant (x ': xs))    where-      show v = case headVariant v of+      show v = case popVariantHead v of          Right x -> show x          Left xs -> show xs +-----------------------------------------------------------+-- Operations by index+-----------------------------------------------------------++-- | Get Variant index+variantIndex :: Variant a -> Word+variantIndex (Variant n _) = n+ -- | Set the value with the given indexed type-setVariantN :: forall (n :: Nat) (l :: [*]).+toVariantAt :: forall (n :: Nat) (l :: [*]).    ( KnownNat n    ) => Index n l -> Variant l-{-# INLINE setVariantN #-}-setVariantN a = Variant (natValue @n) (unsafeCoerce a)+{-# INLINE toVariantAt #-}+toVariantAt a = Variant (natValue' @n) (unsafeCoerce a) +-- | Set the first value+toVariantHead :: forall x xs. x -> Variant (x ': xs)+{-# INLINE toVariantHead #-}+toVariantHead a = Variant 0 (unsafeCoerce a)++-- | Set the tail+toVariantTail :: forall x xs. Variant xs -> Variant (x ': xs)+{-# INLINE toVariantTail #-}+toVariantTail (Variant t a) = Variant (t+1) a+ -- | Get the value if it has the indexed type-getVariantN :: forall (n :: Nat) (l :: [*]).+fromVariantAt :: forall (n :: Nat) (l :: [*]).    ( KnownNat n    ) => Variant l -> Maybe (Index n l)-{-# INLINE getVariantN #-}-getVariantN (Variant t a) = do-   guard (t == natValue @n)+{-# INLINE fromVariantAt #-}+fromVariantAt (Variant t a) = do+   guard (t == natValue' @n)    return (unsafeCoerce a) -- we know it is the effective type --- | Lift an Either into a Variant (reversed order by convention)-liftEither :: Either a b -> Variant '[b,a]-{-# INLINE liftEither #-}-liftEither (Left a)  = setVariantN @1 a-liftEither (Right b) = setVariantN @0 b+-- | Pop a variant value by index, return either the value or the remaining+-- variant+popVariantAt :: forall (n :: Nat) l. +   ( KnownNat n+   ) => Variant l -> Either (Variant (RemoveAt n l)) (Index n l)+{-# INLINE popVariantAt #-}+popVariantAt v@(Variant t a) = case fromVariantAt @n v of+   Just x  -> Right x+   Nothing -> Left $ if t > natValue' @n+      then Variant (t-1) a+      else Variant t a --- | Lift an Either into a Variant (reversed order by convention)-liftEitherM :: (Monad m) => m (Either a b) -> m (Variant '[b,a])-liftEitherM = fmap liftEither+-- | Pop the head of a variant value+popVariantHead :: forall x xs. Variant (x ': xs) -> Either (Variant xs) x+{-# INLINE popVariantHead #-}+popVariantHead v@(Variant t a) = case fromVariantAt @0 v of+   Just x  -> Right x+   Nothing -> Left $ Variant (t-1) a  -- | Update a variant value-updateVariantN :: forall (n :: Nat) a b l.+updateVariantAt :: forall (n :: Nat) a b l.    ( KnownNat n    , a ~ Index n l    ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)-{-# INLINE updateVariantN #-}-updateVariantN f v@(Variant t a) =-   case getVariantN @n v of+{-# INLINE updateVariantAt #-}+updateVariantAt f v@(Variant t a) =+   case fromVariantAt @n v of       Nothing -> Variant t a       Just x  -> Variant t (unsafeCoerce (f x)) --- | Update a variant value in a Monad-updateVariantM :: forall (n :: Nat) l l2 m .+-----------------------------------------------------------+-- Operations by type+-----------------------------------------------------------++-- | Put a value into a Variant+--+-- Use the first matching type index.+toVariant :: forall a l.+   ( Member a l+   ) => a -> Variant l+{-# INLINE toVariant #-}+toVariant = toVariantAt @(IndexOf a l)++class PopVariant a xs where+   -- | Remove a type from a variant+   popVariant' :: Variant xs -> Either (Variant (Filter a xs)) a++instance PopVariant a '[] where+   popVariant' _ = undefined++instance forall a xs n xs' y ys.+      ( PopVariant a xs'+      , n ~ MaybeIndexOf a xs+      , xs' ~ RemoveAt1 n xs+      , Filter a xs' ~ Filter a xs+      , KnownNat n+      , xs ~ (y ': ys)+      ) => PopVariant a (y ': ys)+   where+      {-# INLINE popVariant' #-}+      popVariant' (Variant t a)+         = case natValue' @n of+            0             -> Left (Variant t a) -- no 'a' left in xs+            n | n-1 == t  -> Right (unsafeCoerce a)+              | n-1 < t   -> popVariant' @a @xs' (Variant (t-1) a)+              | otherwise -> Left (Variant t a)++-- | a is popable in xs+type Popable a xs =+   ( Member a xs+   , PopVariant a xs+   )++-- | a may be popable in xs+type MaybePopable a xs =+   ( PopVariant a xs+   )++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+popVariant :: forall a xs.+   ( Popable a xs+   ) => Variant xs -> Either (Variant (Filter a xs)) a+popVariant v = popVariant' @a v++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+popVariantMaybe :: forall a xs.+   ( MaybePopable a xs+   ) => Variant xs -> Either (Variant (Filter a xs)) a+popVariantMaybe v = popVariant' @a v++-- | Pick the first matching type of a Variant+--+-- fromVariantFirst @A (Variant 2 undefined :: Variant '[A,B,A]) == Nothing+fromVariantFirst :: forall a l.+   ( Member a l+   ) => Variant l -> Maybe a+{-# INLINE fromVariantFirst #-}+fromVariantFirst = fromVariantAt @(IndexOf a l)++-- | Try to a get a value of a given type from a Variant+fromVariant :: forall a xs.+   ( Popable a xs+   ) => Variant xs -> Maybe a+{-# INLINE fromVariant #-}+fromVariant v = case popVariant v of+   Right a -> Just a+   Left _  -> Nothing++-- | Try to a get a value of a given type from a Variant that may not even+-- support the given type.+fromVariantMaybe :: forall a xs.+   ( MaybePopable a xs+   ) => Variant xs -> Maybe a+{-# INLINE fromVariantMaybe #-}+fromVariantMaybe v = case popVariantMaybe v of+   Right a -> Just a+   Left _  -> Nothing++-- | Update a variant value+updateVariantFirst :: forall a b n l.+   ( Member a l+   , n ~ IndexOf a l+   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)+{-# INLINE updateVariantFirst #-}+updateVariantFirst f v = updateVariantAt @n f v++-- | Monadic update of the first matching variant value+updateVariantFirstM :: forall (n :: Nat) l l2 m .    (KnownNat n, Monad m)    => (Index n l -> m (Index n l2)) -> Variant l -> m (Variant l2)-{-# INLINE updateVariantM #-}-updateVariantM f v@(Variant t a) =-   case getVariantN @n v of+{-# INLINE updateVariantFirstM #-}+updateVariantFirstM f v@(Variant t a) =+   case fromVariantAt @n v of       Nothing -> return (Variant t a)       Just x  -> Variant t <$> unsafeCoerce (f x) +class MapVariant a b cs (is :: [Nat]) where+   mapVariant' :: (a -> b) -> Variant cs -> Variant (ReplaceNS is b cs)++instance MapVariant a b '[] is where+   {-# INLINE mapVariant' #-}+   mapVariant' = undefined++instance MapVariant a b cs '[] where+   {-# INLINE mapVariant' #-}+   mapVariant' _ v = v++instance forall a b cs is i.+   ( MapVariant a b (ReplaceN i b cs) is+   , a ~ Index i cs+   , KnownNat i+   ) => MapVariant a b cs (i ': is) where+   {-# INLINE mapVariant' #-}+   mapVariant' f v = mapVariant' @a @b @(ReplaceN i b cs) @is f (updateVariantAt @i f v)++type MappableVariant a b cs =+   ( MapVariant a b cs (IndexesOf a cs)+   )++-- | Map the matching types of a variant+mapVariant :: forall a b cs.+   ( MappableVariant a b cs+   ) => (a -> b) -> Variant cs -> Variant (ReplaceNS (IndexesOf a cs) b cs)+mapVariant = mapVariant' @a @b @cs @(IndexesOf a cs)++ -- | Update a variant value with a variant and fold the result-updateVariantFoldN :: forall (n :: Nat) l l2 .+foldMapVariantAt :: forall (n :: Nat) l l2 .    ( KnownNat n    , KnownNat (Length l2)    ) => (Index n l -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)-updateVariantFoldN f v@(Variant t a) =-   case getVariantN @n v of+foldMapVariantAt f v@(Variant t a) =+   case fromVariantAt @n v of       Nothing ->          -- we need to adapt the tag if new valid tags (from l2) are added before          if t < n@@ -176,26 +370,17 @@       Just x  -> case f x of          Variant t2 a2 -> Variant (t2+n) a2    where-      n   = natValue @n-      nl2 = natValue @(Length l2)---- | Update a variant value with a variant and fold the result-updateVariantFold :: forall a (n :: Nat) l l2 .-   ( KnownNat n-   , KnownNat (Length l2)-   , n ~ IndexOf a l-   , a ~ Index n l-   ) => (a -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)-updateVariantFold f v = updateVariantFoldN @n f v+      n   = natValue' @n+      nl2 = natValue' @(Length l2)  -- | Update a variant value with a variant and fold the result-updateVariantFoldM :: forall (n :: Nat) m l l2.+foldMapVariantAtM :: forall (n :: Nat) m l l2.    ( KnownNat n    , KnownNat (Length l2)    , Monad m    ) => (Index n l -> m (Variant l2)) -> Variant l -> m (Variant (ReplaceAt n l l2))-updateVariantFoldM f v@(Variant t a) =-   case getVariantN @n v of+foldMapVariantAtM f v@(Variant t a) =+   case fromVariantAt @n v of       Nothing ->          -- we need to adapt the tag if new valid tags (from l2) are added before          return $ if t < n@@ -207,109 +392,141 @@          case y of             Variant t2 a2 -> return (Variant (t2+n) a2)    where-      n   = natValue @n-      nl2 = natValue @(Length l2)+      n   = natValue' @n+      nl2 = natValue' @(Length l2) +-- | Update a variant value with a variant and fold the result+foldMapVariantFirst :: forall a (n :: Nat) l l2 .+   ( KnownNat n+   , KnownNat (Length l2)+   , n ~ IndexOf a l+   , a ~ Index n l+   ) => (a -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)+foldMapVariantFirst f v = foldMapVariantAt @n f v -class VariantToHList xs where-   -- | Convert a variant into a HList of Maybes-   variantToHList :: Variant xs -> HList (MapMaybe xs)+-- | Update a variant value with a variant and fold the result+foldMapVariantFirstM :: forall a (n :: Nat) l l2 m.+   ( KnownNat n+   , KnownNat (Length l2)+   , n ~ IndexOf a l+   , a ~ Index n l+   , Monad m+   ) => (a -> m (V l2)) -> V l -> m (V (ReplaceAt n l l2))+foldMapVariantFirstM f v = foldMapVariantAtM @n f v -instance VariantToHList '[] where-   variantToHList _ = HNil -instance-   ( VariantToHList xs-   ) => VariantToHList (x ': xs)++-- | Update a variant value with a variant and fold the result+foldMapVariant :: forall a cs ds i.+   ( i ~ IndexOf a cs+   , Popable a cs+   ) => (a -> V ds) -> V cs -> V (InsertAt i (Filter a cs) ds)+foldMapVariant f v = case popVariant v of+   Right a -> case f a of+      Variant t x -> Variant (i + t) x+   Left (Variant t x)+      | t < i     -> Variant t x+      | otherwise -> Variant (i+t) x    where-      variantToHList v@(Variant t a) =-            getVariantN @0 v `HCons` variantToHList v'-         where-            v' :: Variant xs-            v' = Variant (t-1) a+      i = natValue' @i  -class VariantRemoveType a xs where-   -- | Remove a type from a variant-   variantRemoveType :: Variant xs -> Either (Variant (Filter a xs)) a -instance VariantRemoveType a '[] where-   variantRemoveType _ = undefined -instance forall a xs n xs' y ys.-      ( VariantRemoveType a xs'-      , n ~ MaybeIndexOf a xs-      , xs' ~ RemoveAt1 n xs-      , Filter a xs' ~ Filter a xs-      , KnownNat n-      , xs ~ (y ': ys)-      ) => VariantRemoveType a (y ': ys)+-----------------------------------------------------------+-- Generic operations with type classes+-----------------------------------------------------------++class AlterVariant c (b :: [*]) where+   alterVariant' :: Alter c -> Word -> Any -> Any++instance AlterVariant c '[] where+   {-# INLINE alterVariant' #-}+   alterVariant' = undefined++instance+   ( AlterVariant c xs+   , c x+   ) => AlterVariant c (x ': xs)    where-      {-# INLINE variantRemoveType #-}-      variantRemoveType (Variant t a)-         = case natValue' @n of-            0             -> Left (Variant t a) -- no 'a' left in xs-            n | n-1 == t  -> Right (unsafeCoerce a)-              | n-1 < t   -> variantRemoveType @a @xs' (Variant (t-1) a)-              | otherwise -> Left (Variant t a)+      {-# INLINE alterVariant' #-}+      alterVariant' m@(Alter f) t v =+         case t of+            0 -> unsafeCoerce (f (unsafeCoerce v :: x))+            n -> alterVariant' @c @xs m (n-1) v --- | a is catchable in xs-type Catchable a xs =-   ( IsMember a xs ~ 'True-   , VariantRemoveType a xs-   )+-- | Wrap a function and its constraints+data Alter (c :: * -> Constraint) = Alter (forall a. c a => a -> a) --- | a may be catchable in xs-type MaybeCatchable a xs =-   ( VariantRemoveType a xs-   )+-- | Wrap a function and its constraints+data AlterM (c :: * -> Constraint) m = AlterM (forall a. (Monad m, c a) => a -> m a) --- | Extract a type from a variant. Return either the value of this type or the--- remaining variant-catchVariant :: forall a xs.-   ( Catchable a xs-   ) => Variant xs -> Either (Variant (Filter a xs)) a-catchVariant v = variantRemoveType @a v+-- | Useful to specify a "* -> Constraint" function returning no constraint+class NoConstraint a+instance NoConstraint a --- | Extract a type from a variant. Return either the value of this type or the--- remaining variant-catchVariantMaybe :: forall a xs.-   ( MaybeCatchable a xs-   ) => Variant xs -> Either (Variant (Filter a xs)) a-catchVariantMaybe v = variantRemoveType @a v+class TraverseVariant c (b :: [*]) m where+   traverseVariant' :: AlterM c m -> Word -> Any -> m Any --- | Pick a variant value-pickVariant :: forall (n :: Nat) l. -   ( KnownNat n-   ) => Variant l -> Either (Variant (RemoveAt n l)) (Index n l)-{-# INLINE pickVariant #-}-pickVariant v@(Variant t a) = case getVariantN @n v of-   Just x  -> Right x-   Nothing -> Left $ if t > natValue @n-      then Variant (t-1) a-      else Variant t a+instance TraverseVariant c '[] m where+   {-# INLINE traverseVariant' #-}+   traverseVariant' = undefined --- | Pick the head of a variant value-headVariant :: forall x xs. Variant (x ': xs) -> Either (Variant xs) x-{-# INLINE headVariant #-}-headVariant v@(Variant t a) = case getVariantN @0 v of-   Just x  -> Right x-   Nothing -> Left $ Variant (t-1) a+instance+   ( TraverseVariant c xs m+   , c x+   , Monad m+   ) => TraverseVariant c (x ': xs) m+   where+      {-# INLINE traverseVariant' #-}+      traverseVariant' m@(AlterM f) t v =+         case t of+            0 -> unsafeCoerce <$> f (unsafeCoerce v :: x)+            n -> traverseVariant' @c @xs m (n-1) v  --- | Get variant possible values in a tuple of Maybe types-variantToTuple :: forall l t.-   ( VariantToHList l-   , HTuple' (MapMaybe l) t-   ) => Variant l -> t-variantToTuple = hToTuple' . variantToHList+-- | Alter a variant. You need to specify the constraints required by the+-- modifying function.+--+-- Usage:+--    alterVariant @NoConstraint id         v+--    alterVariant @Resizable    (resize 4) v+--+--    class (Ord a, Num a) => OrdNum a+--    instance (Ord a, Num a) => OrdNum a+--+{-# INLINE alterVariant #-}+alterVariant :: forall c (a :: [*]).+   ( AlterVariant c a+   ) => (forall x. c x => x -> x) -> Variant a  -> Variant a+alterVariant f (Variant t a) = +   Variant t (alterVariant' @c @a (Alter @c f) t a) --- | Retreive the last v-singleVariant :: Variant '[a] -> a-{-# INLINE singleVariant #-}-singleVariant (Variant _ a) = unsafeCoerce a+-- | Traverse a variant. You need to specify the constraints required by the+-- modifying function.+{-# INLINE traverseVariant #-}+traverseVariant :: forall c (a :: [*]) m.+   ( TraverseVariant c a m+   , Monad m+   ) => (forall x. c x => x -> m x) -> Variant a  -> m (Variant a)+traverseVariant f (Variant t a) = +   Variant t <$> traverseVariant' @c @a (AlterM @c @m f) t a +-- | Traverse a variant. You need to specify the constraints required by the+-- modifying function.+traverseVariant_ :: forall c (a :: [*]) m.+   ( TraverseVariant c a m+   , Monad m+   ) => (forall x. c x => x -> m ()) -> Variant a  -> m ()+traverseVariant_ f v = void (traverseVariant @c @a f' v)+   where+      f' :: forall x. c x => x -> m x+      f' x = f x >> return x +-----------------------------------------------------------+-- Conversions between variants+-----------------------------------------------------------+ -- | Extend a variant by appending other possible values appendVariant :: forall (ys :: [*]) (xs :: [*]). Variant xs -> Variant (Concat xs ys) {-# INLINE appendVariant #-}@@ -322,30 +539,7 @@ {-# INLINE prependVariant #-} prependVariant (Variant t a) = Variant (n+t) a    where-      n = natValue @(Length ys)---- | Set the first matching type of a Variant-setVariant :: forall a l.-   ( Member a l-   ) => a -> Variant l-{-# INLINE setVariant #-}-setVariant = setVariantN @(IndexOf a l)---- | Set the first matching type of a Variant-getVariant :: forall a l.-   ( Member a l-   ) => Variant l -> Maybe a-{-# INLINE getVariant #-}-getVariant = getVariantN @(IndexOf a l)---- | Update a variant value-updateVariant :: forall a b n l.-   ( Member a l-   , n ~ IndexOf a l-   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)-{-# INLINE updateVariant #-}-updateVariant f v = updateVariantN @n f v-+      n = natValue' @(Length ys)  -- | xs is liftable in ys type Liftable xs ys =@@ -353,22 +547,21 @@    , VariantLift xs ys    ) - class VariantLift xs ys where    liftVariant' :: Variant xs -> Variant ys  instance VariantLift '[] ys where    liftVariant' = error "Lifting empty variant" -instance forall x xs ys.+instance forall xs ys x.       ( VariantLift xs ys       , KnownNat (IndexOf x ys)       ) => VariantLift (x ': xs) ys    where       {-# INLINE liftVariant' #-}-      liftVariant' v = case headVariant v of-         Right a  -> Variant (natValue @(IndexOf x ys)) (unsafeCoerce a)-         Left  v' -> liftVariant' v'+      liftVariant' (Variant t a)+         | t == 0    = Variant (natValue' @(IndexOf x ys)) a+         | otherwise = liftVariant' @xs (Variant (t-1) a)   -- | Lift a variant into another@@ -380,20 +573,57 @@ {-# INLINE liftVariant #-} liftVariant = liftVariant' -liftVariantM ::-   ( Liftable xs ys-   , Monad m-   ) => Variant xs -> m (Variant ys)-{-# INLINE liftVariantM #-}-liftVariantM = return . liftVariant+-- | Nub the type list+nubVariant :: (Liftable xs (Nub xs)) => V xs -> V (Nub xs)+nubVariant = liftVariant +-----------------------------------------------------------+-- Conversions to other data types+----------------------------------------------------------- +-- | Retreive a single value+variantToValue :: Variant '[a] -> a+{-# INLINE variantToValue #-}+variantToValue (Variant _ a) = unsafeCoerce a++ -- | Convert a variant of two values in a Either-toEither :: forall a b. Variant '[a,b] -> Either b a-toEither (Variant 0 a) = Right (unsafeCoerce a)-toEither (Variant _ a) = Left (unsafeCoerce a)+variantToEither :: forall a b. Variant '[a,b] -> Either b a+variantToEither (Variant 0 a) = Right (unsafeCoerce a)+variantToEither (Variant _ a) = Left (unsafeCoerce a) +class VariantToHList xs where+   -- | Convert a variant into a HList of Maybes+   variantToHList :: Variant xs -> HList (MapMaybe xs) +instance VariantToHList '[] where+   variantToHList _ = HNil++instance+   ( VariantToHList xs+   ) => VariantToHList (x ': xs)+   where+      variantToHList v@(Variant t a) =+            fromVariantAt @0 v `HCons` variantToHList v'+         where+            v' :: Variant xs+            v' = Variant (t-1) a++-- | Get variant possible values in a tuple of Maybe types+variantToTuple :: forall l t.+   ( VariantToHList l+   , HTuple' (MapMaybe l) t+   ) => Variant l -> t+variantToTuple = hToTuple' . variantToHList+++-- | Lift an Either into a Variant (reversed order by convention)+variantFromEither :: Either a b -> Variant '[b,a]+{-# INLINE variantFromEither #-}+variantFromEither (Left a)  = toVariantAt @1 a+variantFromEither (Right b) = toVariantAt @0 b++ class ContVariant xs where    -- | Convert a variant into a multi-continuation    variantToCont :: Variant xs -> ContFlow xs r@@ -419,11 +649,11 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      Single (setVariantN @0)+      Single (toVariantAt @0)     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      Single (return . setVariantN @0)+      Single (return . toVariantAt @0)  instance ContVariant '[a,b] where    {-# INLINE variantToCont #-}@@ -441,14 +671,14 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1+      ( toVariantAt @0+      , toVariantAt @1       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1+      ( return . toVariantAt @0+      , return . toVariantAt @1       )  instance ContVariant '[a,b,c] where@@ -469,16 +699,16 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2       )  instance ContVariant '[a,b,c,d] where@@ -501,18 +731,18 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3       )  instance ContVariant '[a,b,c,d,e] where@@ -537,20 +767,20 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4       )  instance ContVariant '[a,b,c,d,e,f] where@@ -577,22 +807,22 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5       )  instance ContVariant '[a,b,c,d,e,f,g] where@@ -621,24 +851,24 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6       )  instance ContVariant '[a,b,c,d,e,f,g,h] where@@ -669,26 +899,26 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6-      , setVariantN @7+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6+      , toVariantAt @7       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6-      , return . setVariantN @7+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6+      , return . toVariantAt @7       )  instance ContVariant '[a,b,c,d,e,f,g,h,i] where@@ -721,28 +951,28 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6-      , setVariantN @7-      , setVariantN @8+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6+      , toVariantAt @7+      , toVariantAt @8       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6-      , return . setVariantN @7-      , return . setVariantN @8+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6+      , return . toVariantAt @7+      , return . toVariantAt @8       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j] where@@ -777,30 +1007,30 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6-      , setVariantN @7-      , setVariantN @8-      , setVariantN @9+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6+      , toVariantAt @7+      , toVariantAt @8+      , toVariantAt @9       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6-      , return . setVariantN @7-      , return . setVariantN @8-      , return . setVariantN @9+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6+      , return . toVariantAt @7+      , return . toVariantAt @8+      , return . toVariantAt @9       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k] where@@ -837,32 +1067,32 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6-      , setVariantN @7-      , setVariantN @8-      , setVariantN @9-      , setVariantN @10+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6+      , toVariantAt @7+      , toVariantAt @8+      , toVariantAt @9+      , toVariantAt @10       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6-      , return . setVariantN @7-      , return . setVariantN @8-      , return . setVariantN @9-      , return . setVariantN @10+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6+      , return . toVariantAt @7+      , return . toVariantAt @8+      , return . toVariantAt @9+      , return . toVariantAt @10       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k,l] where@@ -901,32 +1131,32 @@     {-# INLINE contToVariant #-}    contToVariant c = c >::>-      ( setVariantN @0-      , setVariantN @1-      , setVariantN @2-      , setVariantN @3-      , setVariantN @4-      , setVariantN @5-      , setVariantN @6-      , setVariantN @7-      , setVariantN @8-      , setVariantN @9-      , setVariantN @10-      , setVariantN @11+      ( toVariantAt @0+      , toVariantAt @1+      , toVariantAt @2+      , toVariantAt @3+      , toVariantAt @4+      , toVariantAt @5+      , toVariantAt @6+      , toVariantAt @7+      , toVariantAt @8+      , toVariantAt @9+      , toVariantAt @10+      , toVariantAt @11       )     {-# INLINE contToVariantM #-}    contToVariantM c = c >::>-      ( return . setVariantN @0-      , return . setVariantN @1-      , return . setVariantN @2-      , return . setVariantN @3-      , return . setVariantN @4-      , return . setVariantN @5-      , return . setVariantN @6-      , return . setVariantN @7-      , return . setVariantN @8-      , return . setVariantN @9-      , return . setVariantN @10-      , return . setVariantN @11+      ( return . toVariantAt @0+      , return . toVariantAt @1+      , return . toVariantAt @2+      , return . toVariantAt @3+      , return . toVariantAt @4+      , return . toVariantAt @5+      , return . toVariantAt @6+      , return . toVariantAt @7+      , return . toVariantAt @8+      , return . toVariantAt @9+      , return . toVariantAt @10+      , return . toVariantAt @11       )

@@ -4,11 +4,13 @@  import Haskus.Tests.Utils.HArray import Haskus.Tests.Utils.Variant+import Haskus.Tests.Utils.Solver  testsUtils :: TestTree testsUtils = testGroup "Utils"    [ testsHArray    , testsVariant+   , testsSolver    ]  

@@ -0,0 +1,240 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++module Haskus.Tests.Utils.Solver+   ( testsSolver+   )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Data.List++import Haskus.Utils.Solver+import Haskus.Utils.Flow+++data Predi+   = PredA+   | PredB+   | PredC+   | PredD+   | PredE+   deriving (Show,Eq,Ord)++newtype Err+   = Err String+   deriving (Show,Eq,Ord)++type C     = Constraint Err Predi+type R a t = RuleT Err Predi a t++data T+data NT++type family RuleT e p a s :: * where+   RuleT e p a T   = a+   RuleT e p a NT  = Rule e p a++data PD t = PD+   { pInt  :: R Int t+   , _pStr :: R String t+   }++deriving instance Eq (PD T)+deriving instance Show (PD T)+deriving instance Ord (PD T)+deriving instance Eq (PD NT)+deriving instance Show (PD NT)+deriving instance Ord (PD NT)++instance Predicated (PD NT) where+   type PredErr (PD NT)  = Err+   type Pred (PD NT)     = Predi+   type PredTerm (PD NT) = PD T++   liftTerminal (PD a b) = PD (liftTerminal a) (liftTerminal b)++   reducePredicates oracle (PD a b) =+      initP PD PD+         |> (`applyP` reducePredicates oracle a)+         |> (`applyP` reducePredicates oracle b)+         |> resultP++   getTerminals (PD as bs) = [ PD a b | a <- getTerminals as+                                      , b <- getTerminals bs+                             ]++   getPredicates (PD a b) = concat+                              [ getPredicates a+                              , getPredicates b+                              ]++testsSolver :: TestTree+testsSolver = testGroup "Solver" $+   [ testProperty "Constraint reduce: CBool True"+         (constraintReduce oracleAll (CBool True) == (CBool True :: C))+   , testProperty "Constraint reduce: CBool False"+         (constraintReduce oracleAll (CBool False) == (CBool False :: C))+   , testProperty "Constraint reduce: Not False"+         (constraintReduce oracleAll (Not (CBool False)) == (CBool True :: C))+   , testProperty "Constraint reduce: Not True"+         (constraintReduce oracleAll (Not (CBool True)) == (CBool False :: C))+   , testProperty "Constraint reduce: And [True,True]"+         (constraintReduce oracleAll (And [CBool True,CBool True]) == (CBool True :: C))+   , testProperty "Constraint reduce: And [True,False]"+         (constraintReduce oracleAll (And [CBool True,CBool False]) == (CBool False :: C))+   , testProperty "Constraint reduce: Or [True,True]"+         (constraintReduce oracleAll (Or [CBool True,CBool True]) == (CBool True :: C))+   , testProperty "Constraint reduce: Or [True,False]"+         (constraintReduce oracleAll (Or [CBool True,CBool False]) == (CBool True :: C))+   , testProperty "Constraint reduce: Or [False,False]"+         (constraintReduce oracleAll (Or [CBool False,CBool False]) == (CBool False :: C))++   , testProperty "Constraint reduce: Xor [True,False,True]"+         (constraintReduce oracleAll (Xor [CBool True,CBool False,CBool True]) == (CBool False :: C))+   , testProperty "Constraint reduce: Xor [True,False,False]"+         (constraintReduce oracleAll (Xor [CBool True,CBool False,CBool False]) == (CBool True :: C))++   , testProperty "Constraint reduce: Not (Xor [True,False,False])"+         (constraintReduce oracleAll (Not (Xor [CBool True,CBool False,CBool False])) == (CBool False :: C))+   , testProperty "Constraint reduce: Not (Xor [False,False,False])"+         (constraintReduce oracleAll (Not (Xor [CBool False,CBool False,CBool False])) == (CBool True :: C))++   , testProperty "Constraint reduce: matching oracle"+         (constraintReduce oracleA (Predicate PredA) == (CBool True :: C))+   , testProperty "Constraint reduce: non matching oracle"+         (constraintReduce oracleB (Predicate PredA) == (CBool False :: C))++   , testProperty "Constraint reduce: evalsTo 0"+         (constraintReduce oracleAll (simpleRule `evalsTo` 0) == (CBool False :: C))+   , testProperty "Constraint reduce: evalsTo 1"+         (constraintReduce oracleAll (simpleRule `evalsTo` 1) == (CBool True :: C))+   , testProperty "Constraint reduce: evals to D"+         (constraintReduce oracleA (d1 `evalsTo` PD 0 "Test") == (CBool True :: C))++   , testProperty "Evals to: Terminal 0"+         (((Terminal 0 :: R Int NT) `evalsTo` 0) == (CBool True :: C))+   , testProperty "Evals to: Terminal 1"+         (((Terminal 1 :: R Int NT) `evalsTo` 0) == (CBool False :: C))+   +   , testProperty "Predicated data: matching"+         (reducePredicates oracleA d1 == Match (PD 0 "Test"))+   , testProperty "Predicated data: not matching"+         (case reducePredicates oracleB d1 of+            NoMatch -> True+            _       -> False+         )+   , testProperty "Predicated data: failing"+         (case reducePredicates oracleC d1 of+            MatchFail _ -> True+            _           -> False+         )+   , testProperty "Predicated data: divergent"+         (case reducePredicates oracleD d1 of+            MatchDiverge xs -> sort xs == sort [d1 { pInt = Terminal 1}, d1 { pInt = Terminal 0}]+            _               -> False+         )+   , testProperty "Predicated data: not terminal"+         (case reducePredicates oracleAE d1 of+            DontMatch _ -> True+            _           -> False+         )++   , testProperty "Ordered non terminal 0"+         (case reducePredicates oracleAB (orderedNonTerminal [(Predicate PredA, Terminal 0 :: R Int NT)+                                                             ,(Predicate PredB, Terminal 1)+                                                             ]) of+            Match 0 -> True+            _       -> False+         )+   , testProperty "Ordered non terminal 1"+         (case reducePredicates oracleAB (orderedNonTerminal [(Predicate PredB, Terminal 1 :: R Int NT)+                                                             ,(Predicate PredA, Terminal 0)+                                                             ]) of+            Match 1 -> True+            _       -> False+         )+   , testProperty "Get predicates: flat"+         (sort (getPredicates d1) == sort [PredA,PredC,PredD,PredE])++   , testProperty "Get predicates: nested"+         (sort (getPredicates d2) == sort [PredA,PredB,PredC,PredD])++   , testProperty "Create predicate table: flat non terminal"+         (case createPredicateTable d1 (const True) False of+            Left _   -> False+            Right xs -> sort (fmap (oraclePredicates . fst) xs) == sort+                           [ [(PredA, SetPred)  , (PredC, UnsetPred), (PredD, UnsetPred), (PredE, UnsetPred)]+                           , [(PredA, SetPred)  , (PredC, UnsetPred), (PredD, UnsetPred), (PredE, SetPred)]+                           , [(PredA, UnsetPred), (PredC, UnsetPred), (PredD, UnsetPred), (PredE, SetPred)]+                           ]+         )+   , testProperty "Create predicate table: nested non terminal"+         (case createPredicateTable d2 (const True) False of+            Left _   -> False+            Right xs -> sort (fmap (oraclePredicates . fst) xs) == sort+                  [ [(PredA,SetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  , [(PredA,UnsetPred),(PredB,SetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  , [(PredA,UnsetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredD,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred)]+                  ]+         )++   , testProperty "Create full predicate table: nested non terminal"+         (case createPredicateTable d2 (const True) True of+            Left _   -> False+            Right xs -> sort (fmap (oraclePredicates . fst) xs) == sort+                  [ [(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,SetPred)]+                  , [(PredA,UnsetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,SetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,SetPred)]+                  , [(PredA,UnsetPred),(PredB,SetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  , [(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  ]+         )+   ]++   where+      oracleAll = makeOracle (fmap (,SetPred) [PredA,PredB,PredC,PredD,PredE])+      oracleA   = makeOracle ((PredA,SetPred) : fmap (,UnsetPred) [PredB,PredC,PredD,PredE])+      oracleB   = makeOracle ((PredB,SetPred) : fmap (,UnsetPred) [PredA,PredC,PredD,PredE])+      oracleC   = makeOracle ((PredC,SetPred) : fmap (,UnsetPred) [PredA,PredB,PredD,PredE])+      oracleD   = makeOracle ((PredD,SetPred) : fmap (,UnsetPred) [PredA,PredB,PredC,PredE])+      oracleAE  = makeOracle ((PredA,UndefPred) : (PredD,UndefPred) : fmap (,UnsetPred) [PredB,PredC,PredE])+      oracleAB  = makeOracle ((PredA,SetPred) : (PredB,SetPred) : fmap (,UnsetPred) [PredC,PredD,PredE])++      simpleRule :: R Int NT+      simpleRule = NonTerminal+                     [ (CBool False, Terminal 0)+                     , (CBool True,  Terminal 1)+                     ]+      d1 :: PD NT+      d1 = PD (NonTerminal [ (Predicate PredA, Terminal 0)+                          , (Predicate PredC, Fail (Err "D doesn't support predicate C"))+                          , (Predicate PredD, Terminal 0)+                          , (Predicate PredD, Terminal 1)+                          , (Predicate PredE, Terminal 0)+                          ])+             (Terminal "Test")+      d2 :: PD NT+      d2 = PD (NonTerminal [ (Predicate PredA, Terminal 0)+                          , (Predicate PredB, NonTerminal+                              [ (Predicate PredC, Terminal 1)+                              , (Predicate PredD, Terminal 2)+                              ])+                          ])+             (Terminal "Test")

@@ -2,6 +2,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}  module Haskus.Tests.Utils.Variant    ( testsVariant@@ -25,7 +28,7 @@ type DEF = Variant '[D,E,F]  b :: ABC-b = setVariantN @1 B+b = toVariantAt @1 B  b2d :: B -> D b2d = const D@@ -34,78 +37,93 @@ c2d = const D  b2def :: B -> DEF-b2def = const (setVariant E)+b2def = const (toVariant E)  c2def :: C -> DEF-c2def = const (setVariant E)+c2def = const (toVariant E)   testsVariant :: TestTree testsVariant = testGroup "Variant" $    [ testProperty "set/get by index (match)"-         (getVariantN @1 b == Just B)+         (fromVariantAt @1 b == Just B)    , testProperty "set/get by index (dont' match)"-         (getVariantN @0 b == Nothing)+         (fromVariantAt @0 b == Nothing)    , testProperty "set/get by type (match)"-         (getVariant    (setVariant B :: ABC) == Just B)+         (fromVariant    (toVariant B :: ABC) == Just B)    , testProperty "set/get by type (don't match)"-         (getVariant @C (setVariant B :: ABC) == Nothing)+         (fromVariant @C (toVariant B :: ABC) == Nothing)     , testProperty "variant equality (match)"          (b == b)    , testProperty "variant equality (don't match)"-         (b /= setVariant C)+         (b /= toVariant C)     , testProperty "update by index (match)"-         (updateVariantN @1 (const D) b == setVariantN @1 D)+         (updateVariantAt @1 (const D) b == toVariantAt @1 D)    , testProperty "update by index (don't match)"-         (updateVariantN @0 (const F) b == setVariantN @1 B)+         (updateVariantAt @0 (const F) b == toVariantAt @1 B)    , testProperty "update by type (match)"-         (updateVariant b2d b == setVariantN @1 D)+         (updateVariantFirst b2d b == toVariantAt @1 D)    , testProperty "update by type (don't match)"-         (updateVariant c2d b == setVariant B)+         (updateVariantFirst c2d b == toVariant B)    , testProperty "update/fold by index (match)"-         (updateVariantFoldN @1 b2def b == setVariant E)+         (foldMapVariantAt @1 b2def b == toVariant E)    , testProperty "update/fold by index (don't match)"-         (updateVariantFoldN @2 c2def b == setVariant B)+         (foldMapVariantAt @2 c2def b == toVariant B)     , testProperty "Convert into tuple"          (variantToTuple b == (Nothing, Just B, Nothing))    , testProperty "Convert single variant"-         (singleVariant (setVariant A :: Variant '[A]) == A)+         (variantToValue (toVariant A :: Variant '[A]) == A)     , testProperty "Lift Either: Left"-         (liftEither (Left A :: Either A B) == setVariant A)+         (variantFromEither (Left A :: Either A B) == toVariant A)    , testProperty "Lift Either: Right"-         (liftEither (Right B :: Either A B) == setVariant B)+         (variantFromEither (Right B :: Either A B) == toVariant B)     , testProperty "To Either: Left"-         (toEither (setVariant B :: Variant '[A,B]) == Left B)+         (variantToEither (toVariant B :: Variant '[A,B]) == Left B)    , testProperty "To Either: Right"-         (toEither (setVariant A :: Variant '[A,B]) == Right A)+         (variantToEither (toVariant A :: Variant '[A,B]) == Right A) -   , testProperty "headVariant (match)"-         (headVariant (setVariant A :: ABC) == Right A)-   , testProperty "headVariant (don't match)"-         (isLeft (headVariant b))+   , testProperty "popVariantHead (match)"+         (popVariantHead (toVariant A :: ABC) == Right A)+   , testProperty "popVariantHead (don't match)"+         (isLeft (popVariantHead b)) -   , testProperty "pickVariant (match)"-         (pickVariant @1 b == Right B)-   , testProperty "pickVariant (don't match)"-         (isLeft (pickVariant @2 b))+   , testProperty "popVariantAt (match)"+         (popVariantAt @1 b == Right B)+   , testProperty "popVariantAt (don't match)"+         (isLeft (popVariantAt @2 b)) -   , testProperty "catchVariant (match)"-         (catchVariant @D (setVariantN @4 D :: Variant '[A,B,C,B,D,E,D]) == Right D)-   , testProperty "catchVariant (match)"-         (catchVariant @D (setVariantN @6 D :: Variant '[A,B,C,B,D,E,D]) == Right D)-   , testProperty "catchVariant (don't match)"-         (catchVariant @B (setVariantN @4 D :: Variant '[A,B,C,B,D,E,D]) == Left (setVariantN @2 D))+   , testProperty "popVariant (match)"+         (popVariant @D (toVariantAt @4 D :: Variant '[A,B,C,B,D,E,D]) == Right D)+   , testProperty "popVariant (match)"+         (popVariant @D (toVariantAt @6 D :: Variant '[A,B,C,B,D,E,D]) == Right D)+   , testProperty "popVariant (don't match)"+         (popVariant @B (toVariantAt @4 D :: Variant '[A,B,C,B,D,E,D]) == Left (toVariantAt @2 D))     , testProperty "prependVariant"-         (getVariantN @4 (prependVariant @'[D,E,F] b) == Just B)+         (fromVariantAt @4 (prependVariant @'[D,E,F] b) == Just B)    , testProperty "appendVariant"-         (getVariantN @1 (appendVariant @'[D,E,F] b)  == Just B)+         (fromVariantAt @1 (appendVariant @'[D,E,F] b)  == Just B) +   , testProperty "alterVariant"+         (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: Variant '[Int,Float]) == toVariant (2.0 :: Float))+   , testProperty "alterVariant"+         (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: Variant '[Float,Int]) == toVariant (2.0 :: Float))++   , testProperty "traverseVariant"+         (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing)+            (toVariant (2.0 :: Float) :: Variant '[Float,Int]) == Just (toVariant (2.0 :: Float)))+   , testProperty "traverseVariant"+         (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing)+            (toVariant (0.5 :: Float) :: Variant '[Float,Int]) == Nothing)+    , testProperty "liftVariant"-         (getVariant (liftVariant b :: Variant '[D,A,E,B,F,C])  == Just B)+         (fromVariant (liftVariant b :: Variant '[D,A,E,B,F,C])  == Just B)    ]++class (Ord a, Num a) => OrdNum a+instance (Ord a, Num a) => OrdNum a