diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/haskus-utils.cabal b/haskus-utils.cabal --- a/haskus-utils.cabal +++ b/haskus-utils.cabal @@ -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 diff --git a/src/lib/Haskus/Utils/Embed.hs b/src/lib/Haskus/Utils/Embed.hs --- a/src/lib/Haskus/Utils/Embed.hs +++ b/src/lib/Haskus/Utils/Embed.hs @@ -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|\ + \ + \Auto-generated html formated source\ + \ + \ + \ + \ \ + \|] +@ + +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 diff --git a/src/lib/Haskus/Utils/Flow.hs b/src/lib/Haskus/Utils/Flow.hs --- a/src/lib/Haskus/Utils/Flow.hs +++ b/src/lib/Haskus/Utils/Flow.hs @@ -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 diff --git a/src/lib/Haskus/Utils/List.hs b/src/lib/Haskus/Utils/List.hs --- a/src/lib/Haskus/Utils/List.hs +++ b/src/lib/Haskus/Utils/List.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Map/Strict.hs b/src/lib/Haskus/Utils/Map/Strict.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Map/Strict.hs @@ -0,0 +1,7 @@ +module Haskus.Utils.Map.Strict + ( module Data.Map.Strict + ) +where + +import Data.Map.Strict + diff --git a/src/lib/Haskus/Utils/Maybe.hs b/src/lib/Haskus/Utils/Maybe.hs --- a/src/lib/Haskus/Utils/Maybe.hs +++ b/src/lib/Haskus/Utils/Maybe.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Parser.hs b/src/lib/Haskus/Utils/Parser.hs --- a/src/lib/Haskus/Utils/Parser.hs +++ b/src/lib/Haskus/Utils/Parser.hs @@ -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') diff --git a/src/lib/Haskus/Utils/Solver.hs b/src/lib/Haskus/Utils/Solver.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Solver.hs @@ -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 + ] + + + diff --git a/src/lib/Haskus/Utils/Tuple.hs b/src/lib/Haskus/Utils/Tuple.hs --- a/src/lib/Haskus/Utils/Tuple.hs +++ b/src/lib/Haskus/Utils/Tuple.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Types.hs b/src/lib/Haskus/Utils/Types.hs --- a/src/lib/Haskus/Utils/Types.hs +++ b/src/lib/Haskus/Utils/Types.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Types/List.hs b/src/lib/Haskus/Utils/Types/List.hs --- a/src/lib/Haskus/Utils/Types/List.hs +++ b/src/lib/Haskus/Utils/Types/List.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs --- a/src/lib/Haskus/Utils/Variant.hs +++ b/src/lib/Haskus/Utils/Variant.hs @@ -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 ) diff --git a/src/tests/Haskus/Tests/Utils.hs b/src/tests/Haskus/Tests/Utils.hs --- a/src/tests/Haskus/Tests/Utils.hs +++ b/src/tests/Haskus/Tests/Utils.hs @@ -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 ] diff --git a/src/tests/Haskus/Tests/Utils/Solver.hs b/src/tests/Haskus/Tests/Utils/Solver.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Utils/Solver.hs @@ -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") diff --git a/src/tests/Haskus/Tests/Utils/Variant.hs b/src/tests/Haskus/Tests/Utils/Variant.hs --- a/src/tests/Haskus/Tests/Utils/Variant.hs +++ b/src/tests/Haskus/Tests/Utils/Variant.hs @@ -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