MonadCompose 0.8.0.0 → 0.8.1.0

raw patch · 2 files changed

+142/−93 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Control/Linear.hs +141/−92
• MonadCompose.cabal +1/−1

@@ -1,11 +1,23 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables, MagicHash, UnboxedTuples, FlexibleInstances #-}
+{-# LANGUAGE Rank2Types, ScopedTypeVariables, MagicHash, UnboxedTuples, FlexibleInstances, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}
 -- | A linear type-based I/O system a la Clean.
 --
 --   This is an alternative to composing monads - one can decompose them into their
 --   corresponding comonads, with linear operations for manipulating them.
 --   (See Kieburtz, http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.46.5169&rep=rep1&type=pdf)
-module Control.Linear (St, A, Blank, Pair, Fn, Open, Semiclosed, Freeable(Freeable), Foreign(Foreign), Placeholder(Placeholder), Pointer, (>>==), rtn, run, bimap, assoc1, assoc2, drop1, drop2, undrop1, undrop2, swap, apply, curry, distr, void', bimap',
-open, getStdin, getStdout, getStderr, close, close1, fileSize, setFileSize, eof, seek, tell, char, line, lookahead, contents, putC, putS, random, frst, secnd, Fix(In), fixInj1, fixInj2, newForeign, new, get, weakening, contraction, free, focus, peek', poke', changeType, peek1, poke1, split) where
+module Control.Linear (St, A, Blank, Pair, Fn, (>>==), rtn,
+-- * Algebraic operations
+run, bimap, assoc1, assoc2, drop1, drop2, undrop1, undrop2, swap, apply, curry, distr, void', bimap',
+-- * Basic I/O system
+Exclusive, Semiclosed, Open, Placeholder(Placeholder), open, getStdin, getStdout, getStderr, close, close1, fileSize, setFileSize, eof, seek, tell, char, line, lookahead, contents, putC, putS, random,
+-- * Safe pointer facilities
+Pointer, Freeable(Freeable), Foreign(Foreign), Focused(Focused), Fix(In), fixInj1, fixInj2, Weakening(weakening), contraction, new, free, split, ptrSwap,
+-- ** Focusing
+focus, focusHdl,
+-- ** Strong update
+peek', poke', changeType,
+-- ** Operations on nonlinear data / Weak update
+newForeign, peek1, poke1
+) where
 
 import Control.Arrow
 import Control.Category
@@ -16,14 +28,19 @@ import System.IO
 import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr)
 import Foreign.ForeignPtr.Unsafe
+import Foreign.StablePtr
 import Foreign.Ptr
 import qualified Foreign.Marshal.Alloc as A
 import Foreign.Storable
 import Data.Default
+import Data.Int
 import Prelude hiding (id, (.), curry)
 import System.Random (getStdGen)
 import System.IO.Unsafe
 
