haskus-utils 1.4 → 1.5

raw patch · 16 files changed

+1113/−499 lines, 16 filesdep +doctestdep +freedep −extradep −file-embeddep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, free

Dependencies removed: extra, file-embed

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• haskus-utils.cabal +11/−5
• src/lib/Haskus/Utils/Dynamic.hs +55/−0
• src/lib/Haskus/Utils/Embed.hs +57/−59
• src/lib/Haskus/Utils/Flow.hs +106/−8
• src/lib/Haskus/Utils/Maths.hs +24/−0
• src/lib/Haskus/Utils/MonadFlow.hs +117/−0
• src/lib/Haskus/Utils/MonadStream.hs +117/−0
• src/lib/Haskus/Utils/MonadVar.hs +90/−0
• src/lib/Haskus/Utils/Parser.hs +0/−190
• src/lib/Haskus/Utils/STM.hs +11/−0
• src/lib/Haskus/Utils/STM/Future.hs +3/−1
• src/lib/Haskus/Utils/STM/SnapVar.hs +165/−0
• src/lib/Haskus/Utils/Solver.hs +263/−179
• src/lib/Haskus/Utils/TimedValue.hs +21/−0
• src/tests/Haskus/Tests/Utils/Solver.hs +46/−56
• src/tests/Main.hs +27/−1

@@ -1,5 +1,5 @@ name:                haskus-utils-version:             1.4+version:             1.5 synopsis:            Haskus utility modules license:             BSD3 license-file:        LICENSE@@ -21,11 +21,16 @@ library   exposed-modules:     Haskus.Utils.Solver-    Haskus.Utils.Parser     Haskus.Utils.HArray     Haskus.Utils.MultiState+    Haskus.Utils.Dynamic     Haskus.Utils.Embed     Haskus.Utils.Flow+    Haskus.Utils.Maths+    Haskus.Utils.MonadVar+    Haskus.Utils.MonadFlow+    Haskus.Utils.MonadStream+    Haskus.Utils.TimedValue     Haskus.Utils.STM     Haskus.Utils.STM.TEq     Haskus.Utils.STM.TMap@@ -34,6 +39,7 @@     Haskus.Utils.STM.TTree     Haskus.Utils.STM.Future     Haskus.Utils.STM.TGraph+    Haskus.Utils.STM.SnapVar    other-modules: @@ -50,11 +56,9 @@       ,  transformers              >= 0.4       ,  mtl                       >= 2.2       ,  template-haskell          >= 2.10-      ,  file-embed                >= 0.0.10-      ,  extra                     >= 1.4       ,  hashable                  >= 1.2+      ,  free -  build-tools:    ghc-options:          -Wall   default-language:     Haskell2010   hs-source-dirs:       src/lib@@ -75,3 +79,5 @@       ,  haskus-utils       ,  tasty                   >= 0.11       ,  tasty-quickcheck        >= 0.8+      ,  doctest+      ,  containers

@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++module Haskus.Utils.Dynamic+   ( -- * Dynamic+     module Data.Dynamic+   -- * Dynamic with equality+   , DynEq (..)+   , toDynEq+   , fromDynEq+   , fromDynEqMaybe+   )+where++import Data.Dynamic+import Type.Reflection++-- | Dynamic type with Eq and Ord instance+--+-- Can be used as Map keys for instance+data DynEq where+   DynEq :: forall a. (Eq a, Ord a) => TypeRep a -> a -> DynEq++instance Eq DynEq where+   (DynEq tra a) == (DynEq trb b) = case tra `eqTypeRep` trb of+      Nothing    -> False+      Just HRefl -> a == b++instance Ord DynEq where+   compare (DynEq tra a) (DynEq trb b) = case tra `eqTypeRep` trb of+      Nothing    -> compare (SomeTypeRep tra) (SomeTypeRep trb)+      Just HRefl -> compare a b++-- | Create a DynEq value+--+-- >>> toDynEq (10 :: Int) == toDynEq (12 :: Int)+-- False+-- >>> toDynEq (10 :: Int) <= toDynEq (12 :: Int)+-- True+-- >>> toDynEq (10 :: Int) /= toDynEq "Test"+-- True+toDynEq :: (Typeable a, Eq a, Ord a) => a -> DynEq+toDynEq a = DynEq typeRep a++-- | Get a value from a DynEq or the default one if the type doesn't match+fromDynEq :: Typeable a => DynEq -> a -> a+fromDynEq (DynEq tr a) def = case tr `eqTypeRep` typeOf def of+   Nothing    -> def+   Just HRefl -> a++-- | Get a value from a DynEq if the type matches+fromDynEqMaybe :: forall a. Typeable a => DynEq -> Maybe a+fromDynEqMaybe (DynEq tr a) = case tr `eqTypeRep` (typeRep :: TypeRep a) of+   Nothing    -> Nothing+   Just HRefl -> Just a

@@ -1,7 +1,6 @@ -- | Embed data into the executable binary module Haskus.Utils.Embed    ( embedBytes-   , module Data.FileEmbed    -- | Raw text quasiquoter    , raw    , rawQ@@ -10,59 +9,57 @@  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) +----------------------------------------------------------------------+-- Raw text quasiquoter (adapted from raw-strings-qq package (BSD3)+----------------------------------------------------------------------  -{-| Adapted from the raw-strings-qq package (BSD3)--A quasiquoter for raw string literals - that is, string literals that don't-recognise the standard escape sequences (such as @\'\\n\'@). Basically, they-make your code more readable by freeing you from the responsibility to escape-backslashes. They are useful when working with regular expressions, DOS/Windows-paths and markup languages (such as XML).--Don't forget the @LANGUAGE QuasiQuotes@ pragma if you're using this-module in your code.--Usage:--@-    ghci> :set -XQuasiQuotes-    ghci> import Text.RawString.QQ-    ghci> let s = [raw|\\w+\@[a-zA-Z_]+?\\.[a-zA-Z]{2,3}|]-    ghci> s-    \"\\\\w+\@[a-zA-Z_]+?\\\\.[a-zA-Z]{2,3}\"-    ghci> [raw|C:\\Windows\\SYSTEM|] ++ [raw|\\user32.dll|]-    \"C:\\\\Windows\\\\SYSTEM\\\\user32.dll\"-@--Multiline raw string literals are also supported:--@-    multiline :: String-    multiline = [raw|\<HTML\>-    \<HEAD\>-    \<TITLE\>Auto-generated html formated source\</TITLE\>-    \<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\"\>-    \</HEAD\>-    \<BODY LINK=\"#0000ff\" VLINK=\"#800080\" BGCOLOR=\"#ffffff\"\>-    \<P\> \</P\>-    \<PRE\>|]-@--Caveat: since the @\"|]\"@ character sequence is used to terminate the-quasiquotation, you can't use it inside the raw string literal. Use 'rawQ' if you-want to embed that character sequence inside the raw string.--}+-- |+--+-- 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:+--+-- > :set -XQuasiQuotes+-- > import Haskus.Utils.Embed+-- > let s = [raw|\\w+\@[a-zA-Z_]+?\\.[a-zA-Z]{2,3}|]+-- > s+-- \"\\\\w+\@[a-zA-Z_]+?\\\\.[a-zA-Z]{2,3}\"+-- > [raw|C:\\Windows\\SYSTEM|] ++ [raw|\\user32.dll|]+-- \"C:\\\\Windows\\\\SYSTEM\\\\user32.dll\"+--+-- Multiline raw string literals are also supported:+--+-- @+--     multiline :: String+--     multiline = [raw|\<HTML\>+--     \<HEAD\>+--     \<TITLE\>Auto-generated html formated source\</TITLE\>+--     \<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\"\>+--     \</HEAD\>+--     \<BODY LINK=\"#0000ff\" VLINK=\"#800080\" BGCOLOR=\"#ffffff\"\>+--     \<P\> \</P\>+--     \<PRE\>|]+-- @+--+-- Caveat: since the @\"|]\"@ character sequence is used to terminate the+-- quasiquotation, you can't use it inside the raw string literal. Use 'rawQ' if you+-- want to embed that character sequence inside the raw string. raw :: QuasiQuoter raw = QuasiQuoter {-    -- Extracted from dead-simple-json.     quoteExp  = return . LitE . StringL . normaliseNewlines,      quotePat  = \_ -> fail "illegal raw string QuasiQuote \@@ -73,21 +70,22 @@                            \(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||~~~~]|]-    \"|~~~]\"-@--}+-- | A variant of 'raw' that interprets the @\"|~]\"@ sequence as @\"|]\"@,+-- @\"|~~]\"@ as @\"|~]\"@ and, in general, @\"|~^n]\"@ as @\"|~^(n-1)]\"@+-- for n >= 1.+--+-- Usage:+--+--+-- > [rawQ||~]|~]|]+-- \"|]|]\"+--+-- > [rawQ||~~]|]+-- \"|~]\"+--+-- > [rawQ||~~~~]|]+-- \"|~~~]\"+-- rawQ :: QuasiQuoter rawQ = QuasiQuoter {     quoteExp  = return . LitE . StringL . escape_rQ . normaliseNewlines,

