packages feed

rec-def 0.2 → 0.2.1

raw patch · 17 files changed

+111/−88 lines, 17 files

Files

Data/POrder.hs view
@@ -1,10 +1,7 @@ -- | This module provides the 'POrder' and related classes module Data.POrder where -import System.IO.Unsafe-import Control.Monad.ST import Data.Monoid-import Data.Coerce import qualified Data.Set as S import Numeric.Natural import Data.Function
Data/Propagator/Class.hs view
@@ -17,6 +17,7 @@     freezeProp :: p -> IO ()     readProp :: p -> IO x +-- | Exception thrown by a propagator when attempting to change the value of a frozen propagator data WriteToFrozenPropagatorException = WriteToFrozenPropagatorException    deriving Show instance Exception WriteToFrozenPropagatorException
Data/Propagator/Naive.hs view
@@ -62,9 +62,9 @@  -- | A cell in a propagator network data Prop_ a = Prop-    { val :: IORef_ a-    , lock :: MVar_ ()-    , onChange :: IORef_ (Maybe (M ()))+    { _val :: IORef_ a+    , _lock :: MVar_ ()+    , _onChange :: IORef_ (Maybe (M ()))     }  -- | Creates a cell, initialized to bottom
Data/Propagator/P2.hs view
@@ -27,7 +27,6 @@ #define P2_  (P2 m) #define PBool_  PBool m #define PDualBool_  PDualBool m-#define IORef_ IORef m #define MVar_  MVar m #define M      m @@ -40,13 +39,11 @@ #define P2_  P2 #define PBool_  PBool #define PDualBool_  PDualBool-#define IORef_ IORef #define MVar_  MVar #define M      IO  import Control.Exception import Control.Concurrent.MVar-import Data.IORef  #endif @@ -100,13 +97,14 @@     SurelyBottom -> pure False     StillBottom _ -> pure False +#ifndef DEJAFU+ -- | Freezes the value. Drops references to watchers. freeze :: Ctxt P2_ -> M () freeze (P2 p) = takeMVar p >>= \case     SurelyTop -> putMVar p SurelyTop     _  -> putMVar p SurelyBottom -#ifndef DEJAFU instance Propagator P2_ Bool where     newProp = newP2     newConstProp False = newP2
Data/Propagator/Purify.hs view
@@ -34,9 +34,6 @@ where  import System.IO.Unsafe-import Control.Monad.ST-import Data.Monoid-import Data.Coerce  import Data.Propagator.Class import System.IO.RecThunk
Data/Recursive/Bool.hs view
@@ -26,9 +26,6 @@ module Data.Recursive.Bool (RBool, module Data.Recursive.Bool) where  -import Data.Coerce-import Data.Monoid- import Data.Recursive.Internal import qualified Data.Propagator.Purify as Purify import Data.Propagator.P2@@ -53,42 +50,42 @@  -- | prop> RB.get (RB.mk b) === b mk :: Bool -> RBool-mk b = RBool $ Purify.mk b+mk b = openR $ Purify.mk b  -- | prop> RB.get RB.true == True true :: RBool-true = RBool $ Purify.mk True+true = openR $ Purify.mk True  -- | prop> RB.get RB.false == False false :: RBool-false = RBool $ Purify.mk False+false = openR $ Purify.mk False  -- | prop> RB.get (r1 RB.&& r2) === (RB.get r1 && RB.get r2) (&&) :: RBool -> RBool -> RBool-(&&) = coerce $ Purify.def2 $ \p1 p2 p ->+(&&) = openR $ Purify.def2 $ \p1 p2 p ->     whenTop p1 (whenTop p2 (setTop p))  -- | prop> RB.get (r1 RB.|| r2) === (RB.get r1 || RB.get r2) (||) :: RBool -> RBool -> RBool-(||) = coerce $ Purify.def2 $ \p1 p2 p -> do+(||) = openR $ Purify.def2 $ \p1 p2 p -> do     whenTop p1 (setTop p)     whenTop p2 (setTop p)  -- | prop> RB.get (RB.and rs) === and (map RB.get rs) and :: [RBool] -> RBool-and = coerce $ Purify.defList $ go+and = openR $ Purify.defList $ go   where     go [] p = setTop p     go (p':ps) p = whenTop p' (go ps p)  -- | prop> RB.get (RB.or rs) === or (map RB.get rs) or :: [RBool] -> RBool-or = coerce $ Purify.defList $  \ps p ->+or = openR $ Purify.defList $  \ps p ->     mapM_ @[] (`implies` p) ps  -- | prop> RB.get (RB.not r1) === not (RDB.get r1) not :: RDualBool -> RBool-not = coerce $ Purify.def1 $ \p1 p -> do+not = openR $ Purify.def1 $ \p1 p -> do     implies p1 p  -- | The identity function. This is useful when tying the knot, to avoid a loop that bottoms out:@@ -104,5 +101,5 @@ -- -- prop> RB.get (RB.id r) === RB.get r id :: RBool -> RBool-id = coerce $ Purify.def1 $ \p1 p ->+id = openR $ Purify.def1 $ \p1 p ->     implies p1 p
Data/Recursive/DualBool.hs view
@@ -25,9 +25,6 @@ -} module Data.Recursive.DualBool (RDualBool, module Data.Recursive.DualBool) where -import Data.Coerce-import Data.Monoid- import Data.Recursive.Internal import qualified Data.Propagator.Purify as Purify import Data.Propagator.P2@@ -52,42 +49,42 @@  -- | prop> RDB.get (RDB.mk b) === b mk :: Bool -> RDualBool-mk b = RDualBool $ Purify.mk (Prelude.not b)+mk b = openR $ Purify.mk (Prelude.not b)  -- | prop> RDB.get RDB.true == True true :: RDualBool-true = RDualBool $ Purify.mk False+true = openR $ Purify.mk False  -- | prop> RDB.get RDB.false == False false :: RDualBool-false = RDualBool $ Purify.mk True+false = openR $ Purify.mk True  -- | prop> RDB.get (r1 RDB.&& r2) === (RDB.get r1 && RDB.get r2) (&&) :: RDualBool -> RDualBool -> RDualBool-(&&) = coerce $ Purify.def2 $ \p1 p2 p -> do+(&&) = openR $ Purify.def2 $ \p1 p2 p -> do     whenTop p1 (setTop p)     whenTop p2 (setTop p)  -- | prop> RDB.get (r1 RDB.|| r2) === (RDB.get r1 || RDB.get r2) (||) :: RDualBool -> RDualBool -> RDualBool-(||) = coerce $ Purify.def2 $ \p1 p2 p ->+(||) = openR $ Purify.def2 $ \p1 p2 p ->     whenTop p1 (whenTop p2 (setTop p))  -- | prop> RDB.get (RDB.and rs) === and (map RDB.get rs) and :: [RDualBool] -> RDualBool-and = coerce $ Purify.defList $ \ps p ->+and = openR $ Purify.defList $ \ps p ->     mapM_ @[] (`implies` p) ps  -- | prop> RDB.get (RDB.or rs) === or (map RDB.get rs) or :: [RDualBool] -> RDualBool-or = coerce $ Purify.defList go+or = openR $ Purify.defList go   where     go [] p = setTop p     go (p':ps) p = whenTop p' (go ps p)  -- | prop> RDB.get (RDB.not r1) === not (RB.get r1) not :: RBool -> RDualBool-not = coerce $ Purify.def1 $ \p1 p -> do+not = openR $ Purify.def1 $ \p1 p -> do     implies p1 p  -- | The identity function. This is useful when tying the knot, to avoid a loop that bottoms out:@@ -103,5 +100,5 @@ -- -- | prop> RDB.get (RDB.id r) === RDB.get r id :: RDualBool -> RDualBool-id = coerce $ Purify.def1 $ \p1 p ->+id = openR $ Purify.def1 $ \p1 p ->     implies p1 p
Data/Recursive/Examples.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+ {-|  This file contains a few examples of using the @rec-def@ library. There is no
Data/Recursive/Internal.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}  {- |  This modules contains the newtype definitions backing@@ -19,6 +21,11 @@ import Data.Propagator.P2 import Data.Propagator.Naive +import Data.Coerce++-- Not yet+-- import GHC.TypeError+ -- | Like 'Bool', but admits recursive definitions, preferring the least solution. newtype RBool = RBool (Purify.Purify P2) @@ -30,3 +37,25 @@  -- | Like 'M.Map', but admits recursive definitions. data RMap a b = RMap (RSet a) (M.Map a b)++-- | See 'openR'. Can be extended as needed+type family OpenR a where+    -- newtypes+    OpenR RBool = Purify.Purify P2+    OpenR RDualBool = Purify.Purify P2+    OpenR (RSet a) = Purify.Purify (Prop (S.Set a))+    -- other type constructors (extended as needed)+    OpenR (a -> b) = OpenR a -> OpenR b+    OpenR [a] = [OpenR a]+    -- base type+    OpenR other = other++-- | A constrainted form of 'coerce' that only resolves the newtypes from this+-- module, in a directed way.+--+-- This improves type inference (e.g. if 'Data.Recursive.Set.id' was using+-- 'coerce' instead, it would need a type signature).+--+-- The idiom is [due to Daniel Díaz Carrete](https://discourse.haskell.org/t/haskell-mini-idiom-constraining-coerce/3814?u=nomeata).+openR :: Coercible a (OpenR a) => OpenR a -> a+openR = coerce
Data/Recursive/Map.hs view
@@ -66,10 +66,6 @@   ) where  import qualified Data.Map as M-import qualified Data.Set as S-import Data.Coerce-import Data.Monoid-import Control.Monad  import Data.Recursive.Internal import qualified Data.Recursive.Set as RS@@ -165,7 +161,7 @@  -- | prop> RS.get (RM.keysSet m) === M.keysSet (RM.get m) keysSet :: RMap a b -> RS.RSet a-keysSet ~(RMap rs m) = RS.id rs+keysSet ~(RMap rs _) = RS.id rs   -- better use RS.id either here or in fromSet, to avoid unproductive loops  -- | prop> RM.get (RM.restrictKeys m s) === M.restrictKeys (RM.get m) (RS.get s)@@ -175,16 +171,16 @@  -- | prop> RB.get (RM.member k m) === M.member k (RM.get m) member :: Ord a => a -> RMap a b -> RBool-member x ~(RMap rs m) = RS.member x rs+member x ~(RMap rs _) = RS.member x rs  -- | prop> RDB.get (RM.notMember n r1) === M.notMember n (RM.get r1) notMember :: Ord a => a -> RMap a b -> RDualBool-notMember x ~(RMap rs m) = RS.notMember x rs+notMember x ~(RMap rs _) = RS.notMember x rs  -- | prop> RDB.get (RM.disjoint m1 m2) === M.disjoint (RM.get m1) (RM.get m2) disjoint :: Ord a => RMap a b -> RMap a b -> RDualBool-disjoint ~(RMap rs1 _ ) ~(RMap rs2 m2) = RS.disjoint rs1 rs2+disjoint ~(RMap rs1 _ ) ~(RMap rs2 _) = RS.disjoint rs1 rs2  -- | prop> RDB.get (RM.null m) === M.null (RM.get m) null :: Ord a =>  RMap a b -> RDualBool-null ~(RMap rs m) = RS.null rs+null ~(RMap rs _) = RS.null rs
Data/Recursive/Set.hs view
@@ -12,9 +12,7 @@ module Data.Recursive.Set (RSet, module Data.Recursive.Set) where  import qualified Data.Set as S-import Data.Coerce-import Data.Monoid-import Control.Monad+import Control.Monad hiding (when)  import Data.Recursive.Internal import qualified Data.Propagator.Purify as Purify@@ -33,6 +31,8 @@ -- >>> import Test.QuickCheck -- >>> instance (Ord a, Arbitrary a) => Arbitrary (RS.RSet a) where arbitrary = RS.mk <$> arbitrary -- >>> instance (Ord a, Show a) => Show (RS.RSet a) where show = show . RS.get+-- >>> instance Arbitrary RB.RBool where arbitrary = RB.mk <$> arbitrary+-- >>> instance Show RB.RBool where show = show . RB.get  -- | Extracts the value of a 'RSet a' get :: RSet a -> S.Set a@@ -52,49 +52,49 @@  -- | prop> RS.get (RS.insert n r1) === S.insert n (RS.get r1) insert :: Ord a => a -> RSet a -> RSet a-insert x = coerce $ Purify.def1 $ lift1 $ S.insert x+insert x = openR $ Purify.def1 $ lift1 $ S.insert x  -- | prop> RS.get (RS.delete n r1) === S.delete n (RS.get r1) delete :: Ord a => a -> RSet a -> RSet a-delete x = coerce $ Purify.def1 $ lift1 $ S.delete x+delete x = openR $ Purify.def1 $ lift1 $ S.delete x  -- | prop> \(Fun _ p) -> RS.get (RS.filter p r1) === S.filter p (RS.get r1) filter :: Ord a => (a -> Bool) -> RSet a -> RSet a-filter f = coerce $ Purify.def1 $ lift1 $ S.filter f+filter f = openR $ Purify.def1 $ lift1 $ S.filter f  -- | prop> RS.get (RS.union r1 r2) === S.union (RS.get r1) (RS.get r2) union :: Ord a => RSet a -> RSet a -> RSet a-union = coerce $ Purify.def2 $ lift2 S.union+union = openR $ Purify.def2 $ lift2 S.union  -- | prop> RS.get (RS.unions rs) === S.unions (map RS.get rs) unions :: Ord a => [RSet a] -> RSet a-unions = coerce $ Purify.defList $ liftList S.unions+unions = openR $ Purify.defList $ liftList S.unions  -- | prop> RS.get (RS.intersection r1 r2) === S.intersection (RS.get r1) (RS.get r2) intersection :: Ord a => RSet a -> RSet a -> RSet a-intersection = coerce $ Purify.def2 $ lift2 S.intersection+intersection = openR $ Purify.def2 $ lift2 S.intersection  -- | prop> RB.get (RS.member n r1) === S.member n (RS.get r1) member :: Ord a => a -> RSet a -> RBool-member x = coerce $ Purify.def1 $ \ps pb -> do+member x = openR $ Purify.def1 $ \ps pb -> do     let update = do             s <- readProp ps-            when (S.member x s) $ setTop pb+            if S.member x s then setTop pb else pure ()     watchProp ps update     update  -- | prop> RDB.get (RS.notMember n r1) === S.notMember n (RS.get r1) notMember :: Ord a => a -> RSet a -> RDualBool-notMember x = coerce $ Purify.def1 $ \ps pb -> do+notMember x = openR $ Purify.def1 $ \ps pb -> do     let update = do             s <- readProp ps-            when (S.member x s) $ setTop pb+            if S.member x s then setTop pb else pure ()     watchProp ps update     update  -- | prop> RDB.get (RS.null s) === S.null (RS.get s) null :: RSet a -> RDualBool-null = coerce $ Purify.def1 $ \ps pb -> do+null = openR $ Purify.def1 $ \ps pb -> do     let update = do             s <- readProp ps             unless (S.null s) $ setTop pb@@ -103,7 +103,7 @@  -- | prop> RDB.get (RS.disjoint r1 r2) === S.disjoint (RS.get r1) (RS.get r2) disjoint :: Ord a => RSet a -> RSet a -> RDualBool-disjoint = coerce $ Purify.def2 $ \ps1 ps2 pb -> do+disjoint = openR $ Purify.def2 $ \ps1 ps2 pb -> do     let update = do             s1 <- readProp ps1             s2 <- readProp ps2@@ -112,6 +112,14 @@     watchProp ps2 update     update +-- | An kind of if-then-else statement. Because of monotonicity requirements,+-- this should be sufficient.+--+-- prop> RS.get (RS.when b r) === (if RB.get b then RS.get r else S.empty)+when :: RBool -> RSet a -> RSet a+when = openR $ Purify.def2 $ \pb ps1 ps2 -> do+    whenTop pb $ lift1 Prelude.id ps1 ps2+ -- | The identity function. This is useful when tying the knot, to avoid a loop that bottoms out: -- -- > let x = x in RS.get x@@ -125,4 +133,4 @@ -- -- | prop> RS.get (RS.id s) === RS.get s id :: RSet a -> RSet a-id = coerce $ Purify.def1 $ lift1 (Prelude.id :: S.Set a -> S.Set a)+id = openR $ Purify.def1 $ lift1 Prelude.id
System/IO/RecThunk.hs view
@@ -50,7 +50,6 @@ #define Thunk_  (Thunk m) #define ResolvingState_  (ResolvingState m) #define KickedThunk_  (KickedThunk m)-#define IORef_ IORef m #define MVar_  MVar m #define M      m @@ -64,13 +63,10 @@ #define Thunk_  Thunk #define ResolvingState_  ResolvingState #define KickedThunk_  KickedThunk-#define IORef_ IORef #define MVar_  MVar #define M      IO  import Control.Concurrent.MVar-import Control.Concurrent-import Data.IORef import Data.Unique import Control.Monad.IO.Class
examples.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+ {-|  This file contains a few examples of using the @rec-def@ library. There is no
rec-def.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               rec-def-version:            0.2+version:            0.2.1 synopsis:           Recursively defined values description:    This library provides safe APIs that allow you to define and calculate@@ -50,7 +50,7 @@     CHANGELOG.md     README.md     examples.hs-tested-with: GHC==9.2.1, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4+tested-with: GHC==9.2.1, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4  library     exposed-modules: Data.Recursive.Examples@@ -69,6 +69,8 @@     build-depends:    base >= 4.9 && < 5     build-depends:    containers >= 0.5.11 && < 0.7 +    ghc-options:      -Wall+     default-language: Haskell2010  test-suite doctest@@ -76,19 +78,22 @@     main-is:          doctests.hs     default-language: Haskell2010     ghc-options:      -threaded+    ghc-options:      -Wall     hs-source-dirs:   tests      build-depends:    rec-def     build-depends:    base >= 4.9 && < 5-    build-depends:    doctest ^>= 0.18.2+    build-depends:    doctest     build-depends:    QuickCheck     build-depends:    template-haskell + test-suite spaceleak     type:             exitcode-stdio-1.0     main-is:          spaceleak.hs     hs-source-dirs:   tests     default-language: Haskell2010+    ghc-options:      -Wall     build-depends:    rec-def     build-depends:    base >= 4.9 && < 5     build-depends:    containers >= 0.5.11 && < 0.7@@ -104,6 +109,7 @@     hs-source-dirs:   tests .     default-language: Haskell2010     ghc-options:      -threaded+    ghc-options:      -Wall     cpp-options:      -DDEJAFU      build-depends:    base >= 4.9 && < 5
tests/dejafu.hs view
@@ -1,9 +1,10 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}+ import Test.DejaFu import Control.Concurrent.Classy import Control.Concurrent.Classy.Async import qualified Data.Set as S import System.Random-import Control.Monad import Test.Tasty import Test.Tasty.DejaFu @@ -11,10 +12,11 @@ import Data.Propagator.P2 import System.IO.RecThunk +t, tr :: (Eq a, Show a) => TestName -> Program pty IO a -> TestTree t n = testAuto n- tr n = testAutoWay (randomly (mkStdGen 0) 1000) defaultMemType n +main :: IO () main = defaultMain $ testGroup "tests" $   [ t "prop 1" $ do         p1 <- newProp (S.singleton 1)@@ -30,7 +32,7 @@         p1 <- newProp S.empty         p2 <- newProp S.empty         pure (p1, p2)) $ \(p1, p2) -> do-        mapConcurrently id+        mapConcurrently_ id             [ lift1 (S.insert 3) p1 p2             , lift1 (S.insert 4) p2 p1             ]@@ -41,7 +43,7 @@         p2 <- newProp S.empty         p3 <- newProp S.empty         pure (p1, p2, p3)) $ \(p1, p2, p3) -> do-        mapConcurrently id+        mapConcurrently_ id             [ lift1 (S.insert 3) p1 p2             , lift1 (S.insert 4) p2 p1             ]@@ -57,7 +59,7 @@         p2 <- newProp S.empty         p3 <- newProp S.empty         pure (p1, p2, p3)) $ \(p1, p2, p3) -> do-        mapConcurrently id+        mapConcurrently_ id             [ lift1 (S.insert 3) p1 p2             , lift1 (S.insert 4) p2 p1             , lift1 (S.insert 5) p2 p3@@ -69,7 +71,7 @@         p2 <- newProp S.empty         p3 <- newProp S.empty         pure (p1, p2, p3)) $ \(p1, p2, p3) -> do-        mapConcurrently id+        mapConcurrently_ id             [ lift1 (S.insert 4) p1 p2             , lift1 (S.insert 5) p2 p3             , lift2 (S.union) p2 p3 p1@@ -82,7 +84,7 @@         p3 <- newProp S.empty         p4 <- newProp S.empty         pure (p1, p2, p3, p4)) $ \(p1, p2, p3, p4) -> do-        mapConcurrently id+        mapConcurrently_ id             [ lift1 (S.insert 4) p1 p2             , lift2 (S.union) p1 p2 p3             , liftList (S.unions) [p1,p2,p3] p4@@ -169,7 +171,7 @@   , t "P2 2" $ do     p1 <- newP2     p2 <- newP2-    mapConcurrently id+    mapConcurrently_ id         [ do             False <- isTop p1             setTop p1@@ -184,7 +186,7 @@   , t "P2 2 rec bottom" $ do     p1 <- newP2     p2 <- newP2-    mapConcurrently id+    mapConcurrently_ id         [  p1 `implies` p2         ,  p2 `implies` p1         ]@@ -193,7 +195,7 @@   , t "P2 2 rec top" $ do     p1 <- newP2     p2 <- newP2-    mapConcurrently id+    mapConcurrently_ id         [  p1 `implies` p2         ,  p2 `implies` p1         , setTop p1
tests/doctests.hs view
@@ -1,8 +1,3 @@ import Test.DocTest-main = do-    -- Why do I have to call them separately?-    doctest ["--fast", "-package=QuickCheck","Data/Recursive/Bool.hs"]-    doctest ["--fast", "-package=QuickCheck","Data/Recursive/DualBool.hs"]-    doctest ["--fast", "-package=QuickCheck","Data/Recursive/Set.hs"]-    doctest ["--fast", "-package=QuickCheck","Data/Recursive/Map.hs"]-    doctest ["--fast", "-package=QuickCheck","Data/Recursive/Examples.hs"]+main :: IO ()+main = doctest ["--fast", "-package=QuickCheck","Data/"]
tests/spaceleak.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}  {-| This test checks that resolved cells do no longer hold on to references to@@ -11,8 +12,6 @@  import qualified Data.Set as S import qualified Data.Recursive.Set as RS-import Data.Recursive.Internal-import Data.Propagator.Purify  import Data.IORef import System.Mem.Weak@@ -21,6 +20,7 @@ import System.Environment import Control.Concurrent +main :: IO () main = do     n <- length <$> getArgs