haskelltypeslinear-types

Is there a way to emulate linear types in Haskell?

I am modeling a system that has an operation that creates a resource and other operations that consume that resource. However, a given resource can only be consumed once - is there a way that I can guarantee that at compile time?

For concreteness, lets say the first operation bakes a cake and that there are two other operations, one for "choosing to eat" the cake and one for "choosing to have the cake" and that I can only do one or the other.

-- This is my current "weakly typed" interface:
bake :: IO Cake
eat  :: Cake -> IO ()
keep :: Cake -> IO ()

-- This is OK
do
  brownie <- bake
  muffin <- bake
  eat brownie
  keep muffin

-- Eating and having the same cake is not OK:
do
  brownie <- bake
  eat brownie
  keep brownie -- oops! already eaten!

Its easy to enforce the restriction of not keeping an already eaten cake (or vice versa) at runtime by setting an flag on the cake after we use it. But is there a way to enforce this at compile time?

BTW, this question is meant for a proof of concept so I am OK with any black magic that can give me the static safety I want.

Solution

  • In Haskell, a basic version of this could be expressed with a GADT indexed by a store of cakes (represented by a list of Nat-s):

    {-# LANGUAGE
  TypeFamilies, GADTs, TypeOperators, PartialTypeSignatures,
  DataKinds, PolyKinds #-}

import GHC.TypeLits
import Data.Proxy
import GHC.Exts

-- Allocate a new cake
type family New cs where
  New '[]       = 0
  New (c ': cs) = c + 1

-- Constraint satisfiable if "c" is in "cs"
type family Elem c cs :: Constraint where
  Elem c (c ': cs)  = ()
  Elem c (c' ': cs) = Elem c cs

type family Remove c cs where
  Remove c '[]        = '[]  
  Remove c (c ': cs)  = cs
  Remove c (c' ': cs) = c' ': Remove c cs

data Bake :: [Nat] -> [Nat] -> * -> * where
  Pure :: a -> Bake cs cs a
  Bake :: (Proxy (New cs) -> Bake (New cs ': cs) cs' a) -> Bake cs cs' a
  Eat  :: Elem c cs => Proxy c -> Bake (Remove c cs) cs' a -> Bake cs cs' a
  Keep :: Elem c cs => Proxy c -> Bake cs cs' a -> Bake cs cs' a

ok :: Bake '[] _ _
ok =
  Bake $ \cake1 ->
  Bake $ \cake2 ->
  Eat cake1 $
  Keep cake2 $
  Eat cake2 $
  Pure ()

not_ok :: Bake '[] _ _
not_ok =
  Bake $ \cake1 ->
  Bake $ \cake2 ->
  Eat cake1 $
  Keep cake1 $ -- we already ate that
  Eat cake2 $
  Pure ()

    Unfortunately we can't remove the type annotations from Bake actions and leave types to be inferred:

    foo =
  Bake $ \cake1 ->
  Bake $ \cake2 ->
  Eat cake1 $
  Pure ()

-- Error: Could not deduce (Elem (New cs0) (New cs0 + 1 : New cs0 : cs0))

    Obviously, (Elem (New cs0) (New cs0 + 1 : New cs0 : cs0)) is satisfiable for all cs0, but GHC can't see this, because it cannot decide whether New cs0 is inequal to New cs0 + 1, because GHC can't assume anything about the flexible cs0 variable.

    If we add NoMonomorphismRestriction, foo would typecheck, but that would make even incorrect programs typecheck by pushing all the Elem constraints to the top. This would still prevent doing anything useful with incorrect terms though, but it's a rather ugly solution.

    More generally, we can express Bake as an indexed free monad, which gets us do-notation with RebindableSyntax, and allows a definition for BakeF that is somewhat clearer than what we've seen before. It could also reduce boilerplate much like the plain old Free monad, although I find it rather unlikely that people would find use for indexed free monads on two different occasions in practical code. 

    {-# LANGUAGE
  TypeFamilies, GADTs, TypeOperators, PartialTypeSignatures, StandaloneDeriving,
  DataKinds, PolyKinds, NoImplicitPrelude, RebindableSyntax, DeriveFunctor #-}

import Prelude hiding (Monad(..))
import GHC.TypeLits
import Data.Proxy
import GHC.Exts

class IxFunctor f where
  imap :: (a -> b) -> f i j a -> f i j b

class IxFunctor m => IxMonad m where
  return :: a -> m i i a
  (>>=)  :: m i j a -> (a -> m j k b) -> m i k b
  fail   :: String -> m i j a

infixl 1 >>
infixl 1 >>=

(>>) :: IxMonad m => m i j a -> m j k b -> m i k b
ma >> mb = ma >>= const mb

data IxFree f i j a where
  Pure :: a -> IxFree f i i a
  Free :: f i j (IxFree f j k a) -> IxFree f i k a

liftf :: IxFunctor f => f i j a -> IxFree f i j a
liftf = Free . imap Pure

instance IxFunctor f => IxFunctor (IxFree f) where
  imap f (Pure a)  = Pure (f a)
  imap f (Free fa) = Free (imap (imap f) fa)

instance IxFunctor f => IxMonad (IxFree f) where
  return = Pure
  Pure a  >>= f = f a
  Free fa >>= f = Free (imap (>>= f) fa)
  fail = error

-- Old stuff for Bake

type family New cs where
  New '[]       = 0
  New (c ': cs) = c + 1

type family Elem c cs :: Constraint where
  Elem c (c ': cs)  = ()
  Elem c (c' ': cs) = Elem c cs

type family Remove c cs where
  Remove c '[]        = '[]  
  Remove c (c ': cs)  = cs
  Remove c (c' ': cs) = c' ': Remove c cs

-- Now the return type indices of BakeF directly express the change
-- from the old store to the new store.
data BakeF cs cs' k where
  BakeF :: (Proxy (New cs) -> k) -> BakeF cs (New cs ': cs) k
  EatF  :: Elem c cs => Proxy c -> k -> BakeF cs (Remove c cs) k
  KeepF :: Elem c cs => Proxy c -> k -> BakeF cs cs k

deriving instance Functor (BakeF cs cs')
instance IxFunctor BakeF where imap = fmap

type Bake = IxFree BakeF

bake   = liftf (BakeF id)
eat  c = liftf (EatF c ())
keep c = liftf (KeepF c ())

ok :: Bake '[] _ _
ok = do
  cake1 <- bake
  cake2 <- bake
  eat cake1
  keep cake2
  eat cake2

-- not_ok :: Bake '[] _ _
-- not_ok = do
--   cake1 <- bake
--   cake2 <- bake
--   eat cake1
--   keep cake1 -- already ate it
--   eat cake2