@@ -1,8 +1,12 @@+{-# LANGUAGE BangPatterns #-}+ -- | Control-flow module Haskus.Utils.Flow    ( MonadIO (..)    , MonadInIO (..)    -- * Basic operators+   , (>.>)+   , (<.<)    , (|>)    , (<|)    , (||>)@@ -34,62 +38,156 @@    , (>=>)    , loopM    , whileM+   , intersperseM_+   , forLoopM_+   , forLoop    -- * Variant based operators-   , module Haskus.Utils.Variant.Flow+   , module Haskus.Utils.Variant.Excepts    -- * Monad transformers    , lift    ) where  import Haskus.Utils.Variant-import Haskus.Utils.Variant.Flow+import Haskus.Utils.Variant.Excepts import Haskus.Utils.Monad import Haskus.Utils.Maybe  import Control.Monad.Trans.Class (lift) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies++-- | Compose functions+--+-- >>> (+1) >.> (*7) <| 1+-- 14+(>.>) :: (a -> b) -> (b -> c) -> a -> c+f >.> g = \x -> g (f x)++infixl 9 >.>++-- | Compose functions+--+-- >>> (+1) <.< (*7) <| 1+-- 8+(<.<) :: (b -> c) -> (a -> b) -> a -> c+f <.< g = \x -> f (g x)++infixr 9 <.<++ -- | Apply a function+--+-- >>> 5 |> (*2)+-- 10 (|>) :: a -> (a -> b) -> b-{-# INLINE (|>) #-}+{-# INLINABLE (|>) #-} x |> f = f x  infixl 0 |>  -- | Apply a function+--+-- >>> (*2) <| 5+-- 10 (<|) :: (a -> b) -> a -> b-{-# INLINE (<|) #-}+{-# INLINABLE (<|) #-} f <| x = f x  infixr 0 <|  -- | Apply a function in a Functor+--+-- >>> Just 5 ||> (*2)+-- Just 10 (||>) :: Functor f => f a -> (a -> b) -> f b-{-# INLINE (||>) #-}+{-# INLINABLE (||>) #-} x ||> f = fmap f x  infixl 0 ||>  -- | Apply a function in a Functor+--+-- >>> (*2) <|| Just 5+-- Just 10 (<||) :: Functor f => (a -> b) -> f a -> f b-{-# INLINE (<||) #-}+{-# INLINABLE (<||) #-} f <|| x = fmap f x  infixr 0 <||  -- | Apply a function in a Functor+--+-- >>> Just [5] |||> (*2)+-- Just [10] (|||>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)-{-# INLINE (|||>) #-}+{-# INLINABLE (|||>) #-} x |||> f = fmap (fmap f) x  infixl 0 |||>  -- | Apply a function in a Functor+--+-- >>> (*2) <||| Just [5]+-- Just [10]+-- (<|||) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)-{-# INLINE (<|||) #-}+{-# INLINABLE (<|||) #-} f <||| x = fmap (fmap f) x  infixr 0 <|||  -- | Composition of catMaybes and forM+-- +-- >>> let f x = if x > 3 then putStrLn "OK" >> return (Just x) else return Nothing+-- >>> forMaybeM [0..5] f+-- OK+-- OK+-- [4,5] forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] forMaybeM xs f = catMaybes <|| forM xs f++-- | forM_ with interspersed action+--+-- >>> intersperseM_ (putStr ", ") ["1","2","3","4"] putStr+-- 1, 2, 3, 4+intersperseM_ :: Monad m => m () -> [a] -> (a -> m ()) -> m ()+intersperseM_ f as g = go as+   where+      go []     = pure ()+      go [x]    = g x+      go (x:xs) = g x >> f >> go xs++-- | Fast for-loop in a Monad (more efficient than forM_ [0..n] for instance).+--+-- >>> forLoopM_ (0::Word) (<5) (+1) print+-- 0+-- 1+-- 2+-- 3+-- 4+forLoopM_ :: (Monad m) => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()+{-# INLINABLE forLoopM_ #-}+forLoopM_ start cond inc f = go start+   where+      go !x | cond x    = f x >> go (inc x)+            | otherwise = return ()+++-- | Fast fort-loop with an accumulated result+--+-- >>> let f acc n = acc ++ (if n == 0 then "" else ", ") ++ show n+-- >>> forLoop (0::Word) (<5) (+1) "" f+-- "0, 1, 2, 3, 4"+forLoop :: a -> (a -> Bool) -> (a -> a) -> acc -> (acc -> a -> acc) -> acc+{-# INLINABLE forLoop #-}+forLoop start cond inc acc0 f = go acc0 start+   where+      go acc !x+         | cond x    = let acc' = f acc x+                       in acc' `seq` go acc' (inc x)+         | otherwise = acc

@@ -0,0 +1,24 @@+module Haskus.Utils.Maths+   ( gcds+   , lcms+   )+where++-- | Return the GCD of a list of integrals+--+-- >>> gcds [2,4,8]+-- 2+gcds :: Integral a => [a] -> a+gcds []     = 1+gcds [0]    = 1+gcds [x]    = x+gcds (x:xs) = foldr gcd x xs++-- | Return the LCM of a list of integrals+--+-- >>> lcms [2,3,5]+-- 30+lcms :: Integral a => [a] -> a+lcms []     = 0+lcms [x]    = x+lcms (x:xs) = foldr lcm x xs

@@ -0,0 +1,117 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveFunctor #-}++-- | IO control-flow with cache+module Haskus.Utils.MonadFlow+   ( MonadFlowF (..)+   , MonadFlow+   , runMonadFlow+   , runM+   , withM+   , emitM+   -- * Cached control flow+   , CachedMonadFlow (..)+   , cacheMonadFlow+   , cacheMonadFlowPure+   , updateCachedMonadFlow+   , updateCachedMonadFlowMaybe+   , monadFlowToMonadTree+   )+where++import Haskus.Utils.Flow+import Haskus.Utils.MonadVar+import Haskus.Utils.MonadStream+import Control.Monad.Free++-- | MonadFlow Functor+data MonadFlowF m a e+   = MonadEmit a e                                               -- emit a pure value+   | forall v. Eq v => MonadRead (m v) (v -> e)                  -- read a monadic value and put it in the current scope+   | forall v. Eq v => MonadWith (m v) (v -> MonadFlow m a ()) e -- open a new scope and read a monadic value in it++type MonadFlow m a r = Free (MonadFlowF m a) r++instance Functor (MonadFlowF m a) where+   fmap f = \case+      MonadEmit a e   -> MonadEmit a (f e)+      MonadRead v g   -> MonadRead v (f . g)+      MonadWith v k e -> MonadWith v k (f e)++-- | Run an MonadFlow+runMonadFlow :: Monad m => MonadFlow m a r -> m (r,[a])+runMonadFlow = \case+   Free (MonadWith io f t) -> do+      val <- io+      (_,r1)  <- runMonadFlow (f val)+      (k2,r2) <- runMonadFlow t+      pure (k2, r1 <> r2)+   Free (MonadRead io f)  -> do+      val <- io+      runMonadFlow (f val)+   Free (MonadEmit a t)   -> do+      (k,as) <- runMonadFlow t+      pure (k,a:as)+   Pure k              ->+      pure (k,[])+++-- | Emit a pure value+emitM :: a -> MonadFlow m a ()+emitM a = liftF (MonadEmit a ())++-- | Get a variable in IO+--+-- Use `withM` to clearly limit the variable scope+runM :: forall m v a. (Eq v) => m v -> MonadFlow m a v+runM f = liftF (MonadRead f id)++-- | Read and use an IO variable in a delimited scope+withM :: Eq v => m v -> (v -> MonadFlow m a ()) -> MonadFlow m a ()+withM f g = liftF (MonadWith f g ())++------------------------------------------------+-- Cached control-flow+------------------------------------------------++-- | Cached control-flow+data CachedMonadFlow m a = CachedMonadFlow+   { cachedTree    :: [MonadTree m a]      -- ^ Cached control-flow as an MonadTree+   , cachedContext :: forall b. m b -> m b -- ^ Monadic context when performing an update (e.g. withSnapshot ctx)+   }+   deriving (Functor)++-- | Create a cache from an MonadFlow.+--+-- Execute the MonadFlow once to get cached values+cacheMonadFlow :: Monad m => (forall b. m b -> m b) -> MonadFlow m a r -> m (CachedMonadFlow m a)+cacheMonadFlow ctx cflow = updateCachedMonadFlow (cacheMonadFlowPure ctx cflow)++-- | Create a cache from an MonadFlow.+--+-- This is the pure version: IO dependent nodes may not have any cached value+cacheMonadFlowPure :: (forall b. m b -> m b) -> MonadFlow m a r -> CachedMonadFlow m a+cacheMonadFlowPure ctx f = (CachedMonadFlow (monadFlowToMonadTree f) ctx)++-- | Update a cached MonadFlow+updateCachedMonadFlow :: Monad m => CachedMonadFlow m a -> m (CachedMonadFlow m a)+updateCachedMonadFlow (CachedMonadFlow trees withCtx) = do+   trees' <- withCtx (forM trees updateMonadStream)+   pure (CachedMonadFlow trees' withCtx)++-- | Update a cached MonadFlow+updateCachedMonadFlowMaybe :: Monad m => CachedMonadFlow m a -> m (Maybe (CachedMonadFlow m a))+updateCachedMonadFlowMaybe (CachedMonadFlow trees withCtx) =+   withCtx (updateMonadStreamsMaybe trees)+   |||> (\ts -> CachedMonadFlow ts withCtx)++monadFlowToMonadTree :: MonadFlow m a r -> [MonadTree m a]+monadFlowToMonadTree = \case+   Free (MonadRead io f)   -> [ MonadStream (MonadVarNE [] Nothing io (monadFlowToMonadTree . f)) ]+   Free (MonadWith io f c) -> MonadStream (MonadVarNE [] Nothing io (monadFlowToMonadTree . f)):monadFlowToMonadTree c+   Free (MonadEmit a t)    -> PureStream a []:monadFlowToMonadTree t+   Pure _                  -> []+

@@ -0,0 +1,117 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BlockArguments #-}++-- | Monadic tree with cache+module Haskus.Utils.MonadStream+   ( MonadStream (..)+   , MonadTree+   , MonadList+   , showMonadStream+   , showMonadStreams+   , updateMonadStream+   , updateMonadStreamMaybe+   , updateMonadStreamsMaybe+   , updateMonadStreams+   )+where++import Haskus.Utils.Monad+import Haskus.Utils.MonadVar+import Haskus.Utils.Flow+import Haskus.Utils.Maybe++-- | Monadic stream with cache+--+-- Both the structure and the values may be monadically dependent. The last+-- monadic values read can be stored in a cache.+data MonadStream m n a+   = PureStream a (n (MonadStream m n a))                                   -- ^ Pure stream+   | forall s. Eq s => MonadStream (MonadVarNE m s (n (MonadStream m n a))) -- ^ Monadic stream++deriving instance Functor n => Functor (MonadStream m n)++-- | Monadic rose tree+type MonadTree m a = MonadStream m [] a++-- | Monadic list+type MonadList m a = MonadStream m Maybe a++-- | Pretty-show an MonadStream+showMonadStream ::+   ( Foldable n+   , Show a+   , Eq (n (MonadStream m n a))+   , Monoid (n (MonadStream m n a))+   ) => MonadStream m n a -> String+showMonadStream = go 0+   where+      indent n c      = replicate (2*n) ' ' <> c+      showNode n a ts = indent n "- " <> show a <> "\n" <> concatMap (go (n+1)) ts+      go n = \case+         PureStream a ts                 -> showNode n a ts+         MonadStream (MonadVarNE ts _ _ _)+            | ts == mempty -> indent n "{}\n"+            | otherwise    -> indent n "{\n" <> concatMap (go (n+1)) ts <> indent n "}\n"++-- | Pretty-show some MonadStreams+showMonadStreams ::+   ( Foldable n+   , Show a+   , Eq (n (MonadStream m n a))+   , Monoid (n (MonadStream m n a))+   ) => n (MonadStream m n a) -> String+showMonadStreams = concatMap showMonadStream++-- | Update a MonadStream recursively. Reuse cached values when possible+updateMonadStream ::+   ( Monad m+   , Traversable n+   ) => MonadStream m n a -> m (MonadStream m n a)+updateMonadStream t = updateMonadStreamMaybe t+   ||> fromMaybe t++-- | Update a MonadStream recursively. Reuse cached values when possible+updateMonadStreamMaybe ::+   ( Monad m+   , Traversable n+   ) => MonadStream m n a -> m (Maybe (MonadStream m n a))+updateMonadStreamMaybe = go False+   where+      go False (PureStream a ts) = PureStream a <||| updateMonadStreamsMaybe ts+      go True  (PureStream a ts) = Just <|| PureStream a <|| updateMonadStreams ts+      go True (MonadStream dv) = do+            (MonadVarNE ts' ms' io f) <- updateMonadVarNE dv+            ts'' <- updateMonadStreams ts'+            pure (Just (MonadStream (MonadVarNE ts'' ms' io f)))+      go False (MonadStream dv@(MonadVarNE ts ms io f)) = do+            mcdv <- updateMonadVarNEMaybe dv+            case mcdv of+               Nothing -> updateMonadStreamsMaybe ts+                          |||> (\ts' -> MonadStream (MonadVarNE ts' ms io f))+               Just (MonadVarNE ts' ms' _ _) -> do+                  ts'' <- updateMonadStreams ts'+                  pure (Just (MonadStream (MonadVarNE ts'' ms' io f)))++-- | Update a MonadStream forest recursively. Reuse cached values when possible+updateMonadStreamsMaybe ::+   ( Monad m+   , Traversable n+   ) => n (MonadStream m n a) -> m (Maybe (n (MonadStream m n a)))+updateMonadStreamsMaybe ns = do+   ns' <- forM ns \n -> do+      mu <- updateMonadStreamMaybe n+      pure (n,mu)+   if all (isNothing . snd) ns'+      then pure Nothing+      else pure (Just (fmap fst ns'))++-- | Update a MonadStream forest recursively+updateMonadStreams ::+   ( Monad m+   , Traversable n+   ) => n (MonadStream m n a) -> m (n (MonadStream m n a))+updateMonadStreams ns = updateMonadStreamsMaybe ns+   ||> fromMaybe ns

@@ -0,0 +1,90 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BlockArguments #-}++-- | Monadic variable with cache+module Haskus.Utils.MonadVar+   ( MonadVar (..)+   , updateMonadVarForce+   , updateMonadVarMaybe+   , updateMonadVar+   -- * Non-empty+   , MonadVarNE (..)+   , updateMonadVarNEMaybe+   , updateMonadVarNE+   )+where++import Haskus.Utils.Flow+import Haskus.Utils.Maybe++-- | A value that can be read with IO. The last read can be cached in it too.+--+-- We store both the read value (type s) and a pure modifier function (s -> a).+-- By doing this we can easily compare a read value to the cached one without+-- performing extra computations. The functor instance compose with the modifier+-- function.+--+-- The supposedly costly modifier function is applied lazily+data MonadVar m s a+   = MonadVar !(m s) (s -> a)            -- ^ IO accessor + modifier function+   | CachedMonadVar a !s !(m s) (s -> a) -- ^ Additional cached transformed and read values.+   deriving (Functor)++-- | Check if the MonadVar cache needs to be updated.+--+-- Invariably produce an MonadVar with cached values or Nothing if the old one+-- hasn't changed.+updateMonadVarMaybe :: (Monad m, Eq s) => MonadVar m s a -> m (Maybe (MonadVar m s a))+updateMonadVarMaybe dv@(MonadVar {}) = Just <|| updateMonadVarForce dv+updateMonadVarMaybe (CachedMonadVar _ s io f) = do+   s' <- io+   if s == s'+      then pure Nothing+      else pure <| Just <| CachedMonadVar (f s') s' io f++-- | Check if the MonadVar cache needs to be updated. Return the updated MonadVar.+--+-- Invariably produce an MonadVar with cached values.+updateMonadVar :: (Monad m, Eq s) => MonadVar m s a -> m (MonadVar m s a)+updateMonadVar dv = fromMaybe dv <|| updateMonadVarMaybe dv++-- | Update an MonadVar without comparing to the cache even if it is available.+--+-- Invariably produce an MonadVar with cached values.+updateMonadVarForce :: (Monad m, Eq s) => MonadVar m s a -> m (MonadVar m s a)+updateMonadVarForce (CachedMonadVar _ _ io f) = do+   s <- io+   pure (CachedMonadVar (f s) s io f)+updateMonadVarForce (MonadVar io f) = do+   s <- io+   pure (CachedMonadVar (f s) s io f)++++----------------------------------+-- Non-empty MonadVar+----------------------------------+++-- Non-empty MonadVar+--+-- The value may be set purely if the source is Nothing+data MonadVarNE m s a+   = MonadVarNE a !(Maybe s) !(m s) (s -> a) -- ^ Additional cached transformed and read values.+   deriving (Functor)++-- | Check if the MonadVarNE cache needs to be updated.+updateMonadVarNEMaybe :: (Monad m, Eq s) => MonadVarNE m s a -> m (Maybe (MonadVarNE m s a))+updateMonadVarNEMaybe (MonadVarNE _ ms io f) = do+   s' <- io+   pure case ms of+      Just s | s == s' -> Nothing+      _                -> Just <| MonadVarNE (f s') (Just s') io f++-- | Check if the MonadVarNE cache needs to be updated. Return the updated+-- MonadVarNE+updateMonadVarNE :: (Monad m, Eq s) => MonadVarNE m s a -> m (MonadVarNE m s a)+updateMonadVarNE dv = fromMaybe dv <|| updateMonadVarNEMaybe dv

@@ -1,190 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeOperators #-}---- | Tools to write parsers using Flows-module Haskus.Utils.Parser-   ( ParseError (..)-   , Choice (..)-   , choice-   , choice'-   , manyBounded-   , manyAtMost-   , manyAtMost'-   , manyAtMost''-   , many-   , manyAtLeast-   , manyTill-   , manyTill'-   )-where--import Prelude hiding (min,max)-import Haskus.Utils.HList-import Haskus.Utils.Types.List-import Haskus.Utils.Variant.OldFlow-import Haskus.Utils.Variant----- A parser is a Flow function that can either:---    - return a parsed value or a semantic error---    - fail with a ParseError:---       - not enough input---       - syntax error------- | Parser error-data ParseError-   = SyntaxError-   | EndOfInput-   deriving (Show,Eq)---- We can define combinators between parsers--data Choice a = Choice--instance forall x y z xs ys zs m a.-      ( x ~ Flow m xs-      , y ~ Flow m ys-      , z ~ Flow m zs-      , a :< xs-      , LiftVariant ys zs-      , LiftVariant (Remove a xs) zs-      , zs ~ Union (Remove a xs) ys-      , Monad m-      ) => Apply (Choice a) (x,y) z-   where-      apply _ (x,y) = x >%~|> \(_ :: a) -> y---- | Try to apply the actions in the list in order, until one of them succeeds.--- Returns the value of the succeeding action, or the value of the last one.--- Failures are detected with values of type "ParseError".-choice :: forall m fs zs.-   ( Monad m-   , HFoldl (Choice ParseError) (Flow m '[ParseError]) fs (Flow m zs)-   ) => HList fs -> Flow m zs-choice = choice' @ParseError---- | Try to apply the actions in the list in order, until one of them succeeds.--- Returns the value of the succeeding action, or the value of the last one.--- Failures are detected with values of type "a".-choice' :: forall a m fs zs.-   ( Monad m-   , HFoldl (Choice a) (Flow m '[a]) fs (Flow m zs)-   ) => HList fs -> Flow m zs-choice' = hFoldl (Choice :: Choice a) (flowSingle undefined :: Flow m '[a])---- | Apply the action zero or more times (until a ParseError result is--- returned)-many ::-   ( zs ~ Remove ParseError xs-   , Monad m-   , ParseError :< xs-   ) => Flow m xs -> Flow m '[[V zs]]-many f = manyBounded Nothing Nothing f-            >%~^> \(_ :: ParseError) -> flowSingle []---- | Apply the action zero or more times (up to max) until a ParseError result--- is returned-manyAtMost ::-   ( zs ~ Remove ParseError xs-   , Monad m-   , ParseError :< xs-   ) => Word -> Flow m xs -> Flow m '[[V zs]]-manyAtMost max f = manyBounded Nothing (Just max) f-                     >%~^> \(_ :: ParseError) -> flowSingle []---- | Apply the action zero or more times (up to max) until a ParseError result--- is returned-manyAtMost' ::-   ( zs ~ Remove ParseError xs-   , Monad m-   , ParseError :< xs-   ) => Word -> Flow m xs -> m [V zs]-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] ~ Remove ParseError xs-   , Monad m-   , ParseError :< xs-   ) => Word -> Flow m xs -> m [x]-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 ~ Remove ParseError xs-   , Monad m-   , ParseError :< xs-   ) => Word -> Flow m xs -> Flow m '[[V zs],ParseError]-manyAtLeast min = manyBounded (Just min) Nothing---- | Apply the first action zero or more times until the second succeeds.--- If the first action fails, the whole operation fails.------ Return both the list of first values and the ending value-manyTill ::-   ( zs ~ Remove ParseError xs-   , zs' ~ Remove ParseError ys-   , Monad m-   , ParseError :<? xs-   , ParseError :< ys-   ) => Flow m xs -> Flow m ys -> Flow m '[([V zs],V zs'),ParseError]-manyTill f g = go []-   where-      go xs = do-         v <- g-         case popVariant v of-            Right EndOfInput  -> flowSet EndOfInput-            Right SyntaxError -> do-               u <- f-               case popVariantMaybe u of-                  Right (e :: ParseError) -> flowSet e-                  Left x                  -> go (x:xs)-            Left x            -> flowSet (reverse xs,x)---- | Apply the first action zero or more times until the second succeeds.--- If the first action fails, the whole operation fails.------ Return only the list of first values-manyTill' ::-   ( zs ~ Remove ParseError xs-   , Monad m-   , ParseError :<? xs-   , ParseError :< ys-   ) => Flow m xs -> Flow m ys -> Flow m '[[V zs],ParseError]-manyTill' f g = manyTill f g >.-.> fst---- | Apply the given action at least 'min' times and at most 'max' time------ On failure, fails.-manyBounded :: forall zs xs m.-   ( zs ~ Remove ParseError xs-   , Monad m-   , ParseError :<? xs-   ) => Maybe Word -> Maybe Word -> Flow m xs -> Flow m '[[V zs],ParseError]-manyBounded _ (Just 0) _   = flowSet ([] :: [V zs])-manyBounded (Just 0) max f = manyBounded Nothing max f-manyBounded min max f      = do-   v <- f-   case popVariantMaybe v of-      Right (e :: ParseError) -> case min of-         Just n | n > 0 -> flowSet e-         _              -> flowSet ([] :: [V zs])-      Left x           -> do-         let minus1 = fmap (\k -> k - 1)-         xs <- manyBounded (minus1 min) (minus1 max) f-         case variantToEither xs of-            Left (e :: ParseError) -> flowSet e-            Right xs'              -> flowSet (x : xs')-

@@ -8,9 +8,11 @@    , newTVarIO    , readTVarIO    , S.writeTVar+   , writeTVarIO    , S.readTVar    , S.newTVar    , S.swapTVar+   , swapTVarIO    , S.modifyTVar    , S.modifyTVar'    -- ** TMVar@@ -32,6 +34,7 @@    , S.newBroadcastTChan    , S.writeTChan    , S.dupTChan+   , S.cloneTChan    , S.readTChan    ) where@@ -47,6 +50,14 @@ -- | Read a TVar in an IO monad readTVarIO :: MonadIO m => TVar a -> m a readTVarIO = liftIO . S.readTVarIO++-- | Write a TVar in an IO monad+writeTVarIO :: MonadIO m => TVar a -> a -> m ()+writeTVarIO v a = atomically (S.writeTVar v a)++-- | Swap a TVar in an IO monad+swapTVarIO :: MonadIO m => TVar a -> a -> m a+swapTVarIO v a = atomically (S.swapTVar v a)  -- | Create a broadcast channel newBroadcastTChanIO :: MonadIO m => m (TChan a)

@@ -30,7 +30,9 @@  -- | `newFuture` in `IO` newFutureIO :: MonadIO m => m (Future a, FutureSource a)-newFutureIO = atomically newFuture+newFutureIO = do+   m <- liftIO newEmptyTMVarIO+   return (Future m, FutureSource m)  -- | Set a future setFuture :: a -> FutureSource a -> STM ()

@@ -0,0 +1,165 @@+-- | Snapshotable STM variables+--+-- A `SnapVar` is like a `TVar` except that they have a context which can+-- enable a snapshot mode. When in snapshot mode, the current values are not+-- erased by writes. Instead each SnapVar can have 2 values: the value at the+-- time of the snapshot and its current value.+--+-- There can be only a single snapshot at a time. When the snapshot mode is+-- exited, the variables only keep the current value alive, not the snapshot+-- one.+--+module Haskus.Utils.STM.SnapVar+   ( SnapVar+   , SnapContext+   , newSnapContextIO+   , newSnapContext+   , newSnapVarIO+   , newSnapVar+   , writeSnapVar+   , writeSnapVarIO+   , readSnapVar+   , readSnapVarIO+   , modifySnapVar+   , modifySnapVarIO+   -- * Snapshot+   , withSnapshot+   , readSnapshot+   , readSnapshotIO+   )+where++import Haskus.Utils.STM+import Haskus.Utils.Monad++-- | A snapshot variable+data SnapVar a = SnapVar+   { snapContext   :: !SnapContext      -- ^ Snapshot context+   , snapValue     :: !(TVar a)         -- ^ Snapshot value (during snapshot) or current value (otherwise)+   , snapNextValue :: !(TVar (Maybe a)) -- ^ Next value (during snapshot)+   }++-- | Snapshot context+data SnapContext = SnapContext+   { snapContextState    :: !(TVar SnapState) -- ^ Snapshot state+   , snapContextUpdaters :: !(TVar [STM ()])  -- ^ Variable updaters (on snapshot exit)+   }++-- | Snapshot state+data SnapState+   = NoSnapshot   -- ^ No snapshot active+   | Snapshot     -- ^ Snapshot active+   | SnapshotExit -- ^ Exiting the snapshot+++-- | Create a new snapshot context+newSnapContextIO :: MonadIO m => m SnapContext+newSnapContextIO = SnapContext <$> newTVarIO NoSnapshot <*> newTVarIO []++-- | Create a new snapshot context+newSnapContext :: STM SnapContext+newSnapContext = SnapContext <$> newTVar NoSnapshot <*> newTVar []++-- | Create a new SnapVar+newSnapVarIO :: MonadIO m => SnapContext -> a -> m (SnapVar a)+newSnapVarIO ctx v = SnapVar <$> return ctx <*> newTVarIO v <*> newTVarIO Nothing++-- | Create a new SnapVar+newSnapVar :: SnapContext -> a -> STM (SnapVar a)+newSnapVar ctx v = SnapVar <$> return ctx <*> newTVar v <*> newTVar Nothing++-- | Write a SnapVar+writeSnapVar :: SnapVar a -> a -> STM ()+writeSnapVar v a = do+   state <- readTVar (snapContextState (snapContext v))+   case state of+      NoSnapshot   -> writeTVar (snapValue v) a+      SnapshotExit -> do+         writeTVar (snapValue v) a+         -- update next-value too to be sure that no updater will erase our+         -- value and that a future read will be correct+         writeTVar (snapNextValue v) Nothing+      Snapshot     -> do+         -- write into next-value and get old value+         mv <- swapTVar (snapNextValue v) (Just a)+         -- install value updater on exit (if not already done)+         case mv of+            Just _  -> return () -- value updater already installed+            Nothing -> modifyTVar (snapContextUpdaters (snapContext v)) (updateSnapVar v:)++-- | SnapVar updater (on snapshot exit, for variable written during the snapshot)+updateSnapVar :: SnapVar a -> STM ()+updateSnapVar v = do+   -- read fresh value+   nv <- readTVar (snapNextValue v)+   writeTVar (snapNextValue v) Nothing+   case nv of+      Just val -> writeTVar (snapValue v) val+      Nothing  -> return () -- nothing to do, a writer has already done this before us++-- | Write a SnapVar+writeSnapVarIO :: MonadIO m => SnapVar a -> a -> m ()+writeSnapVarIO v a = atomically (writeSnapVar v a)++-- | Read a SnapVar+readSnapVar :: SnapVar a -> STM a+readSnapVar v = do+   state <- readTVar (snapContextState (snapContext v))+   case state of+      NoSnapshot -> readTVar (snapValue v)+      _          -> do+         -- in the SnapshotExit case we could update the value here if+         -- necessary, but an updater will eventually do it so we don't bother+         mv <- readTVar (snapNextValue v)+         case mv of+            Just a  -> return a+            Nothing -> readTVar (snapValue v)++-- | Read a SnapVar+readSnapVarIO :: MonadIO m => SnapVar a -> m a+readSnapVarIO v = atomically (readSnapVar v)++-- | Modify a SnapVar+modifySnapVar :: SnapVar a -> (a -> a) -> STM a+modifySnapVar v f = do+   old <- readSnapVar v+   writeSnapVar v (f old)+   return old++-- | Modify a SnapVar+modifySnapVarIO :: MonadIO m => SnapVar a -> (a -> a) -> m a+modifySnapVarIO v f = atomically (modifySnapVar v f)++-- | Read the snapshot value of the variable.+--+-- Must be used in the context of a `withSnapshot`+readSnapshotIO :: MonadIO m => SnapVar a -> m a+readSnapshotIO v = readTVarIO (snapValue v)++-- | Read the snapshot value of the variable.+--+-- Must be used in the context of a `withSnapshot`+readSnapshot :: SnapVar a -> STM a+readSnapshot v = readTVar (snapValue v)++-- | Use a snapshot+withSnapshot :: MonadIO m => SnapContext -> m r -> m r+withSnapshot ctx action = do+   -- enable snapshot+   old <- swapTVarIO (snapContextState ctx) Snapshot+   case old of+      NoSnapshot -> return ()+      _          -> error "withSnapshot: invalid snapshot state"++   +   -- use the snapshot+   r <- action++   -- finalize snapshot +   writeTVarIO (snapContextState ctx) SnapshotExit -- in SnapshotExit state, no new updaters can be added to the list+   updaters <- readTVarIO (snapContextUpdaters ctx)+   forM_ updaters atomically -- run updaters one by one instead of all at once to have small transactions++   writeTVarIO (snapContextState ctx) NoSnapshot++   return r

@@ -15,19 +15,21 @@    , makeOracle    , oraclePredicates    , emptyOracle+   , oracleUnion    , predIsSet    , predIsUnset    , predIsUndef+   , predIsInvalid    , predIs    , predState+   , predAdd    -- * Constraint    , Constraint (..)-   , simplifyConstraint-   , constraintReduce+   , constraintOptimize+   , constraintSimplify    -- * Rule    , Rule (..)-   , orderedNonTerminal-   , mergeRules+   , ruleSimplify    , evalsTo    , MatchResult (..)    -- * Predicated data@@ -45,11 +47,18 @@ import Haskus.Utils.Map.Strict (Map) import qualified Haskus.Utils.Map.Strict as Map -import Data.Bits import Control.Arrow (first,second)+import Data.Set (Set)+import qualified Data.Set as Set -import Prelude hiding (pred)+import Prelude hiding (pred,length) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies+ ------------------------------------------------------- -- Constraint -------------------------------------------------------@@ -59,6 +68,7 @@    = SetPred       -- ^ Set predicate    | UnsetPred     -- ^ Unset predicate    | UndefPred     -- ^ Undefined predicate+   | InvalidPred   -- ^ Invalid predicate (can't be used)    deriving (Show,Eq,Ord)  -- | Predicate oracle@@ -76,6 +86,10 @@ predIsUndef :: Ord p => PredOracle p -> p -> Bool predIsUndef oracle p = predIs oracle p UndefPred +-- | Ask an oracle if a predicate is invalid+predIsInvalid :: Ord p => PredOracle p -> p -> Bool+predIsInvalid oracle p = predIs oracle p InvalidPred+ -- | Check the state of a predicate predIs :: Ord p => PredOracle p -> p -> PredState -> Bool predIs oracle p s = predState oracle p == s@@ -90,10 +104,21 @@ makeOracle :: Ord p => [(p,PredState)] -> PredOracle p makeOracle = Map.fromList --- | Get a list of predicates from an oracle+-- | Get a list of valid and defined predicates from an oracle oraclePredicates :: Ord p => PredOracle p -> [(p,PredState)] oraclePredicates = filter (\(_,s) -> s /= UndefPred) . Map.toList +-- | Combine two oracles+-- TODO: check that there is no contradiction+oracleUnion :: Ord p => PredOracle p -> PredOracle p -> PredOracle p+oracleUnion = Map.union++-- | Add predicates to an oracle+-- TODO: check that there is no contradiction+predAdd :: Ord p => [(p,PredState)] -> PredOracle p -> PredOracle p+predAdd cs = oracleUnion (makeOracle cs)++ -- | Oracle that always answer Undef emptyOracle :: PredOracle p emptyOracle = Map.empty@@ -102,50 +127,82 @@ -- Constraint ------------------------------------------------------- +-- | A constraint is a boolean expression+--+-- `p` is the predicate type data Constraint e p-   = Predicate p-   | Not (Constraint e p)-   | And [Constraint e p]-   | Or  [Constraint e p]-   | Xor [Constraint e p]-   | CBool Bool+   = Predicate p            -- ^ Predicate value+   | IsValid p              -- ^ Is the predicate valid+   | Not (Constraint e p)   -- ^ Logic not+   | And [Constraint e p]   -- ^ Logic and+   | Or  [Constraint e p]   -- ^ Logic or+   | Xor [Constraint e p]   -- ^ Logic xor+   | CBool Bool             -- ^ Constant+   | CErr (Either String e) -- ^ Error    deriving (Show,Eq,Ord)  instance Functor (Constraint e) where    fmap f (Predicate p)  = Predicate (f p)+   fmap f (IsValid   p)  = IsValid (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)+   fmap _ (CErr e)       = CErr e  -- | 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+--+-- >>> data P = A | B deriving (Show,Eq,Ord)+-- >>> let c = And [IsValid A, Predicate B]+--+-- >>> let oracle = makeOracle [(A,InvalidPred),(B,SetPred)]+-- >>> constraintSimplify oracle c+-- CBool False+--+-- >>> let oracle = makeOracle [(A,SetPred),(B,SetPred)]+-- >>> constraintSimplify oracle c+-- CBool True+--+-- >>> let oracle = makeOracle [(A,SetPred),(B,UnsetPred)]+-- >>> constraintSimplify oracle c+-- CBool False+constraintSimplify :: (Ord p, Eq p, Eq e) => PredOracle p -> Constraint e p -> Constraint e p+constraintSimplify oracle c = case constraintOptimize c of+   CErr e       -> CErr e+   IsValid p    -> case predState oracle p of+                     UndefPred   -> IsValid p+                     InvalidPred -> CBool False+                     SetPred     -> CBool True+                     UnsetPred   -> CBool True    Predicate p  -> case predState oracle p of-                      UndefPred -> Predicate p-                      SetPred   -> CBool True-                      UnsetPred -> CBool False-   Not c'       -> case constraintReduce oracle c' of+                      UndefPred   -> Predicate p+                      InvalidPred -> CErr (Left "Invalid predicate")+                      SetPred     -> CBool True+                      UnsetPred   -> CBool False+   Not c'       -> case constraintSimplify oracle c' of                       CBool v -> CBool (not v)+                      CErr e  -> CErr e                       c''     -> Not c''-   And cs       -> case fmap (constraintReduce oracle) cs of-                      []                                     -> error "Empty And constraint"+   And cs       -> case fmap (constraintSimplify oracle) cs of+                      []                                     -> CErr (Left "Empty And constraint")                       cs' | all (constraintIsBool True)  cs' -> CBool True                       cs' | any (constraintIsBool False) cs' -> CBool False+                      cs' | all constraintIsError cs'        -> CErr (Left "And expression only contains Error constraints")                       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"+   Or cs        -> case filter (not . constraintIsError) <| fmap (constraintSimplify oracle) cs of+                      []                                      -> CErr (Left "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')+   Xor cs       -> case fmap (constraintSimplify oracle) cs of+                      cs' | any constraintIsError cs' -> CErr (Left "Xor expression contains Error constraint")+                      []                              -> CErr (Left "Empty Xor constraint")+                      cs'                             -> constraintOptimize (Xor cs')    c'@(CBool _) -> c'  -- | Check that a constraint is evaluated to a given boolean value@@ -153,102 +210,87 @@ constraintIsBool v (CBool v') = v == v' constraintIsBool _ _          = False +-- | Check that a constraint is evaluated to an error+constraintIsError :: Constraint e p -> Bool+constraintIsError (CErr _) = True+constraintIsError _        = False+ -- | Get predicates used in a constraint-getConstraintPredicates :: Constraint e p -> [p]+getConstraintPredicates :: Ord p => Constraint e p -> Set p getConstraintPredicates = \case-   Predicate p  -> [p]+   CErr _       -> Set.empty+   IsValid   p  -> Set.singleton p+   Predicate p  -> Set.singleton p    Not c        -> getConstraintPredicates c-   And cs       -> concatMap getConstraintPredicates cs-   Or  cs       -> concatMap getConstraintPredicates cs-   Xor cs       -> concatMap getConstraintPredicates cs-   CBool _      -> []+   And cs       -> Set.unions $ fmap getConstraintPredicates cs+   Or  cs       -> Set.unions $ fmap getConstraintPredicates cs+   Xor cs       -> Set.unions $ fmap getConstraintPredicates cs+   CBool _      -> Set.empty  -- | Get constraint terminals-getConstraintTerminals :: Constraint e p -> [Bool]+getConstraintTerminals :: Constraint e p -> Set Bool getConstraintTerminals = \case-   Predicate _  -> [True,False]-   CBool v      -> [v]-   Not c        -> fmap not (getConstraintTerminals c)+   CErr _       -> Set.empty+   IsValid   _  -> tf+   Predicate _  -> tf+   CBool v      -> Set.singleton v+   Not c        -> Set.map 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]+                   in if | null cs                         -> Set.empty+                         | any (False `elem`) cs'          -> Set.singleton False+                         | all (== Set.singleton True) cs' -> Set.singleton True+                         | otherwise                       -> tf    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                -> []+                   in if | null cs                          -> Set.empty+                         | any (True `elem`) cs'            -> Set.singleton True+                         | all (== Set.singleton False) cs' -> Set.singleton False+                         | otherwise                        -> tf+   Xor cs       -> let cs' = fmap (Set.toList . getConstraintTerminals) cs+                   in if | null cs                -> Set.empty                          | otherwise              -> xo False cs'    where-      xo t     []           = [t]+      tf = Set.fromList [True,False]++      xo t     []           = Set.singleton t       xo False ([True]:xs)  = xo True xs-      xo True  ([True]:_)   = [False]+      xo True  ([True]:_)   = Set.singleton 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+      xo _     ([]:_)       = Set.empty+      xo _     _            = tf --- | Simplify a constraint-simplifyConstraint :: Constraint e p -> Constraint e p-simplifyConstraint x = case x of+-- | Optimize/simplify a constraint+constraintOptimize :: Constraint e p -> Constraint e p+constraintOptimize x = case x of+   CErr _            -> x+   Not (CErr e)      -> CErr e+   IsValid _         -> x    Predicate _       -> x    CBool _           -> x+   Not (IsValid _)   -> 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+   Not (Not c)       -> constraintOptimize c+   Not (Or cs)       -> constraintOptimize (And (fmap Not cs))+   Not (And cs)      -> constraintOptimize (Or (fmap Not cs))+   Not (Xor cs)      -> case constraintOptimize (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+                           r       -> constraintOptimize (Not r)+   And [c]           -> constraintOptimize c+   Or  [c]           -> constraintOptimize c+   Xor [c]           -> let c' = constraintOptimize c                         in if | constraintIsBool True c'  -> CBool True                               | constraintIsBool False c' -> CBool False                               | otherwise                 -> c'-   And cs            -> let cs' = fmap simplifyConstraint cs+   And cs            -> let cs' = fmap constraintOptimize 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+   Or cs             -> let cs' = fmap constraintOptimize 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+   Xor cs            -> let cs'        = fmap constraintOptimize cs                             countTrue  = length (filter (constraintIsBool True) cs')                             countFalse = length (filter (constraintIsBool False) cs')                             countAll   = length cs'@@ -257,46 +299,78 @@                               | 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++-------------------------------------------------------+-- Rule+-------------------------------------------------------++-- | A rule can produce some "a"s (one or more if it diverges), depending on the+-- constraints.+data Rule e p a+   = Terminal a+   | OrderedNonTerminal [(Constraint e p, Rule e p 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 f (OrderedNonTerminal xs) = OrderedNonTerminal (fmap (second (fmap f)) xs)+   fmap _ (Fail e)                = Fail e+++-- | Simplify a rule given an oracle+ruleSimplify ::+   ( Ord p, Eq e+   ) => PredOracle p -> Rule e p a -> Rule e p a+ruleSimplify oracle r = case r of+   Terminal a            -> Terminal a+   Fail e                -> Fail e+   OrderedNonTerminal rs -> OrderedNonTerminal (simplifyNonTerminal rs)+   NonTerminal rs        -> NonTerminal (concatMap foldNonTerminal (simplifyNonTerminal rs))    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)+      -- Simplify non-terminal rule constraints. Remove rules whose constraint is False+      simplifyNonTerminal xs = xs+         -- reduce constraints+         |> fmap (first (constraintSimplify oracle))+         -- recursively simplify nested rules+         |> fmap (second (ruleSimplify oracle))+         -- filter non matching rules+         |> filter (not . constraintIsBool False . fst) -      fl x = fmap (second (x `mergeRules`))-      fr x = fmap (second (`mergeRules` x))+      -- non terminal sub-rules whose constraints are True can be folded into the+      -- upper non-terminal rule. We rely on this to perform rule reduction.+      foldNonTerminal (c, NonTerminal rs)+         | constraintIsBool True c = rs+      foldNonTerminal x = [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]+ruleReduce oracle r = case ruleSimplify oracle r of+   Terminal a            -> Match a+   Fail e                -> MatchFail [e]+   NonTerminal []        -> NoMatch+   OrderedNonTerminal [] -> NoMatch+   OrderedNonTerminal ((c,x):xs)+      | constraintIsBool True c  -> ruleReduce oracle x+      | constraintIsBool False c -> ruleReduce oracle (OrderedNonTerminal xs)+      | otherwise                -> DontMatch (OrderedNonTerminal ((c,x):xs))    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'+         (matchingRules,mayMatchRules) = partition (constraintIsBool True . fst) rs          matchingResults               = nub $ fmap snd $ matchingRules  -         (failingResults,terminalResults,nonTerminalResults) = go [] [] [] matchingResults+         (failingResults,terminalResults,hasNonTerminalResults) = go [] [] False 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+            []                        -> (fr,tr,ntr)+            (Fail x:xs)               -> go (x:fr) tr ntr  xs+            (Terminal x:xs)           -> go fr (x:tr) ntr  xs+            (NonTerminal _:xs)        -> go fr tr     True xs+            (OrderedNonTerminal _:xs) -> go fr tr     True xs           divergence = case terminalResults of             -- results are already "nub"ed.@@ -304,39 +378,32 @@             (_:_:_) -> 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')+      if | not (null failingResults)     -> MatchFail failingResults+         | divergence                    -> MatchDiverge (fmap Terminal terminalResults)+         | hasNonTerminalResults         -> DontMatch (NonTerminal rs)+         | otherwise                     ->+            case (terminalResults,mayMatchRules) of+               ([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+getRuleTerminals :: Ord a => Rule e p a -> Set a+getRuleTerminals (Fail _)                = Set.empty+getRuleTerminals (Terminal a)            = Set.singleton a+getRuleTerminals (NonTerminal xs)        = Set.unions (fmap (getRuleTerminals . snd) xs)+getRuleTerminals (OrderedNonTerminal xs) = Set.unions (fmap (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+getRulePredicates :: (Eq p,Ord p) => Rule e p a -> Set p+getRulePredicates (Fail _)                = Set.empty+getRulePredicates (Terminal _)            = Set.empty+getRulePredicates (NonTerminal xs)        = Set.unions $ fmap (\(x,y) -> getConstraintPredicates x `Set.union` getRulePredicates y) xs+getRulePredicates (OrderedNonTerminal xs) = Set.unions $ fmap (\(x,y) -> getConstraintPredicates x `Set.union` 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+evalsTo s a = case createPredicateTable s (const True) of    Left x   -> CBool (x == a)    Right xs -> orConstraints <| fmap andPredicates                              <| fmap oraclePredicates@@ -346,17 +413,17 @@    where        andPredicates []  = CBool True-      andPredicates [x] = makePred x-      andPredicates xs  = And (fmap makePred xs)+      andPredicates xs  = And (concatMap 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+      makePred (p, UnsetPred)   = [IsValid p, Not (Predicate p)]+      makePred (p, SetPred)     = [IsValid p, Predicate p]+      makePred (p, InvalidPred) = [Not (IsValid p)]+      makePred (_, UndefPred)   = undefined -- shouldn't be possible given we use+                                            -- get the predicates from the oracle itself   -------------------------------------------------------@@ -410,7 +477,7 @@ --                               , getPredicates b --                               ] -- @-class Predicated a where+class (Ord (Pred a), Ord (PredTerm a)) => Predicated a where    -- | Error type    type PredErr a :: * @@ -426,19 +493,23 @@    -- | Reduce predicates    reducePredicates :: PredOracle (Pred a) -> a -> MatchResult (PredErr a) a (PredTerm a) +   -- | Simplify predicates+   simplifyPredicates :: PredOracle (Pred a) -> a -> a+    -- | Get possible resulting terminals-   getTerminals :: a -> [PredTerm a]+   getTerminals :: a -> Set (PredTerm a)     -- | Get used predicates-   getPredicates :: a -> [Pred a]+   getPredicates :: a -> Set (Pred a)  -instance (Ord p, Eq e, Eq a, Eq p) => Predicated (Rule e p a) where+instance (Ord a, 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+   reducePredicates   = ruleReduce+   simplifyPredicates = ruleSimplify    liftTerminal     = Terminal    getTerminals     = getRuleTerminals    getPredicates    = getRulePredicates@@ -448,15 +519,42 @@    type Pred     (Constraint e p) = p    type PredTerm (Constraint e p) = Bool -   reducePredicates oracle c = case constraintReduce oracle c of+   reducePredicates oracle c = case constraintSimplify oracle c of       CBool v -> Match v       c'      -> DontMatch c' +   simplifyPredicates oracle c = constraintSimplify oracle c+    liftTerminal     = CBool    getTerminals     = getConstraintTerminals    getPredicates    = getConstraintPredicates +instance forall x y.+   ( Predicated x+   , Predicated y+   , PredErr x ~ PredErr y+   , Pred x ~ Pred y+   ) => Predicated (x,y)+   where+   type PredErr  (x,y) = PredErr x+   type Pred     (x,y) = Pred x+   type PredTerm (x,y) = (PredTerm x, PredTerm y) +   reducePredicates oracle (x,y) =+      initP (,) (,)+         |> (`applyP` reducePredicates oracle x)+         |> (`applyP` reducePredicates oracle y)+         |> resultP++   simplifyPredicates oracle (x,y) = (simplifyPredicates oracle x, simplifyPredicates oracle y)++   liftTerminal (x,y)  = (liftTerminal x, liftTerminal y)+   getTerminals (x,y)  = Set.fromList+                           [ (x',y') | x' <- Set.toList (getTerminals x)+                                     , y' <- Set.toList (getTerminals y)+                           ]+   getPredicates (x,y) = Set.union (getPredicates x) (getPredicates y)+ -- | Reduction result data MatchResult e nt t    = NoMatch@@ -517,8 +615,8 @@    , 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 =+   ) => a -> (PredOracle (Pred a) -> Bool) -> Either (PredTerm a) [(PredOracle (Pred a),PredTerm a)]+createPredicateTable s oracleChecker =    -- we first check if the predicated value reduces to a terminal without any    -- additional oracle    case reducePredicates emptyOracle s of@@ -531,25 +629,11 @@        oracles = filter oracleChecker (fmap makeOracle predSets) -      preds        = sort (getPredicates s)--      predSets-         | fullTable = makeFullSets preds-         | otherwise = makeSets     preds [] +      preds = Set.toList (getPredicates (simplifyPredicates emptyOracle s)) -      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)+      predSets = makeSets preds [[]]  +      -- make predicate sets (each predicate is either Set, Unset or Undef)       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-                                 ]---+      makeSets (p:ps) os = let ns = [(p,SetPred),(p,UnsetPred),(p,UndefPred)]+                           in makeSets ps [(n:o) | o <- os, n <- ns]

