diff --git a/haskus-utils.cabal b/haskus-utils.cabal --- a/haskus-utils.cabal +++ b/haskus-utils.cabal @@ -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 diff --git a/src/lib/Haskus/Utils/Dynamic.hs b/src/lib/Haskus/Utils/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Dynamic.hs @@ -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 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 @@ -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|\ - \ - \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. --} +-- | +-- +-- 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|\ +-- \ +-- \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 \ @@ -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, 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 @@ -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 diff --git a/src/lib/Haskus/Utils/Maths.hs b/src/lib/Haskus/Utils/Maths.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Maths.hs @@ -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 diff --git a/src/lib/Haskus/Utils/MonadFlow.hs b/src/lib/Haskus/Utils/MonadFlow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/MonadFlow.hs @@ -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 _ -> [] + diff --git a/src/lib/Haskus/Utils/MonadStream.hs b/src/lib/Haskus/Utils/MonadStream.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/MonadStream.hs @@ -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 diff --git a/src/lib/Haskus/Utils/MonadVar.hs b/src/lib/Haskus/Utils/MonadVar.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/MonadVar.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Parser.hs b/src/lib/Haskus/Utils/Parser.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Parser.hs +++ /dev/null @@ -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 : 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 : 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 : 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') - diff --git a/src/lib/Haskus/Utils/STM.hs b/src/lib/Haskus/Utils/STM.hs --- a/src/lib/Haskus/Utils/STM.hs +++ b/src/lib/Haskus/Utils/STM.hs @@ -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) diff --git a/src/lib/Haskus/Utils/STM/Future.hs b/src/lib/Haskus/Utils/STM/Future.hs --- a/src/lib/Haskus/Utils/STM/Future.hs +++ b/src/lib/Haskus/Utils/STM/Future.hs @@ -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 () diff --git a/src/lib/Haskus/Utils/STM/SnapVar.hs b/src/lib/Haskus/Utils/STM/SnapVar.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/SnapVar.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Solver.hs b/src/lib/Haskus/Utils/Solver.hs --- a/src/lib/Haskus/Utils/Solver.hs +++ b/src/lib/Haskus/Utils/Solver.hs @@ -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] diff --git a/src/lib/Haskus/Utils/TimedValue.hs b/src/lib/Haskus/Utils/TimedValue.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/TimedValue.hs @@ -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 diff --git a/src/tests/Haskus/Tests/Utils/Solver.hs b/src/tests/Haskus/Tests/Utils/Solver.hs --- a/src/tests/Haskus/Tests/Utils/Solver.hs +++ b/src/tests/Haskus/Tests/Utils/Solver.hs @@ -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 diff --git a/src/tests/Main.hs b/src/tests/Main.hs --- a/src/tests/Main.hs +++ b/src/tests/Main.hs @@ -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