module Control.Linear (St, A, Blank, Pair, Fn, (>>==), rtn,
run, bimap, assoc1, assoc2, drop1, drop2, undrop1, undrop2, swap, apply, curry, distr, void', bimap',
Exclusive, Semiclosed, Open, Placeholder(Placeholder), open, getStdin, getStdout, getStderr, close, close1, fileSize, setFileSize, eof, seek, tell, char, line, lookahead, contents, putC, putS, random,
Pointer, Freeable(Freeable), Foreign(Foreign), Focused(Focused), Fix(In), fixInj1, fixInj2, Weakening(weakening), contraction, new, free, split, ptrSwap,
focus, focusHdl,
peek', poke', changeType,
newForeign, peek1, poke1
) where
import Control.Arrow
import Control.Category
import Control.Monad
import GHC.Prim
import GHC.IO
import GHC.Base (realWorld#)
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
data St = St (State# RealWorld)
newtype A t u v = A (u -> (v, t))
type Fn t u = A () (Pair t St) (Pair u St)
data Blank = Blank
data Pair t u = Pair !t !u
instance (Default a) => Category (A a) where
id = A (\x -> (x, def))
A f . A g = A (f . fst . g)
instance (Default a) => Arrow (A a) where
arr f = A (\x -> (f x, def))
first (A f) = A (\(x, y) -> let (z, a) = f x in ((z, y), a))
instance (Default a) => ArrowChoice (A a) where
A f +++ A g = A (\ei -> either (\x -> let (y, z) = f x in (Left y, z))
(\x -> let (y, z) = g x in (Right y, z))
ei)
left a = a +++ id
infixl 1 >>==
A f >>== g = A (\x -> let
(y, z) = f x
A h = g z in
h y)
rtn x = A (\y -> (y, x))
run :: A a St St -> IO a
run (A f) = IO $ \world -> case f (St world) of (St world', x) -> (# world', x #)
bimap (A f) (A g) = A (\(Pair a b) -> let
(c, d) = f a
(e, h) = g b in
(Pair c e, (d, h)))
assoc1 = A (\(Pair (Pair a b) c) -> (Pair a (Pair b c), ()))
assoc2 = A (\(Pair a (Pair b c)) -> (Pair (Pair a b) c, ()))
drop1 = A (\(Pair Blank x) -> (x, ()))
drop2 = A (\(Pair x Blank) -> (x, ()))
undrop1 = A (\x -> (Pair Blank x, ()))
undrop2 = A (\x -> (Pair x Blank, ()))
swap = A (\(Pair x y) -> (Pair y x, ()))
apply = A (\(Pair (A f) x) -> f x)
curry (A f) = A (\x -> (A (\y -> f (Pair x y)), ()))
distr = A (\(Pair a ei) -> (either (Left . Pair a) (Right . Pair a) ei, ()))
void' = (>>== const (rtn ()))
bimap' :: A () t u -> A () v w -> A () (Pair t v) (Pair u w)
bimap' a a2 = void' (bimap a a2)
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
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 -> (Exclusive hdl, ())) $ openFile file mode) . undrop1
getStdin = A (\Blank -> (Open stdin, ()))
getStdout = A (\Blank -> (Open stdout, ()))
getStderr = A (\Blank -> (Open stderr, ()))
close = drop1 . lift (\(Exclusive hdl) -> hClose hdl >> return (Blank, ()))
close1 = drop1 . lift (\(Semiclosed hdl) -> hClose hdl >> return (Blank, ()))
fileSize = lift (\h -> liftM ((,) h) (hFileSize (getHdl h)))
setFileSize sz = lift (\h -> hSetFileSize (getHdl h) sz >> return (h, ()))
eof = lift (\h -> liftM ((,) h) (hIsEOF (getHdl h)))
seek mode pos = lift (\h -> hSeek (getHdl h) mode pos >> return (h, ()))
tell = lift (\h -> liftM ((,) h) (hTell (getHdl h)))
char = lift (\h -> liftM ((,) h) (hGetChar (getHdl h)))
line = lift (\h -> liftM ((,) h) (hGetLine (getHdl h)))
lookahead = lift (\h -> liftM ((,) h) (hLookAhead (getHdl h)))
contents = lift (\(Exclusive hdl) -> liftM ((,) (Semiclosed hdl)) (hGetContents hdl))
putC c = lift (\h -> hPutChar (getHdl h) c >> return (h, ()))
putS s = lift (\h -> hPutStr (getHdl h) s >> return (h, ()))
random = A (\Blank -> unsafePerformIO $ liftM ((,) Blank) getStdGen)
instance Storable Blank where
sizeOf _ = 0
alignment _ = 1
peek _ = return Blank
poke _ Blank = return ()
align x y = ((sizeOf x 1) `div` alignment y + 1) * alignment y
frst :: (Storable a, Storable b) => Ptr (Pair a b) -> Ptr a
frst = castPtr
secnd :: forall a b. (Storable a, Storable b) => Ptr (Pair a b) -> Ptr b
secnd = castPtr . (`plusPtr` align (undefined :: a) (undefined :: b))
instance (Storable a, Storable b) => Storable (Pair a b) where
sizeOf _ = align (undefined :: a) (undefined :: b) + sizeOf (undefined :: b)
alignment _ = alignment (undefined :: a)
`lcm` alignment (undefined :: b)
peek p = liftM2 Pair (peek (frst p)) (peek (secnd p))
poke p (Pair x y) = do
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
data Fix f = In (f (Fix f))
fixInj1 :: Pointer p s (Fix f) -> Pointer p s (f (Fix f))
fixInj1 (Pointer fp p world) = Pointer fp (castPtr p) world
fixInj2 :: Pointer p s (f (Fix f)) -> Pointer p s (Fix f)
fixInj2 (Pointer fp p world) = Pointer fp (castPtr p) world
data Pointer p s t = Pointer !(ForeignPtr Blank) !(Ptr t) (State# RealWorld)
instance Storable (Pointer p s t) where
sizeOf _ = 8
alignment _ = 4
poke p (Pointer fp p2 _) = do
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 #))
data Freeable = Freeable
data Focused = Focused
data Foreign = Foreign
data Placeholder = Placeholder
class Copyable s
instance Copyable Focused
instance Copyable Foreign
dummy :: ForeignPtr Blank
dummy = unsafePerformIO (A.malloc >>= newForeignPtr_)
contraction :: (Copyable s) => A () (Pointer p s t) (Pair (Pointer p s t) (Pointer p s t))
contraction = A (\p -> (Pair p p, ()))
class Weakening t where
weakening :: A () t Blank
instance Weakening (Pointer p Focused t) where
weakening = A (\(Pointer _ _ _) -> (Blank, ()))
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, ()))
new :: (Storable t) => A () Blank (Pointer p Placeholder t)
new = A (\Blank -> unsafePerformIO (liftM (\p -> (Pointer dummy p realWorld#, ())) A.malloc))
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 :: 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
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
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, ()))
manipulate = assoc2 . bimap' id swap . assoc1
updateWorld1 = manipulate . bimap' updateWorld id . manipulate
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))
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, ()))
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 "Control.Linear.changeType: value won't fit"
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 :: (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 p s t) (Pointer p s t)
poke1 x = lift (\ptr@(Pointer _ p _) -> poke p x >> return (ptr, ())) >>> updateWorld
helloWorld = run $ undrop1
>>> bimap' getStdout id
>>> putS "Hello world!\n"
>>> bimap' weakening id
>>> drop1