@@ -0,0 +1,21 @@+-- | Mutable value with associated last write time+module Haskus.Utils.TimedValue+   ( TimedValue (..)+   )+where++-- | Value with Eq/Ord instances uniquely based on time field indicating the+-- time the value was last written.+--+-- This can be used with IOVar/IOTree which use Eq instances to detect value+-- changes. It can be useful for values that we don't want to structurally+-- compare (because it is too costly or because we can't)+--+-- `t` should be SystemTime (fast to query monotonic clock)+data TimedValue t a = TimedValue t a++instance Eq t => Eq (TimedValue t a) where+   TimedValue t1 _ == TimedValue t2 _ = t1 == t2++instance Ord t => Ord (TimedValue t a) where+   compare (TimedValue t1 _) (TimedValue t2 _) = compare t1 t2

@@ -13,11 +13,11 @@ import Test.Tasty import Test.Tasty.QuickCheck as QC import Data.List+import qualified Data.Set as Set  import Haskus.Utils.Solver import Haskus.Utils.Flow - data Predi    = PredA    | PredB@@ -65,57 +65,60 @@          |> (`applyP` reducePredicates oracle b)          |> resultP -   getTerminals (PD as bs) = [ PD a b | a <- getTerminals as-                                      , b <- getTerminals bs-                             ]+   simplifyPredicates oracle (PD a b) =+      PD (simplifyPredicates oracle a)+         (simplifyPredicates oracle b) -   getPredicates (PD a b) = concat-                              [ getPredicates a-                              , getPredicates b+   getTerminals (PD as bs) = Set.fromList+                              [ PD a b+                              | a <- Set.toList (getTerminals as)+                              , b <- Set.toList (getTerminals bs)                               ] +   getPredicates (PD a b) = Set.union (getPredicates a) (getPredicates b)+ testsSolver :: TestTree testsSolver = testGroup "Solver" $    [ testProperty "Constraint reduce: CBool True"-         (constraintReduce oracleAll (CBool True) == (CBool True :: C))+         (constraintSimplify oracleAll (CBool True) == (CBool True :: C))    , testProperty "Constraint reduce: CBool False"-         (constraintReduce oracleAll (CBool False) == (CBool False :: C))+         (constraintSimplify oracleAll (CBool False) == (CBool False :: C))    , testProperty "Constraint reduce: Not False"-         (constraintReduce oracleAll (Not (CBool False)) == (CBool True :: C))+         (constraintSimplify oracleAll (Not (CBool False)) == (CBool True :: C))    , testProperty "Constraint reduce: Not True"-         (constraintReduce oracleAll (Not (CBool True)) == (CBool False :: C))+         (constraintSimplify oracleAll (Not (CBool True)) == (CBool False :: C))    , testProperty "Constraint reduce: And [True,True]"-         (constraintReduce oracleAll (And [CBool True,CBool True]) == (CBool True :: C))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify 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))+         (constraintSimplify oracleAll (Not (Xor [CBool False,CBool False,CBool False])) == (CBool True :: C))     , testProperty "Constraint reduce: matching oracle"-         (constraintReduce oracleA (Predicate PredA) == (CBool True :: C))+         (constraintSimplify oracleA (Predicate PredA) == (CBool True :: C))    , testProperty "Constraint reduce: non matching oracle"-         (constraintReduce oracleB (Predicate PredA) == (CBool False :: C))+         (constraintSimplify oracleB (Predicate PredA) == (CBool False :: C))     , testProperty "Constraint reduce: evalsTo 0"-         (constraintReduce oracleAll (simpleRule `evalsTo` 0) == (CBool False :: C))+         (constraintSimplify oracleAll (simpleRule `evalsTo` 0) == (CBool False :: C))    , testProperty "Constraint reduce: evalsTo 1"-         (constraintReduce oracleAll (simpleRule `evalsTo` 1) == (CBool True :: C))+         (constraintSimplify oracleAll (simpleRule `evalsTo` 1) == (CBool True :: C))    , testProperty "Constraint reduce: evals to D"-         (constraintReduce oracleA (d1 `evalsTo` PD 0 "Test") == (CBool True :: C))+         (constraintSimplify oracleA (d1 `evalsTo` PD 0 "Test") == (CBool True :: C))     , testProperty "Evals to: Terminal 0"          (((Terminal 0 :: R Int NT) `evalsTo` 0) == (CBool True :: C))@@ -146,27 +149,27 @@          )     , testProperty "Ordered non terminal 0"-         (case reducePredicates oracleAB (orderedNonTerminal [(Predicate PredA, Terminal 0 :: R Int NT)+         (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)+         (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])+         (getPredicates d1 == Set.fromList [PredA,PredC,PredD,PredE])     , testProperty "Get predicates: nested"-         (sort (getPredicates d2) == sort [PredA,PredB,PredC,PredD])+         (getPredicates d2 == Set.fromList [PredA,PredB,PredC,PredD])     , testProperty "Create predicate table: flat non terminal"-         (case createPredicateTable d1 (const True) False of+         (case createPredicateTable d1 (const True) of             Left _   -> False             Right xs -> sort (fmap (oraclePredicates . fst) xs) == sort                            [ [(PredA, SetPred)  , (PredC, UnsetPred), (PredD, UnsetPred), (PredE, UnsetPred)]@@ -175,37 +178,24 @@                            ]          )    , testProperty "Create predicate table: nested non terminal"-         (case createPredicateTable d2 (const True) False of+         (case createPredicateTable d2 (const True) 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)]+                  [[(PredA,SetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,SetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,SetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredC,UnsetPred),(PredD,UnsetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredD,SetPred)]+                  ,[(PredA,SetPred),(PredB,UnsetPred),(PredD,UnsetPred)]+                  ,[(PredA,UnsetPred),(PredB,SetPred),(PredC,SetPred),(PredD,UnsetPred)]+                  ,[(PredA,UnsetPred),(PredB,SetPred),(PredC,UnsetPred),(PredD,SetPred)]                   ]          ) -   , 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

@@ -1,5 +1,31 @@+{-# LANGUAGE LambdaCase #-}+ import Haskus.Tests.Utils import Test.Tasty+import Test.DocTest +import Control.Exception+import System.Exit++ main :: IO ()-main = defaultMain testsUtils+main = wrapTests+   [ title "TASTY"   $ defaultMain testsUtils+   , title "DOCTEST" $ doctest ["src/lib/"]+   ]++title :: String -> IO () -> IO ()+title s m = do+   putStrLn ""+   putStrLn (replicate 30 '=')+   putStrLn s+   putStrLn (replicate 30 '=')+   m++wrap :: IO () -> IO Bool+wrap m = (m >> return True) `catch` (\e -> return (e == ExitSuccess))++wrapTests :: [IO ()] -> IO ()+wrapTests ts = (and <$> traverse wrap ts) >>= \case+   True  -> title "SUMMARY" exitSuccess+   False -> title "SUMMARY" exitFailure