diff --git a/data-forced.cabal b/data-forced.cabal --- a/data-forced.cabal +++ b/data-forced.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: data-forced -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Specify that lifted values were forced to WHNF or NF. license: MIT license-file: LICENSE @@ -20,26 +20,26 @@ Main tutorial on the only module. Here is a taste of how it will look like. - > import Data.Map.Lazy as ML -- Spine strict - > - > -- No references on added leafs even though it is a lazy map. - > basicEvent :: ML.Map Char (ForcedWHNF Int) -> IO (ML.Map Char (ForcedWHNF Int)) - > basicEvent map0 = do - > let - > -- Step1: bind the strict value with a strict let. (2 + 2) reduced - > -- before val0 is bound. - > val0 :: StrictValueExtractor (ForcedWHNF Int) - > val0 = strictlyWHNF (2 + 2) - > -- val0 = strictlyWHNF (error "argument evaluated") -- would fail - > - > -- Step2: extract the strict value to be use on lazy setting. A - > -- neccesary idiom to avoid a pitfall. - > val1 = case val0 of { Pairy val0' ext -> ext val0' } - > - > -- Step3: Store the value free of references. Even though map1 is a lazy - > -- map, the references to evaluate val1 were already freed. - > map1 = ML.insert 'a' val1 map0 - > pure map1 + > {-# Language QualifiedDo #-} + > + > import qualified Data.Forced as DF + > import Data.Forced hiding (pure, fmap, (\<*\>), return, (>>=), (>>)) + > import Data.Map.Lazy qualified as ML + > + > noThunksForWHNF :: IO () + > noThunksForWHNF = do + > -- map0 actually evaluated on here. + > let map0 :: Demand (ML.Map Char (ForcedWHNF Int)) + > map0 = DF.do + > v <- demandWHNF (const (2 + 2) 'a') + > DF.pure $ ML.insert 'a' v ML.empty + > + > map1 <- extractDemand map0 + > go (ML.lookup 'a' map1) + > + > -- pattern matching for de-structuring, no construction allowed. + > go :: ForcedWHNF Int -> IO () + > go (ForcedWHNF i) = print i -- extra-source-files: source-repository head @@ -47,7 +47,7 @@ location: https://github.com/RubenAstudillo/data-forced common warnings - ghc-options: -Wall -Werror=unbanged-strict-patterns + ghc-options: -Wall library import: warnings diff --git a/src/Data/Forced.hs b/src/Data/Forced.hs --- a/src/Data/Forced.hs +++ b/src/Data/Forced.hs @@ -3,199 +3,131 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnliftedDatatypes #-} -module Data.Forced ( - -- * How to use this library - - -- ** Add a new flag on ghc-options - -- $howToUse1 - - -- ** Put ForcedWHNF or ForcedNF types on fields that need to have __no__ references when hold on a long lived data structure. - -- $howToUse2 - - -- ** Use this common idiom whenever you need to obtain a forced value - -- $howToUse3 - - -- * The 'UnliftedType' calling convention (or how to avoid pitfalls) - -- $unliftedCallingConvetion +module Data.Forced + ( -- * How to use this library + -- | You should use the following imports + -- + -- @ + -- import qualified Data.Forced as DF + -- import Data.Forced hiding (pure, fmap, (<*>), return, (>>=), (>>)) + -- @ - -- * Unlifted types + -- ** Design the type of your long lived data structure + -- $dataTypeUserDesign - -- | We need these so whenever we bound a strict computation, all the - -- lazy values will be forced as needed. - Pairy (..), - StrictValueExtractor, - Strict, + -- ** Construct values on the @Demand@ monad + -- $useMonad - -- * Newtypes that hold a evaluation invariant - -- $invariantNewtypes - ForcedWHNF, - pattern ForcedWHNF, - ForcedNF, - pattern ForcedNF, + -- * Newtypes to be used to specify how evaluated a type should be + ForcedWHNF (ForcedWHNF) + , ForcedNF (ForcedNF) + -- * Monadic environment to execute the needed demands. + , Demand + , demandWHNF + , demandNF + , extractDemand - -- * Call By Value functions - strictlyWHNF, - strictlyNF, -) where + -- * Qualified Do support. + -- | These are available to construct value by hand. But they clash with + -- 'P.Functor', 'P.Applicative' and 'P.Monad' functions. We cannot + -- provide instances to those classes as the 'Demand' monad is + -- 'UnliftedType' kinded. But using @-XQualifiedDo@, GHC will pick up + -- these names and use it on a @DF.do@ notation that does the right + -- thing. + , fmap + , pure + , (<*>) + , return + , (>>=) + , (>>) + ) where import Control.DeepSeq (NFData (rnf)) import Data.Elevator (LiftedType, UnliftedType) +import Prelude () +import qualified Prelude as P -{- $howToUse1 -Add this to your .cabal file It will save us from a pitfall. +{- $dataTypeUserDesign +The main way this library helps you avoid leaks is by specifying the types +of your long lived data structures. They should contain new demands on the +type variables. @ -common warnings - ghc-options: -Werror=unbanged-strict-patterns - -library - import: warnings - ... - -executable myAwesomeProgram - import: warnings -@ --} - -{- $howToUse2 -@ import Data.Map.Lazy -- it is fine, really. import Data.Vector -type MyMap a = Map (ForcedWHNF Char) (ForcedNF (Maybe Vector)) +-- On insertion of the lazy map, the keys and the values will evaluated. +type MyMap a = Map (ForcedWHNF Char) (ForcedNF (Maybe (Vector Int))) --- Prompt removal of deleted elements. -type MyMap2 a = ForcedWHNF (Map (ForcedWHNF Char) (ForcedNF (Maybe Vector))) +-- On top, prompt removal of deleted elements. +type MyMap2 a = ForcedWHNF (Map (ForcedWHNF Char) (ForcedNF (Maybe (Vector Int)))) @ This way it will be a type error to store a thunk that is keeping references alive. -} -{- $howToUse3 - 1. Strictly @let@ bound on your current context the result of a call to - 'strictlyWHNF' or 'strictlyNF'. __This is the most important part.__ - 2. Use a lazy let to extract the underlying @ForcedWHNF a@ or @ForcedNF a@ - with the paired extractor. - 3. Store the previous result on the long lived data structure. +{- $useMonad +We use the 'Demand' monad to construct values with the correct strictness. +You either construct the values by hand, but it is better to use the +@-XQualifiedDo@ extension. +The main functions to keep in mind on this monad are: 'demandWHNF' and +'demandNF'. + +Once you have the value specified, you need to extract it to the IO +environment. Hopefully this will be close to main where your long lived data +should be stored. We do this as is the obvious sequence point, so from the +PoV of the rest of the program, the action is visible on the default lifted +environment. + The ideal code piece looks like this: @ -import Data.Map.Lazy +\{\-\# Language QualifiedDo \#\-\} -type MyMap a = Map Char (ForcedNF (Maybe Int)) +import qualified Data.Forced as DF +import Data.Forced hiding (pure, fmap, (\<*\>), return, (>>=), (>>)) +import Data.Map.Lazy qualified as ML noThunksForWHNF :: IO () noThunksForWHNF = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - - -- Step 1. Strict let bound is done given the kind of - -- StrictValueExtractor - val0 :: StrictValueExtractor (ForcedWHNF Int) - val0 = strictlyWHNF (const (2 + 2) map0) + -- map0 actually evaluated on here. + let map0 :: Demand (ML.Map Char (ForcedWHNF Int)) + map0 = DF.do + v <- demandWHNF (const (2 + (2 :: Int)) \'a\') + DF.pure $ ML.insert \'a\' v ML.empty - -- Step 2. The extractor is inside the Pairy constructor of val0 - val1 = case val0 of { Pairy v ext -> ext v } + map1 <- extractDemand map0 + go (ML.lookup \'a\' map1) - -- Step 3. Store as a lazy thunk without the references. - map1 = ML.insert 'a' val1 map0 - pure () +-- pattern matching for de-structuring, no construction allowed. +go :: ForcedWHNF Int -> IO () +go (ForcedWHNF i) = print i @ -} -{- $unliftedCallingConvetion - -Types that have kind 'UnliftedType' have an different calling convention -than normal values. To achieve the correct evaluation level: - - 1. We __should__ bound with a name (@let@) computations that return a type - with 'UnliftedType' kind to the top level of our current context. - 2. We __must not__ inline computation with kind 'UnliftedType' at use - sites. Specially if the use site is inside of a lazy function. - -The first kind of mistake is hard to trigger if we follow the first section -rules. The library also steers you in the right direction by recommending -the following stanza. - -@ -common warnings - ghc-options: -Wall -Werror=unbanged-strict-patterns -@ - -on the cabal file of your project. It will protect your against this common -error - -@ -noThunksForWHNF :: IO (ML.Map Char (Forced Int)) -noThunksForWHNF = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - - -- Step 1 & 2 merged - val0 :: StrictValueExtractor (ForcedWHNF Int) - val0@(Pairy v ext) = strictlyWHNF (const (2 + 2) map0) - - -- Step 3. Store as a lazy thunk without the references. - map1 = ML.insert 'a' val1 map0 - pure map1 -@ - -Now @val0@ merged steps 1 and 2. __But in doing so it turned a strict let__ -__into a lazy let__. The @-Werror=unbanged-strict-patterns@ will highlight -this at compile time and require you to put a @BangPattern@ on @val0@. - -The problem about inlining is hiding a strict computation inside of a lazy -computation. So in the previous example - -@ -noThunksForWHNF :: IO (ML.Map Char (Forced Int)) -noThunksForWHNF = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - - -- Step 1 & 2 merged - val1= case strictlyWHNF (const (2 + 2) map0) of - Pairy v ext -> ext - - -- Step 3. Store as a lazy thunk without the references. - map1 = ML.insert 'a' val1 map0 - pure map1 -@ - -val1 __has been bound by a lazy let__. Top level bound plus explicit types -in @let@ bindings will help us to avoid this. --} - -{- | Unlifted pair type. When a value of this type is bound, it will have - already evaluated @u@. --} -type Pairy :: UnliftedType -> LiftedType -> UnliftedType -data Pairy (u :: UnliftedType) (l :: LiftedType) :: UnliftedType where - Pairy :: u -> l -> Pairy u l - -{- | A type synonym for the unlifted pair type synonym. It contains a strict - value and a way to extract it to a lazy/normal context. +{- | A strict identity monad of 'UnliftedType' kind. To be used via +@-XQualifiedDo@. -} -type StrictValueExtractor a = Pairy (Strict a) (Strict a -> a) - --- | A wrapper for a lifted type that makes sure to have it evaluated. -type Strict :: LiftedType -> UnliftedType -data Strict (a :: LiftedType) :: UnliftedType where - Strict :: !a -> Strict a +type Demand :: LiftedType -> UnliftedType +data Demand (a :: LiftedType) :: UnliftedType where + Demand :: a -> Demand a -{- | We don't ship the constructor of 'Strict' as it could be used to bypass - our pushes to bind values to a name. +{- | We don't ship the constructor of 'Demand'. The only way to extract a +'Demand' is to sequence to a know point on 'P.IO'. From the PoV of the rest +of the program, the tagged values with t'ForcedWHNF' or t'ForcedNF' +will have been demanded. -} -extractStrict :: Strict a -> a -extractStrict (Strict a) = a +extractDemand :: Demand a -> P.IO a +extractDemand (Demand a) = P.pure a {- $invariantNewtypes The invariants of @ForcedWHNF@ and @ForcedNF@ depends on the constructors not being exported. The only way to construct these value is through the CBV -functions. Pattern matching is done via a unidirectional pattern. +functions of the 'Demand' type. Pattern matching is done via a +unidirectional pattern. -} {- | Contains a value of type @a@ that has been forced to __W__eak __H__ead @@ -204,6 +136,9 @@ -} newtype ForcedWHNF a = ForcedOuter a +instance P.Show a => P.Show (ForcedWHNF a) where + show (ForcedOuter a) = "ForcedWHNF " P.++ P.show a + -- | The only way to extract the underlying value. pattern ForcedWHNF :: forall a. a -> ForcedWHNF a pattern ForcedWHNF a <- ForcedOuter a @@ -213,6 +148,9 @@ -} newtype ForcedNF a = ForcedFull a +instance P.Show a => P.Show (ForcedNF a) where + show (ForcedFull a) = "ForcedNF " P.++ P.show a + -- | The only way to extract the underlying value. pattern ForcedNF :: forall a. a -> ForcedNF a pattern ForcedNF a <- ForcedFull a @@ -220,9 +158,41 @@ {- | This is a CBV function. Evaluates the argument to WHNF before returning. -} -strictlyWHNF :: forall a. a -> StrictValueExtractor (ForcedWHNF a) -strictlyWHNF a = Pairy (Strict (ForcedOuter a)) extractStrict +demandWHNF :: forall a. a -> Demand (ForcedWHNF a) +demandWHNF a = a `P.seq` Demand (ForcedOuter a) -- | This is a CBV function. Evaluates the argument to NF before returning. -strictlyNF :: forall a. NFData a => a -> StrictValueExtractor (ForcedNF a) -strictlyNF a = Pairy (Strict (ForcedFull (rnf a `seq` a))) extractStrict +demandNF :: forall a. NFData a => a -> Demand (ForcedNF a) +demandNF a = rnf a `P.seq` Demand (ForcedFull a) + +{- $qualifiedDoSupport + +There are no 'P.Functor', 'P.Applicative' or 'P.Monad' classes for +'UnliftedType' types yet. This package is not the right place to define +them. We can get @do@ notation using @-XQualifiedDo@. +-} +-- | 'P.fmap' analogue for 'Demand's which are of the 'UnliftedType' kind. +fmap :: (a -> b) -> Demand a -> Demand b +fmap f (Demand a) = Demand (f a) + +-- | Places __no__ demand on the value. 'P.pure' analogue for 'Demand's +-- which are of the 'UnliftedType' kind. +pure :: a -> Demand a +pure a = Demand a + +-- | 'P.<*>' analogue for 'Demand's which are of the 'UnliftedType' kind. +(<*>) :: Demand (a -> b) -> Demand a -> Demand b +(<*>) (Demand fun) (Demand fa) = Demand (fun fa) + +-- | 'P.return' analogue for 'Demand's which are of the 'UnliftedType' kind. +-- Same as 'pure'. +return :: a -> Demand a +return = pure + +-- | 'P.>>=' analogue for 'Demand's which are of the 'UnliftedType' kind. +(>>=) :: Demand a -> (a -> Demand b) -> Demand b +(Demand ma) >>= f = f ma + +-- | 'P.>>' analogue for 'Demand's which are of the 'UnliftedType' kind. +(>>) :: Demand a -> Demand b -> Demand b +(>>) fa fb = fa >>= (\_ -> fb) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,9 +1,13 @@ -{-# OPTIONS_GHC -Wno-unused-binds #-} +{-# Language QualifiedDo #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Evaluate" #-} module Main (main) where import Control.Exception (ErrorCall (..), catch) -import Data.Forced +import qualified Data.Forced as DF +import Data.Forced hiding (pure, fmap, (<*>), return, (>>=), (>>)) import Data.Map.Lazy qualified as ML import Test.HUnit (Counts, Test (TestList), runTestTT, (~:)) @@ -24,47 +28,28 @@ noThunksForWHNF :: IO () noThunksForWHNF = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - val0 :: StrictValueExtractor (ForcedWHNF Int) - !val0@(Pairy val1 ext) = strictlyWHNF (error "argument evaluated") - map1 = ML.insert 'a' (ext val1) map0 - pure () - -noThunksForWHNF1 :: IO () -noThunksForWHNF1 = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - val0 :: StrictValueExtractor (ForcedWHNF Int) - val0 = strictlyWHNF (error "argument evaluated") - val1 = case val0 of Pairy v ext -> ext v - map1 = ML.insert 'a' val1 map0 - pure () - -noThunksForWHNF2 :: IO () -noThunksForWHNF2 = do - let map0 :: ML.Map Char (ForcedWHNF Int) - map0 = ML.empty - val1 = case strictlyWHNF (error "argument evaluated") of Pairy v ext -> ext v - map1 = ML.insert 'a' val1 map0 + let map0 :: Demand (ML.Map Char (ForcedWHNF Int)) + map0 = DF.do + v <- demandWHNF (error "argument evaluated") + DF.pure $ ML.insert 'a' v ML.empty + map1 <- extractDemand map0 pure () +-- | Should not fail. thunksForWHNFMaybe :: IO () thunksForWHNFMaybe = do - let map0 :: ML.Map Char (ForcedWHNF (Maybe Int)) - map0 = ML.empty - val0 :: StrictValueExtractor (ForcedWHNF (Maybe Int)) - val0 = strictlyWHNF (const (Just (error "argument evaluated")) 'a') - val1 = case val0 of Pairy v ext -> ext v - map1 = ML.insert 'a' val1 map0 + let map0 :: Demand (ML.Map Char (ForcedWHNF (Maybe Int))) + map0 = DF.do + v <- demandWHNF (const (Just (error "argument evaluated")) 'a') + DF.pure $ ML.insert 'a' v ML.empty + map1 <- extractDemand map0 pure () noThunksForNFMaybe :: IO () noThunksForNFMaybe = do - let map0 :: ML.Map Char (ForcedNF (Maybe Int)) - map0 = ML.empty - val0 :: StrictValueExtractor (ForcedNF (Maybe Int)) - val0 = strictlyNF ((+ 1) <$> Just (error "argument evaluated" :: Int)) - val = case val0 of Pairy st ext -> ext st - map1 = ML.insert 'a' val map0 + let map0 :: Demand (ML.Map Char (ForcedNF (Maybe Int))) + map0 = DF.do + v <- demandNF (const (Just (error "argument evaluated")) 'a') + DF.pure $ ML.insert 'a' v ML.empty + map1 <- extractDemand map0 pure ()