+-- * Linear type machinery
+
+-- | Values representing the real world.
 data St = St (State# RealWorld)
 
 -- | Linear computations are arrows over linear data, but monads over nonlinear data.
@@ -35,33 +52,6 @@ 
 data Pair t u = Pair !t !u
 
-newtype Open = Open Handle
-
-newtype Semiclosed = Semiclosed Handle
-
-data Pointer p s t = Pointer !(ForeignPtr Blank) !(Ptr t) (State# RealWorld)
-
--- | Pointers can be freeable or foreign. Freeable pointers are created with 'new'.
---   Linearity is enforced for them, so I can do strong update, but the need
---   to keep track of all pointers means that 'split' cannot be supported.
---   Foreign pointers on the other hand can be copied indefinitely since the
---   garbage collector is keeping track of them.
---
---   Freeable pointers can be turned into foreign pointers permanently using
---   'newForeign', or temporarily by focusing.
---
---   Placeholders classify pointers that either point to junk or to data that
---   is not allowed to be used (to maintain linearity).
-data Freeable = Freeable
-
-data Foreign = Foreign
-
-data Placeholder = Placeholder
-
-{-# NOINLINE dummy #-}
-dummy :: ForeignPtr Blank
-dummy = unsafePerformIO (A.malloc >>= newForeignPtr_)
-
 instance (Default a) => Category (A a) where
 	id = A (\x -> (x, def))
 	A f . A g = A (f . fst . g)
@@ -87,8 +77,7 @@ -- | Monadic return
 rtn x = A (\y -> (y, x))
 
---- Algebraic operations
--- This setup is from http://cs.ioc.ee/~tarmo/tsem11/jeltsch1602-slides.pdf
+-- | This setup is from http://cs.ioc.ee/~tarmo/tsem11/jeltsch1602-slides.pdf
 --
 -- It implements some of http://pauillac.inria.fr/~fpottier/slides/fpottier-2007-05-linear-bestiary.pdf
 
@@ -143,12 +132,27 @@ 
 ------------------------------------------------------
 
+newtype Exclusive = Exclusive Handle deriving Storable
+
+newtype Semiclosed = Semiclosed Handle deriving Storable
+
+newtype Open p = Open Handle deriving Storable
+
+class Openhandle h where
+	getHdl :: h -> Handle
+
+instance Openhandle Exclusive where
+	getHdl (Exclusive h) = h
+
+instance Openhandle (Open p) where
+	getHdl (Open h) = h
+
 {-# INLINE lift #-}
 lift f = A $ \(Pair x (St world)) -> let
 	IO g = f x
 	(# world', (y, z) #) = g world in (Pair y (St world'), z)
 
-open file mode = lift (\Blank -> liftM (\hdl -> (Open hdl, ())) $ openFile file mode)
+open file mode = lift (\Blank -> liftM (\hdl -> (Exclusive hdl, ())) $ openFile file mode) . undrop1
 
 getStdin = A (\Blank -> (Open stdin, ()))
 
@@ -156,38 +160,38 @@ 
 getStderr = A (\Blank -> (Open stderr, ()))
 
-close = drop1 . lift (\(Open hdl) -> unless (hdl `elem` [stdin, stdout, stderr]) (hClose hdl) >> return (Blank, ()))
+close = drop1 . lift (\(Exclusive hdl) -> hClose hdl >> return (Blank, ()))
 
 close1 = drop1 . lift (\(Semiclosed hdl) -> hClose hdl >> return (Blank, ()))
 
-fileSize = lift (\h@(Open hdl) -> liftM ((,) h) (hFileSize hdl))
+fileSize = lift (\h -> liftM ((,) h) (hFileSize (getHdl h)))
 
-setFileSize sz = lift (\h@(Open hdl) -> hSetFileSize hdl sz >> return (h, ()))
+setFileSize sz = lift (\h -> hSetFileSize (getHdl h) sz >> return (h, ()))
 
-eof = lift (\h@(Open hdl) -> liftM ((,) h) (hIsEOF hdl))
+eof = lift (\h -> liftM ((,) h) (hIsEOF (getHdl h)))
 
-seek mode pos = lift (\h@(Open hdl) -> hSeek hdl mode pos >> return (h, ()))
+seek mode pos = lift (\h -> hSeek (getHdl h) mode pos >> return (h, ()))
 
-tell = lift (\h@(Open hdl) -> liftM ((,) h) (hTell hdl))
+tell = lift (\h -> liftM ((,) h) (hTell (getHdl h)))
 
-char = lift (\h@(Open hdl) -> liftM ((,) h) (hGetChar hdl))
+char = lift (\h -> liftM ((,) h) (hGetChar (getHdl h)))
 
-line = lift (\h@(Open hdl) -> liftM ((,) h) (hGetLine hdl))
+line = lift (\h -> liftM ((,) h) (hGetLine (getHdl h)))
 
-lookahead = lift (\h@(Open hdl) -> liftM ((,) h) (hLookAhead hdl))
+lookahead = lift (\h -> liftM ((,) h) (hLookAhead (getHdl h)))
 
-contents = lift (\(Open hdl) -> liftM ((,) (Semiclosed hdl)) (hGetContents hdl))
+contents = lift (\(Exclusive hdl) -> liftM ((,) (Semiclosed hdl)) (hGetContents hdl))
 
-putC c = lift  (\h@(Open hdl) -> hPutChar hdl c >> return (h, ()))
+putC c = lift  (\h -> hPutChar (getHdl h) c >> return (h, ()))
 
-putS s = lift (\h@(Open hdl) -> hPutStr hdl s >> return (h, ()))
+putS s = lift (\h -> hPutStr (getHdl h) s >> return (h, ()))
 
 {-# NOINLINE random #-}
 -- Random numbers have no interesting dependence on the world state,
 -- so it is not threaded.
 random = A (\Blank -> unsafePerformIO $ liftM ((,) Blank) getStdGen)
 
-------------------------------------------------------
+--------------------------------------------------------
 
 instance Storable Blank where
 	sizeOf _ = 0
@@ -212,6 +216,15 @@ 		poke (frst p) x
 		poke (secnd p) y
 
+coerce :: Ptr Handle -> Ptr Int32
+coerce = castPtr
+
+instance Storable Handle where
+	sizeOf _ = 4
+	alignment _ = 4
+	peek = peek . castPtr
+	poke = poke . castPtr
+
 -- | With the Fix constructor, I can build data structures of linear data.
 data Fix f = In (f (Fix f))
 
@@ -221,68 +234,98 @@ fixInj2 :: Pointer p s (f (Fix f)) -> Pointer p s (Fix f)
 fixInj2 (Pointer fp p world) = Pointer fp (castPtr p) world
 
--- | Nonlinear resources.
-class Nonlinear t
-
-instance Nonlinear Char
-
-instance (Nonlinear t) => Nonlinear [t]
-
-instance Nonlinear Bool
+data Pointer p s t = Pointer !(ForeignPtr Blank) !(Ptr t) (State# RealWorld)
 
-instance Nonlinear Ordering
+instance Storable (Pointer p s t) where
+	sizeOf _ = 8
+	alignment _ = 4
+	poke p (Pointer fp p2 _) = do -- The RealWorld is lost...
+		sp <- newStablePtr fp
+		pokeByteOff p 0 sp
+		pokeByteOff p 4 p2
+	peek p = do
+		sp <- peekByteOff p 0
+		fp <- deRefStablePtr sp
+		freeStablePtr sp
+		p2 <- peekByteOff p 4
+		IO (\s -> (# s, Pointer fp p2 s #)) -- ...so produce one here.
 
-instance Nonlinear Integer
+-- | Pointers can be freeable, foreign, or focused. There are the following
+--   tradeoffs:
+--
+--   * Freeable pointers support strong update, but can only be split
+--       under focusing.
+--
+--   * Foreign pointers can be split, but do not support strong update.
+--
+--   Placeholders classify pointers that either point to junk or to data that
+--   is not allowed to be used (to maintain linearity).
+data Freeable = Freeable
 
-instance Nonlinear Int
+data Focused = Focused
 
-instance Nonlinear Float
+data Foreign = Foreign
 
-instance Nonlinear Double
+data Placeholder = Placeholder
 
-instance (Nonlinear t, Nonlinear u) => Nonlinear (t, u)
+class Copyable s
 
-instance (Nonlinear t, Nonlinear u, Nonlinear v) => Nonlinear (t, u, v)
+instance Copyable Focused
 
-instance (Nonlinear t, Nonlinear u, Nonlinear v, Nonlinear w) => Nonlinear (t, u, v, w)
+instance Copyable Foreign
 
-instance (Nonlinear t, Nonlinear u, Nonlinear v, Nonlinear w, Nonlinear x) => Nonlinear (t, u, v, w, x)
+{-# NOINLINE dummy #-}
+dummy :: ForeignPtr Blank
+dummy = unsafePerformIO (A.malloc >>= newForeignPtr_)
 
--- | Contraction and weakening are available for pointers created from ForeignPtrs
---   (and pointers I am focusing on).
-contraction :: A () (Pointer p Foreign t) (Pair (Pointer p Foreign t) (Pointer p Foreign t))
+contraction :: (Copyable s) => A () (Pointer p s t) (Pair (Pointer p s t) (Pointer p s t))
 contraction = A (\p -> (Pair p p, ()))
 
-weakening :: A () (Pointer p Foreign t) Blank
-weakening = A (\(Pointer fp _ world) -> let IO f = touchForeignPtr fp in
-	case f world of (# _, () #) -> (Blank, ()))
+class Weakening t where
+	weakening :: A () t Blank
 
---- Safe pointer facilities
+instance Weakening (Pointer p Focused t) where
+	weakening = A (\(Pointer _ _ _) -> (Blank, ()))
 
-newForeign :: A (ForeignPtr t) (Pair (Pointer p Freeable t) St) St
-newForeign = lift (\(Pointer _ p _) -> liftM (\fp -> (Blank, fp)) $ newForeignPtr_ p) >>== \fp -> drop1 >>== \_ -> rtn fp
+instance Weakening (Pointer p Foreign t) where
+	weakening = A (\(Pointer fp _ world) -> let IO f = touchForeignPtr fp in
+		case f world of (# _, () #) -> (Blank, ()))
 
+instance Weakening (Open p) where
+	weakening = A (\(Open _) -> (Blank, ()))
+
+-- | Allocate a new freeable block (containing junk), Use 'poke'' to initialize it.
 {-# NOINLINE new #-}
 new :: (Storable t) => A () Blank (Pointer p Placeholder t)
 new = A (\Blank -> unsafePerformIO (liftM (\p -> (Pointer dummy p realWorld#, ())) A.malloc))
 
--- Gets the pointer from a ForeignPtr unsafely, however linearity ensures that
--- user programs must touch the ForeignPtr in order to dispose of it
--- (see 'weakening').
-get :: (Nonlinear t) => ForeignPtr t -> A () Blank (Pointer p Foreign t)
-get fp = A (\Blank -> (Pointer (castForeignPtr fp) (unsafeForeignPtrToPtr fp) realWorld#, ()))
-
 -- By using a smuggled RealWorld, I sequence freeing of a pointer without
 -- requiring explicit world sequencing.
+-- | Use 'peek'' to take ownership of the contents of a block before freeing it.
 free :: A () (Pointer p2 Placeholder t) Blank
 free = A (\(Pointer _ p world) -> let IO f = A.free p in
 	case f world of (# _, () #) -> (Blank, ()))
 
+-- | Split a pointer to a pair, into a pair of pointers.
+split :: forall t u p s. (Storable t, Storable u, Copyable s) => A () (Pointer p s (Pair t u)) (Pair (Pointer p s t) (Pointer p s u))
+split = A (\(Pointer fp p _) -> (Pair
+	(Pointer fp (frst p) realWorld#)
+	(Pointer fp (secnd p) realWorld#), ()))
+
+ptrSwap ::  (Storable t) => Fn (Pair (Pointer p s t) t) (Pair (Pointer p s t) t)
+ptrSwap = lift (\(Pair ptr@(Pointer _ p _) x) -> peek p >>= \y -> poke p x >> return (Pair ptr y, ())) >>> updateWorld1
+
 -- | Focusing on a pointer.
-focus :: (forall p. A a (Pair (Pointer p Foreign t) u) (Pair v St)) -> A a (Pair (Pointer p2 s t) u) (Pair (Pair (Pointer p2 s t) v) St)
+--
+--   Temporarily turns a freeable pointer into a focused pointer. I get the freeable
+--   pointer back after all copies have been surrendered (with 'weakening').
+focus :: (forall p. A a (Pair (Pointer p Focused t) u) (Pair v St))
+	-> A a (Pair (Pointer p2 s t) u) (Pair (Pair (Pointer p2 s t) v) St)
 focus (A f) = A (\(Pair ptr@(Pointer fp p _) x) -> first (\(Pair x st) -> Pair (Pair ptr x) st) (f (Pair (Pointer fp p realWorld#) x))) >>== \x -> updateWorld1 >>== \_ -> rtn x
 
---- Strong update
+-- | Focusing on a handle.
+focusHdl :: (forall p. A a (Pair (Open p) t) u) -> A a (Pair Exclusive t) (Pair Exclusive u)
+focusHdl (A f) = A (\(Pair h@(Exclusive hdl) x) -> first (Pair h) (f (Pair (Open hdl) x)))
 
 updateWorld :: A () (Pair (Pointer p s t) St) (Pair (Pointer p s t) St)
 updateWorld = A (\(Pair (Pointer fp p _) st@(St world)) -> (Pair (Pointer fp p world) st, ()))
@@ -291,37 +334,43 @@ 
 updateWorld1 = manipulate . bimap' updateWorld id . manipulate
 
+-- | Take the data out of a block, making it a placeholder.
 peek' :: (Storable t) => Fn (Pointer p Freeable t) (Pair (Pointer p Placeholder t) t)
 peek' = updateWorld1 . lift (\(Pointer fp p st) -> liftM (\x -> (Pair (Pointer fp p st) x, ())) (peek p))
 
+-- | The reverse operation.
 poke' :: (Storable t) => Fn (Pair (Pointer p Placeholder t) t) (Pointer p Freeable t)
 poke' = updateWorld . lift (\(Pair (Pointer fp p world) x) -> poke p x >> return (Pointer fp p world, ()))
 
+-- | A placeholder block can change its type.
 changeType :: forall t u p. (Storable t, Storable u) => A () (Pointer p Placeholder t) (Pointer p Placeholder u)
 changeType = if sizeOf (undefined :: u) <= sizeOf (undefined :: t) then
 		A (\(Pointer fp p world) -> (Pointer (castForeignPtr fp) (castPtr p) world, ()))
 	else
-		error "Linear.changeType: value won't fit"
+		error "Control.Linear.changeType: value won't fit"
 
---- Weak update
+-- Linearity ensures that a program must touch the pointer in order to dispose of it.
+-- | Allocate a Foreign pointer.
+{-# NOINLINE newForeign #-}
+newForeign :: (Storable t) => t -> A () Blank (Pointer p Foreign t)
+newForeign x = A (\Blank -> unsafePerformIO $ do
+	p <- A.malloc
+	poke p x
+	fp <- newForeignPtr_ p
+	return (Pointer (castForeignPtr fp) p realWorld#, ()))
 
-peek1 :: (Nonlinear t, Storable t) => A t (Pair (Pointer p s t) St) (Pair (Pointer p s t) St)
+peek1 :: (Storable t, Copyable s) => A t (Pair (Pointer p s t) St) (Pair (Pointer p s t) St)
 peek1 = lift (\ptr@(Pointer _ p _) -> liftM (\x -> (ptr, x)) $ peek p) >>== \x -> updateWorld >>== \_ -> rtn x
 
-poke1 :: (Storable t) => t -> Fn (Pointer p2 s t) (Pointer p2 s t)
+poke1 :: (Storable t) => t -> Fn (Pointer p s t) (Pointer p s t)
 poke1 x = lift (\ptr@(Pointer _ p _) -> poke p x >> return (ptr, ())) >>> updateWorld
 
--- | Split a pointer to a pair, into a pair of pointers.
-split :: forall t u p. (Storable t, Storable u) => A () (Pointer p Foreign (Pair t u)) (Pair (Pointer p Foreign t) (Pointer p Foreign u))
-split = A (\(Pointer fp p _) -> (Pair
-	(Pointer fp (frst p) realWorld#)
-	(Pointer fp (secnd p) realWorld#), ()))
-
 ------------------------------------------------------
---- Sample program
+--- Sample programs
 
 helloWorld = run $ undrop1
 	>>> bimap' getStdout id
 	>>> putS "Hello world!\n"
-	>>> close
+	>>> bimap' weakening id
+	>>> drop1
 

@@ -1,5 +1,5 @@ name:                MonadCompose
-version:             0.8.0.0
+version:             0.8.1.0
 synopsis:            Methods for composing monads.
 description:         Methods for composing monads.
   .