diff --git a/examples/Simple.hs b/examples/Simple.hs deleted file mode 100644 --- a/examples/Simple.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - -import Data.IORef - -import Control.Monad.Operational.Higher - - - --------------------------------------------------------------------------------- --- Simple expression language --------------------------------------------------------------------------------- - -data Exp a - where - Lit :: a -> Exp a - Add :: Num a => Exp a -> Exp a -> Exp a - Eq :: Eq a => Exp a -> Exp a -> Exp Bool - -instance Num a => Num (Exp a) - where - fromInteger = Lit . fromInteger - (+) = Add - -eval :: Exp a -> a -eval (Lit i) = i -eval (Add a b) = eval a + eval b -eval (Eq a b) = eval a == eval b - - - --------------------------------------------------------------------------------- --- Composable instructions --------------------------------------------------------------------------------- - --- | If statement -data If p a - where - If :: Exp Bool -> p a -> p a -> If p a - --- | Loop -data Loop p a - where - Loop :: Exp Int -> p () -> Loop p () - --- | Mutable references -data Ref (p :: * -> *) a - where - NewRef :: Exp a -> Ref p (IORef a) - GetRef :: IORef a -> Ref p (Exp a) - SetRef :: IORef a -> Exp a -> Ref p () - -instance HFunctor If - where - hfmap f (If c thn els) = If c (f thn) (f els) - -instance HFunctor Loop - where - hfmap f (Loop n body) = Loop n (f body) - -instance HFunctor Ref - where - hfmap f (NewRef a) = NewRef a - hfmap f (GetRef r) = GetRef r - hfmap f (SetRef r a) = SetRef r a - -instance Interp If IO - where - interp (If c thn els) = if eval c then thn else els - -instance Interp Loop IO - where - interp (Loop n body) = replicateM_ (eval n) body - -instance Interp Ref IO - where - interp (NewRef a) = newIORef (eval a) - interp (GetRef r) = fmap Lit $ readIORef r - interp (SetRef r a) = writeIORef r (eval a) - - - --------------------------------------------------------------------------------- --- Example --------------------------------------------------------------------------------- - -type MyProgram a = Program (If :+: Loop :+: Ref) a - -iff :: Exp Bool -> MyProgram a -> MyProgram a -> MyProgram a -iff c thn els = singleInj $ If c thn els - -loop :: Exp Int -> MyProgram () -> MyProgram () -loop n = singleInj . Loop n - -newRef :: Exp a -> MyProgram (IORef a) -newRef = singleInj . NewRef - -getRef :: IORef a -> MyProgram (Exp a) -getRef = singleInj . GetRef - -setRef :: IORef a -> Exp a -> MyProgram () -setRef r = singleInj . SetRef r - -prog :: MyProgram (Exp Int) -prog = do - r <- newRef 0 - loop 10 $ do - a <- getRef r - iff (Eq a 3) - (setRef r 100) - (setRef r (a+1)) - singleInj $ GetRef r - -main = fmap eval $ interpret prog - diff --git a/operational-alacarte.cabal b/operational-alacarte.cabal --- a/operational-alacarte.cabal +++ b/operational-alacarte.cabal @@ -1,9 +1,20 @@ name: operational-alacarte -version: 0.1.1 +version: 0.2 synopsis: A version of Operational suitable for extensible EDSLs description: A version of Operational \[1\] suitable for EDSLs extensible via data types à la carte. . + This library provides two important extensions to + Operational: + . + 1. The ability for instructions to refer to sub-programs in + a generic way. (This is a key to obtaining an extensible + library.) + . + 2. Generic interpretation of programs, including + sub-programs and other sub-structures (e.g. + expressions). + . More information is found in the documentation of "Control.Monad.Operational.Higher". . @@ -12,7 +23,8 @@ license-file: LICENSE author: Emil Axelsson maintainer: emax@chalmers.se -copyright: Copyright 2015 Emil Axelsson, Heinrich Apfelmus +copyright: Copyright (c) 2015 Emil Axelsson, Heinrich Apfelmus + Copyright (c) 2016 Emil Axelsson homepage: https://github.com/emilaxelsson/operational-alacarte bug-reports: https://github.com/emilaxelsson/operational-alacarte/issues category: Language @@ -31,15 +43,15 @@ default-language: Haskell2010 default-extensions: + DataKinds DeriveDataTypeable DeriveFunctor FlexibleInstances GADTs - KindSignatures MultiParamTypeClasses + PolyKinds Rank2Types ScopedTypeVariables - TypeFamilies TypeOperators -- DeriveDataTypeable only needed for GHC < 7.10 @@ -53,17 +65,11 @@ test-suite Examples type: exitcode-stdio-1.0 - hs-source-dirs: examples + hs-source-dirs: examples tests - main-is: Simple.hs + main-is: Tests.hs default-language: Haskell2010 - - default-extensions: - GADTs - KindSignatures - MultiParamTypeClasses - TypeOperators build-depends: base, diff --git a/src/Control/Monad/Operational/Higher.hs b/src/Control/Monad/Operational/Higher.hs --- a/src/Control/Monad/Operational/Higher.hs +++ b/src/Control/Monad/Operational/Higher.hs @@ -3,15 +3,17 @@ -- | = Introduction -- -- This module gives an alternative to the Operational package \[1\], in which --- instructions are higher-order functors, parameterized on the program monad +-- instructions can be higher-order functors, parameterized on the program monad -- that they are part of. This makes it possible to define instruction sets --- compositionally using ':+:'. In the normal Operational, this can be done for --- simple instructions, but here it can be done even for \"control --- instructions\" -- instructions that take program as arguments. +-- compositionally using ':+:'. In the normal Operational, this could be done +-- for simple instructions, but here it can be done even for \"control +-- instructions\" -- instructions that take programs as arguments. -- -- For general information about the ideas behind this module, see the --- Operational package: +-- Operational package \[1\]. -- +-- \[1\] +-- -- = Example -- -- (Full code found in @@ -20,25 +22,28 @@ -- An \"if\" instruction can be defined as follows: -- -- @ --- data If p a where --- If :: Exp `Bool` -> p a -> p a -> If p a +-- data If fs a where +-- If :: Exp `Bool` -> prog a -> prog a -> If (`Param1` prog) a -- @ -- --- Note the use of the type parameter @p@ to refer to sub-programs. (@Exp@ is +-- Note the use of the type parameter @prog@ to refer to sub-programs. (@Exp@ is -- some type representing pure expressions.) -- +-- The type @(`Param1` prog)@ can be seen as a type-level list with one element +-- @prog@. (See "Data.ALaCarte" for more details on parameter lists.) +-- -- We can now make program types that combine several instructions; e.g.: -- --- @type MyProgram a = `Program` (If `:+:` Loop `:+:` ...) a@ +-- @type MyProgram = `Program` (If `:+:` Loop `:+:` ...) `Param0`@ -- --- Here the sub-programs of @If@ (and @Loop@, etc.) will have the type --- @MyProgram@. With the original Operational package, we would have to --- hard-code a specific type for the sub-programs of @If@ (or make @MyProgram@ a --- recursive newtype, as noted by the author of Operational). +-- 'Program' is a recursive type that sets the type of the sub-programs of @If@ +-- (and @Loop@, etc.) to @MyProgram@. With the original Operational package, we +-- would have to hard-code a specific type for the sub-programs of @If@ (or make +-- @MyProgram@ a recursive newtype, as noted by the author of Operational). -- --- Interpretation of 'Program' can be done using +-- Interpretation of 'Program' in a monad @m@ can be done using -- --- @`interpret` :: (`Interp` i m, `HFunctor` i, `Monad` m) => `Program` i a -> m a@ +-- @`interpret` :: (`Interp` i m fs, `HFunctor` i, `Monad` m) => `Program` i fs a -> m a@ -- -- In order to use this function, @If@ needs to be an instance of 'Interp' and -- 'HFunctor'. The 'HFunctor' instance is straightforward: @@ -48,12 +53,12 @@ -- `hfmap` f (If c thn els) = If c (f thn) (f els) -- @ -- --- The 'Interp' type class is parameterized both on the instruction and the --- destination monad. For example, interpretation of @If@ in the IO monad might --- look as follows: +-- The 'Interp' type class is parameterized both on the instruction type and the +-- destination monad. For example, interpretation of @If@ in the 'IO' monad +-- might look as follows: -- -- @ --- instance `Interp` If `IO` where +-- instance `Interp` If `IO` fs where -- `interp` (If c thn els) = if eval c then thn else els -- @ -- @@ -63,6 +68,137 @@ -- interpret any expression type @(I1 `:+:` I2 `:+:` I3 `:+:` ...)@ to 'IO', as -- long as the individual instructions (@I1@, @I2@, etc.) have 'Interp' -- instances for 'IO'. +-- +-- = Bi-functorial instructions +-- +-- The type @(`Param1` prog)@ in the result of @If@ above says that the +-- instruction has one sub-structure whose type is @prog@. The advanced example +-- +-- shows a version of @If@ that has two parameters: +-- +-- @ +-- If :: exp `Bool` -> prog a -> prog a -> If (`Param2` prog exp) a +-- @ +-- +-- @prog@ represents sub-programs and @exp@ represents expressions (@Exp Bool@ +-- has been replaced with @exp Bool@). +-- +-- This new @If@ instruction is a higher-order /bi-functor/ (see 'HBifunctor'). +-- +-- The advantage of parameterizing instructions on expressions is that it lets +-- us define generic functions, such as `interpretBi`, which decouple the +-- interpretation of instructions from the interpretation of expressions. +-- +-- = Generalized interface +-- +-- We have seen two examples of @If@ with a parameter list of one and two +-- arguments respectively (@(`Param1` prog)@ and @(`Param2` prog exp)@). There +-- is nothing stopping us from having instructions with more parameters. For +-- example, we could make a version of @If@ that takes an extra type class +-- constraint @pred@ as parameter: +-- +-- @ +-- If :: pred a => exp `Bool` -> prog a -> prog a -> If (`Param3` prog exp pred) a +-- @ +-- +-- (See the documentation to "Data.ALaCarte" regarding why it is a good idea to +-- make @pred@ part of the parameter list rather than just making it a separate +-- parameter.) +-- +-- In fact, it is possible to have arbitrarily many parameters to instructions +-- (but the type synonyms for parameter lists stop at 'Param4'). +-- +-- The functions and types in this module (and "Data.ALaCarte") are designed to +-- be generic in the sense that things that work for parameter lists of /N/ +-- elements also work for parameter lists of more elements. For example, the +-- function 'interpret' mentioned above requires the instruction @i@ to be a +-- higher-order functor, but it also works for high-order bi-functors, and for +-- the last version of @If@ that has an additional parameter @pred@. +-- +-- = Typical use +-- +-- Here we give specialized type signatures for a selection of functions for +-- different uses of the general interface. +-- +-- . +-- +-- __Functorial instructions with no extra parameters__ +-- +-- This scenario is used in . +-- +-- @ +-- `singleton` :: instr (`Param1` (`ProgramT` instr `Param0` m)) a -> `ProgramT` instr `Param0` m a +-- +-- `interpretWithMonad` +-- :: (`HFunctor` instr, `Monad` m) +-- => (forall b . instr (`Param1` m) b -> m b) +-- -> `Program` instr `Param0` a -> m a +-- +-- `interpret` +-- :: (`Interp` i m `Param0`, `HFunctor` i, `Monad` m) +-- => `Program` i `Param0` a -> m a +-- @ +-- +-- . +-- +-- __Functorial instructions with extra parameter__ +-- +-- Like the previous scenario but with an extra parameter @p@ (poly-kinded) that instructions can use for anything. +-- +-- @ +-- `singleton` :: instr (`Param2` (`ProgramT` instr (`Param1` p) m) p) a -> `ProgramT` instr (`Param1` p) m a +-- +-- `interpretWithMonad` +-- :: (`HFunctor` instr, `Monad` m) +-- => (forall b . instr (`Param2` m p) b -> m b) +-- -> `Program` instr (`Param1` p) a -> m a +-- +-- `interpret` +-- :: (`Interp` i m (`Param1` p), `HFunctor` i, `Monad` m) +-- => `Program` i (`Param1` p) a -> m a +-- @ +-- +-- . +-- +-- __Bi-functorial instructions with no extra parameters__ +-- +-- This scenario is used in . +-- +-- The parameter @exp@ is an extra interpreted structure that e.g. can represent expressions. +-- +-- @ +-- `singleton` :: instr (`Param2` (`ProgramT` instr (`Param1` exp) m) exp) a -> `ProgramT` instr (`Param1` exp) m a +-- +-- `interpretWithMonadBi` +-- :: (`HBifunctor` instr, `Functor` m, `Monad` m) +-- => (forall b . exp b -> m b) +-- -> (forall b . instr (`Param2` m m) b -> m b) +-- -> `Program` instr (`Param1` exp) a -> m a +-- +-- `interpret` +-- :: (`InterpBi` i m `Param0`, `HBifunctor` i, `Functor` m, `Monad` m) +-- => (forall b . exp b -> m b) -> `Program` i (`Param1` exp) a -> m a +-- @ +-- +-- . +-- +-- __Bi-functorial instructions with extra parameter__ +-- +-- Like the previous scenario but with an extra parameter @p@ (poly-kinded) that instructions can use for anything. +-- +-- @ +-- `singleton` :: instr (`Param3` (`ProgramT` instr (`Param2` exp p) m) exp p) a -> `ProgramT` instr (`Param2` exp p) m a +-- +-- `interpretWithMonadBi` +-- :: (`HBifunctor` instr, `Functor` m, `Monad` m) +-- => (forall b . exp b -> m b) +-- -> (forall b . instr (`Param3` m m p) b -> m b) +-- -> `Program` instr (`Param2` exp p) a -> m a +-- +-- `interpret` +-- :: (`InterpBi` i m (`Param1` p), `HBifunctor` i, `Functor` m, `Monad` m) +-- => (forall b . exp b -> m b) -> `Program` i (`Param2` exp p) a -> m a +-- @ module Control.Monad.Operational.Higher ( module Control.Monad @@ -81,14 +217,20 @@ , interpret , ProgramViewT (..) , ProgramView (..) + , ProgViewT + , ProgView , viewT , view , unview - -- * Instructions parameterized on expression language - , IExp - , injE - , prjE - , singleE + -- * Bi-functorial instructions + , interpretWithMonadBiT + , interpretWithMonadBi + , InterpBi (..) + , interpretBiT + , interpretBi + , Reexpressible (..) + , reexpress + , reexpressEnv ) where @@ -98,120 +240,135 @@ #endif import Control.Monad import Control.Monad.Identity -import Control.Monad.Trans +import Control.Monad.Reader import Data.Typeable import Data.ALaCarte ----------------------------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- * Program monad ----------------------------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- | Representation of programs parameterized by the primitive instructions -data ProgramT instr m a +-- (transformer version) +data ProgramT instr fs m a where - Lift :: m a -> ProgramT instr m a - Bind :: ProgramT instr m a -> (a -> ProgramT instr m b) -> ProgramT instr m b - Instr :: instr (ProgramT instr m) a -> ProgramT instr m a + Lift :: m a -> ProgramT instr fs m a + Bind :: ProgramT instr fs m a -> + (a -> ProgramT instr fs m b) -> ProgramT instr fs m b + Instr :: instr '(ProgramT instr fs m, fs) a -> ProgramT instr fs m a #if __GLASGOW_HASKELL__>=708 deriving Typeable #endif --- | Representation of programs parameterized by its primitive instructions -type Program instr = ProgramT instr Identity +-- | Representation of programs parameterized by the primitive instructions +type Program instr fs = ProgramT instr fs Identity -instance Monad m => Functor (ProgramT instr m) +instance Monad m => Functor (ProgramT instr fs m) where fmap = liftM -instance Monad m => Applicative (ProgramT instr m) +instance Monad m => Applicative (ProgramT instr fs m) where pure = return (<*>) = ap -instance Monad m => Monad (ProgramT instr m) +instance Monad m => Monad (ProgramT instr fs m) where return = Lift . return (>>=) = Bind -instance MonadTrans (ProgramT instr) +instance MonadTrans (ProgramT instr fs) where lift = Lift --- | Make a program from a single primitive instruction -singleton :: instr (ProgramT instr m) a -> ProgramT instr m a +-- | Make a program from a single instruction +singleton :: instr '(ProgramT instr fs m, fs) a -> ProgramT instr fs m a singleton = Instr --- | Make a program from a single primitive instruction -singleInj :: (i :<: instr) => i (ProgramT instr m) a -> ProgramT instr m a +-- | Make a program from a single instruction +singleInj :: (i :<: instr) => + i '(ProgramT instr fs m, fs) a -> ProgramT instr fs m a singleInj = Instr . inj ----------------------------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- * Interpretation ----------------------------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- --- | Lift a simple program to a program over a monad @m@ -liftProgram :: forall instr m a . (HFunctor instr, Monad m) => Program instr a -> ProgramT instr m a +-- | Lift a program to a program transformer +liftProgram :: forall instr fs m a . (HFunctor instr, Monad m) + => Program instr fs a -- ^ Program to lift + -> ProgramT instr fs m a liftProgram = go where - go :: Program instr b -> ProgramT instr m b + go :: Program instr fs b -> ProgramT instr fs m b go (Lift a) = Lift $ return $ runIdentity a go (Bind p k) = Bind (go p) (go . k) go (Instr i) = Instr $ hfmap go i -- | Interpret a program in a monad -interpretWithMonadT :: forall instr m n a . (HFunctor instr, Monad m) - => (forall b . instr m b -> m b) - -> (forall b . n b -> m b) - -> ProgramT instr n a -> m a -interpretWithMonadT runi runn = go +interpretWithMonadT :: forall instr fs m n a . (HFunctor instr, Monad m) + => (forall b . instr '(m,fs) b -> m b) -- ^ Interpretation of instructions + -> (forall b . n b -> m b) -- ^ Interpretation of the underlying monad + -> ProgramT instr fs n a -> m a +interpretWithMonadT inti intn = go where - go :: ProgramT instr n b -> m b - go (Lift a) = runn a + go :: ProgramT instr fs n b -> m b + go (Lift a) = intn a go (Bind p k) = go p >>= (go . k) - go (Instr i) = runi $ hfmap go i + go (Instr i) = inti $ hfmap go i -- | Interpret a program in a monad -interpretWithMonad :: (HFunctor instr, Monad m) => - (forall b . instr m b -> m b) -> Program instr a -> m a +interpretWithMonad :: (HFunctor instr, Monad m) + => (forall b . instr '(m,fs) b -> m b) -- ^ Interpretation of instructions + -> Program instr fs a -> m a interpretWithMonad interp = interpretWithMonadT interp (return . runIdentity) --- | @`Interp` i m@ represents the fact that @i@ can be interpreted in the monad @m@ -class Interp i m +-- | @`Interp` instr m fs@ represents the fact that @instr@ can be interpreted +-- in the monad @m@ +class Interp instr m fs where -- | Interpret an instruction in a monad - interp :: i m a -> m a + interp :: instr '(m,fs) a -> m a -instance (Interp i1 m, Interp i2 m) => Interp (i1 :+: i2) m +instance (Interp i1 m fs, Interp i2 m fs) => Interp (i1 :+: i2) m fs where interp (Inl i) = interp i interp (Inr i) = interp i --- | Interpret a program in a monad. The interpretation of primitive instructions is provided by the --- 'Interp' class. -interpretT :: (Interp i m, HFunctor i, Monad m) => (forall b . n b -> m b) -> ProgramT i n a -> m a +-- | Interpret a program in a monad. The interpretation of instructions is +-- provided by the 'Interp' class. +interpretT :: (Interp i m fs, HFunctor i, Monad m) + => (forall b . n b -> m b) -- ^ Interpretation of the underlying monad + -> ProgramT i fs n a -> m a interpretT = interpretWithMonadT interp --- | Interpret a program in a monad. The interpretation of primitive instructions is provided by the --- 'Interp' class. -interpret :: (Interp i m, HFunctor i, Monad m) => Program i a -> m a +-- | Interpret a program in a monad. The interpretation of instructions is +-- provided by the 'Interp' class. +interpret :: (Interp i m fs, HFunctor i, Monad m) => Program i fs a -> m a interpret = interpretWithMonad interp -- | View type for inspecting the first instruction -data ProgramViewT instr m a +data ProgramViewT instr fs m a where - Return :: a -> ProgramViewT instr m a - (:>>=) :: instr (ProgramT instr m) b -> (b -> ProgramT instr m a) -> ProgramViewT instr m a + Return :: a -> ProgramViewT instr fs m a + (:>>=) + :: instr '(ProgramT instr fs m, fs) b + -> (b -> ProgramT instr fs m a) + -> ProgramViewT instr fs m a -- | View type for inspecting the first instruction -type ProgramView instr = ProgramViewT instr Identity +type ProgramView instr fs = ProgramViewT instr fs Identity +type ProgViewT instr m = ProgramViewT instr '() m +type ProgView instr = ProgramView instr '() + -- | View function for inspecting the first instruction -viewT :: Monad m => ProgramT instr m a -> m (ProgramViewT instr m a) +viewT :: Monad m => ProgramT instr fs m a -> m (ProgramViewT instr fs m a) viewT (Lift m) = m >>= return . Return viewT (Lift m `Bind` g) = m >>= viewT . g viewT ((m `Bind` g) `Bind` h) = viewT (m `Bind` (\x -> g x `Bind` h)) @@ -219,49 +376,158 @@ viewT (Instr i) = return (i :>>= return) -- | View function for inspecting the first instruction -view :: HFunctor instr => Program instr a -> ProgramView instr a +view :: HFunctor instr => Program instr fs a -> ProgramView instr fs a view = runIdentity . viewT -- | Turn a 'ProgramViewT' back to a 'Program' -unview :: Monad m => ProgramViewT instr m a -> ProgramT instr m a +unview :: Monad m => ProgramViewT instr fs m a -> ProgramT instr fs m a unview (Return a) = return a unview (i :>>= k) = singleton i >>= k -------------------------------------------------------------------------------- --- * Instructions parameterized on expression language +-- * Bi-functorial instructions -------------------------------------------------------------------------------- --- | Extract the expression type from an instruction set +-- | Bi-functorial version of 'interpretWithMonadT' -- --- 'IExp' is needed to avoid types like --- @(`SomeInstr` exp `:<:` i) => `Program` i ()@. Here it is not possible to --- constrain @exp@ by constraining @i@, so the instance search will always fail. --- Functions like 'injE' solve this by using 'IExp' to determine @exp@ from @i@. --- For this to work, one must use an instruction set @i@ that has an instance of --- 'IExp'. +-- Bi-functorial instructions are of the form @instr '(prog, '(exp, ...)) a@, +-- where @prog@ is a representation of sub-programs, and @exp@ is a +-- representation of some other sub-structure, e.g. expressions. +-- 'interpretWithMonadBiT' allows interpreting both these kinds of +-- sub-structures in a generic way. +interpretWithMonadBiT :: (HBifunctor instr, Functor m, Monad m, Monad n) + => (forall b . exp b -> m b) -- ^ Interpretation of the @exp@ sub-structure + -> (forall b . instr '(m,'(m,fs)) b -> m b) -- ^ Interpretation of instructions + -> (forall b . n b -> m b) -- ^ Interpretation of the underlying monad + -> ProgramT instr '(exp,fs) n a -> m a +interpretWithMonadBiT inte inti intn = interpretWithMonadT + (\i -> inti $ hbimap id inte i) + intn + +-- | Bi-functorial version of 'interpretWithMonad' -- --- It is common for all instructions in a sum (using ':+:') to use the same --- expression type. For this common case, it is enough to get the expression --- type from the first summand. This can be achieved by giving two 'IExp' --- instances for each instruction: +-- See explanation of 'interpretWithMonadBiT'. +interpretWithMonadBi :: (HBifunctor instr, Functor m, Monad m) + => (forall b . exp b -> m b) -- ^ Interpretation of the @exp@ sub-structure + -> (forall b . instr '(m,'(m,fs)) b -> m b) -- ^ Interpretation of instructions + -> Program instr '(exp,fs) a -> m a +interpretWithMonadBi inte inti = interpretWithMonadBiT inte inti + (return . runIdentity) + +-- | @`InterpBi` instr m fs@ represents the fact that the bi-functorial +-- instruction @instr@ can be interpreted in the monad @m@ +class InterpBi instr m fs + where + -- | Interpret a bi-functorial instruction in a monad + interpBi :: instr '(m,'(m,fs)) a -> m a + +instance (InterpBi i1 m fs, InterpBi i2 m fs) => InterpBi (i1 :+: i2) m fs + where + interpBi (Inl i) = interpBi i + interpBi (Inr i) = interpBi i + +-- | Interpret a program in a monad. The interpretation of instructions is +-- provided by the 'InterpBi' class. +interpretBiT :: (InterpBi i m fs, HBifunctor i, Functor m, Monad m, Monad n) + => (forall b . exp b -> m b) -- ^ Interpretation of the @exp@ sub-structure + -> (forall b . n b -> m b) -- ^ Interpretation of the underlying monad + -> ProgramT i '(exp,fs) n a -> m a +interpretBiT inte = interpretWithMonadBiT inte interpBi + -- The reason for only getting the interpretation of instructions from a class + -- (and not the interpretation of `exp`), is that `interpBi` is constructed + -- automatically for instructions built using `:+:`. It would be quite + -- cumbersome to construct this function by hand. + +-- | Interpret a program in a monad. The interpretation of instructions is +-- provided by the 'InterpBi' class. +interpretBi :: (InterpBi i m fs, HBifunctor i, Functor m, Monad m) + => (forall b . exp b -> m b) -- ^ Interpretation of the @exp@ sub-structure + -> Program i '(exp,fs) a -> m a +interpretBi inte = interpretWithMonadBi inte interpBi + +-- | Reexpressible types -- --- @ --- type instance `IExp` (SomeInstr exp) = exp --- type instance `IExp` (SomeInstr exp `:+:` i) = exp --- @ -type family IExp (i :: (* -> *) -> * -> *) :: * -> * +-- @i@ is a bi-functorial instruction where, in the type @i '(p,'(e1,...)) a@, +-- sub-structure @e1@ can be converted to a different sub-structure @e2@. +-- +-- @e1@ and @e2@ typically represent expressions; hence the name +-- \"reexpressible\". +class HBifunctor i => Reexpressible i instr + where + -- | Rewrite an instruction changing its \"expression\" sub-structure + reexpressInstr :: Monad m + => (forall b . exp1 b -> ProgramT instr '(exp2,fs) m (exp2 b)) + -- ^ Conversion of the \"expression\" sub-structure + -> i '(ProgramT instr '(exp2,fs) m, '(exp1, fs)) a + -> ProgramT instr '(exp2,fs) m a + reexpressInstr reexp + = flip runReaderT () + . reexpressInstrEnv (lift . reexp) + . hbimap lift id --- | Inject an instruction that is parameterized by an expression type -injE :: (i (IExp instr) :<: instr) => i (IExp instr) m a -> instr m a -injE = inj + -- | Rewrite an instruction changing its \"expression\" sub-structure + -- + -- As an example of how to define this function, take the following + -- instruction that just puts a tag on a sub-program: + -- + -- > data Tag fs a + -- > where + -- > Tag :: String -> prog () -> Tag (Param2 prog exp) () + -- + -- To define `reexpressInstrEnv` we have to use a combination of `ReaderT` + -- and `runReaderT`: + -- + -- > instance (Tag :<: instr) => Reexpressible Tag instr + -- > where + -- > reexpressInstrEnv reexp (Tag tag prog) = ReaderT $ \env -> + -- > singleInj $ Tag tag (flip runReaderT env prog) + reexpressInstrEnv :: Monad m + => ( forall b . + exp1 b -> ReaderT env (ProgramT instr '(exp2,fs) m) (exp2 b) + ) + -- ^ Conversion of the \"expression\" sub-structure + -> i '(ReaderT env (ProgramT instr '(exp2,fs) m), '(exp1, fs)) a + -> ReaderT env (ProgramT instr '(exp2,fs) m) a + -- The reason for only allowing `ReaderT` is that for instructions that + -- have sub-programs, this seems to be the only possible transformer for + -- which `reexpressInstrEnv` can be defined (among common monads). E.g. + -- the above trick with `runReaderT` doesn't work for `StateT`. --- | Project an instruction that is parameterized by an expression type -prjE :: (i (IExp instr) :<: instr) => instr m a -> Maybe (i (IExp instr) m a) -prjE = prj +instance (Reexpressible i1 instr, Reexpressible i2 instr) => + Reexpressible (i1 :+: i2) instr + where + reexpressInstr reexp (Inl i) = reexpressInstr reexp i + reexpressInstr reexp (Inr i) = reexpressInstr reexp i + reexpressInstrEnv reexp (Inl i) = reexpressInstrEnv reexp i + reexpressInstrEnv reexp (Inr i) = reexpressInstrEnv reexp i --- | Create a program from an instruction that is parameterized by an expression type -singleE :: (i (IExp instr) :<: instr) => i (IExp instr) (ProgramT instr m) a -> ProgramT instr m a -singleE = singleton . inj +-- | Rewrite a program changing its expression type (assuming that the second +-- sub-structure of the instruction type represents expressions) +-- +-- Conversion of expressions is done in the target monad, so pure expressions +-- are allowed to expand to monadic code. This can be used e.g. to \"compile\" +-- complex expressions into simple expressions with supporting monadic code. +reexpress :: (Reexpressible instr1 instr2, Monad m) + => (forall b . exp1 b -> ProgramT instr2 '(exp2,fs) m (exp2 b)) + -- ^ Conversion of expressions + -> ProgramT instr1 '(exp1,fs) m a -> ProgramT instr2 '(exp2,fs) m a +reexpress reexp p = interpretWithMonadT (reexpressInstr reexp) lift p + +-- | Rewrite a program changing its expression type (assuming that the second +-- sub-structure of the instruction type represents expressions) +-- +-- Conversion of expressions is done in the target monad, so pure expressions +-- are allowed to expand to monadic code. This can be used e.g. to \"compile\" +-- complex expressions into simple expressions with supporting monadic code. +reexpressEnv :: (Reexpressible instr1 instr2, Monad m) + => ( forall b . + exp1 b -> ReaderT env (ProgramT instr2 '(exp2,fs) m) (exp2 b) + ) + -- ^ Conversion of expressions + -> ProgramT instr1 '(exp1,fs) m a + -> ReaderT env (ProgramT instr2 '(exp2,fs) m) a +reexpressEnv reexp p = + interpretWithMonadT (reexpressInstrEnv reexp) (lift . lift) p diff --git a/src/Data/ALaCarte.hs b/src/Data/ALaCarte.hs --- a/src/Data/ALaCarte.hs +++ b/src/Data/ALaCarte.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PolyKinds #-} #ifndef MIN_VERSION_GLASGOW_HASKELL #define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0 @@ -11,20 +10,121 @@ {-# LANGUAGE OverlappingInstances #-} #endif --- | Higher-order (and poly-kinded) implementation of Data Types à la Carte [1] +-- | This module provides a generalized implementation of data types à la carte +-- [1]. It supports (higher-order) functors with 0 or more functorial parameters +-- and additional non-functorial parameters, all with a uniform interface. -- -- \[1\] W. Swierstra. Data Types à la Carte. -- /Journal of Functional Programming/, 18(4):423-436, 2008, -- . +-- +-- (This module is preferably used with the GHC extensions @DataKinds@ and +-- @PolyKinds@.) +-- +-- = Usage +-- +-- Compared to traditional data types à la carte, an extra poly-kinded parameter +-- has been added to ':+:' and to the parameters of ':<:'. Standard data types à +-- la carte is obtained by setting this parameter to @()@. That gives us the +-- following type for 'Inl': +-- +-- @`Inl` :: h1 () a -> (h1 `:+:` h2) () a@ +-- +-- Here, @h1 ()@ and @(h1 `:+:` h2) ()@ are functors. +-- +-- By setting the extra parameter to a functor @f :: * -> *@, we obtain this +-- type: +-- +-- @`Inl` :: h1 f a -> (h1 `:+:` h2) f a@ +-- +-- This makes @h1@ and @(h1 `:+:` h2)@ higher-order functors. +-- +-- Finally, by setting the parameter to a type-level pair of functors +-- @'(f,g) :: (* -> *, * -> *)@, we obtain this type: +-- +-- @`Inl` :: h1 '(f,g) a -> (h1 `:+:` h2) '(f,g) a@ +-- +-- This makes @h1@ and @(h1 `:+:` h2)@ higher-order bi-functors. +-- +-- Alternatively, we can represent all three cases above using heterogeneous +-- lists of functors constructed using @'(,)@ and terminated by @()@: +-- +-- @ +-- `Inl` :: h1 () a -> (h1 `:+:` h2) () a -- functor +-- `Inl` :: h1 '(f,()) a -> (h1 `:+:` h2) '(f,()) a -- higher-order functor +-- `Inl` :: h1 '(f,'(g,())) a -> (h1 `:+:` h2) '(f,'(g,())) a -- higher-order bi-functor +-- @ +-- +-- This view is taken by the classes 'HFunctor' and 'HBifunctor'. An 'HFunctor' +-- takes a parameter of kind @(* -> *, k)@; i.e. it has /at least/ one +-- functorial parameter. A 'HBiFunctor' takes a parameter of kind +-- @(* -> *, (* -> *, k))@; i.e. it has /at least/ two functorial parameters. +-- +-- = Aliases for parameter lists +-- +-- To avoid ugly types such as @'(f,'(g,()))@, this module exports the synonyms +-- 'Param0', 'Param1', 'Param2', etc. for parameter lists up to size 4. These +-- synonyms allow the module to be used without the @DataKinds@ extension. +-- +-- = Extra type parameters +-- +-- Recall that an 'HFunctor' takes a parameter of kind @(* -> *, k)@, and an +-- 'HBifunctor' takes a parameter of kind @(* -> *, (* -> *, k))@. Since @k@ is +-- polymorphic, it means that it is possible to add extra parameters in place of +-- @k@. +-- +-- For example, a user can define the following type representing addition in +-- some language: +-- +-- @ +-- data Add fs a where +-- Add :: (`Num` a, pred a) => f a -> f a -> Add (`Param2` f pred) a +-- +-- instance `HFunctor` Add where +-- `hfmap` f (Add a b) = Add (f a) (f b) +-- @ +-- +-- Here, @Add@ has a functorial parameter @f@, and an extra non-functorial +-- parameter @pred@ that provides a constraint for the type @a@. +-- +-- An obvious alternative would have been to just make @pred@ a separate +-- parameter to @Add@: +-- +-- @ +-- data Add pred fs a where +-- Add :: (`Num` a, pred a) => f a -> f a -> Add pred (`Param1` f) a +-- +-- instance `HFunctor` (Add pred) where +-- `hfmap` f (Add a b) = Add (f a) (f b) +-- @ +-- +-- However, this has the disadvantage of being hard to use together with the +-- ':<:' class. For example, we might want to define the following \"smart +-- constructor\" for @Add@: +-- +-- @ +-- mkAdd :: (`Num` a, pred a, Add pred `:<:` h) => f a -> f a -> h (`Param1` f) a +-- mkAdd a b = `inj` (Add a b) +-- @ +-- +-- Unfortunately, the above type is ambiguous, because @pred@ is completely +-- free. Assuming that @h@ is a type of the form @(... `:+:` Add `Show` `:+:` ...)@, +-- we would like to infer @(pred ~ `Show`)@, but this would require extra +-- machinery, such as a type family that computes @pred@ from @h@. +-- +-- By putting @pred@ in the parameter list, we avoid the above problem. We also +-- get the advantage that the same @pred@ parameter is distributed to all types +-- in a sum constructed using ':+:'. This makes it easier to, for example, +-- change the @pred@ parameter uniformly throughout an expression. module Data.ALaCarte where -- | Coproducts -data (f :+: g) a b - = Inl (f a b) - | Inr (g a b) +data (h1 :+: h2) fs a + = Inl (h1 fs a) + | Inr (h2 fs a) #if __GLASGOW_HASKELL__>=708 deriving (Functor) #endif @@ -33,10 +133,10 @@ -- | A constraint @f `:<:` g@ expresses that the signature @f@ is subsumed by -- @g@, i.e. @f@ can be used to construct elements in @g@. -class f :<: g +class sub :<: sup where - inj :: f a b -> g a b - prj :: g a b -> Maybe (f a b) + inj :: sub fs a -> sup fs a + prj :: sup fs a -> Maybe (sub fs a) instance {-# OVERLAPPING #-} (f :<: f) where @@ -59,10 +159,46 @@ class HFunctor h where -- | Higher-order 'fmap' - hfmap :: (forall b . m b -> n b) -> h m a -> h n a + hfmap :: (forall b . f b -> g b) -> h '(f,fs) a -> h '(g,fs) a instance (HFunctor h1, HFunctor h2) => HFunctor (h1 :+: h2) where hfmap f (Inl i) = Inl (hfmap f i) hfmap f (Inr i) = Inr (hfmap f i) + +-- | Higher-order bi-functors +class HFunctor h => HBifunctor h + where + -- | Higher-order \"bimap\" + hbimap :: (Functor f, Functor g) + => (forall b . f b -> g b) + -> (forall b . i b -> j b) + -> h '(f,'(i,fs)) a + -> h '(g,'(j,fs)) a + +instance (HBifunctor h1, HBifunctor h2) => HBifunctor (h1 :+: h2) + where + hbimap f g (Inl i) = Inl (hbimap f g i) + hbimap f g (Inr i) = Inr (hbimap f g i) + + + +-------------------------------------------------------------------------------- +-- * Parameter lists +-------------------------------------------------------------------------------- + +-- | Empty parameter list +type Param0 = () + +-- | Singleton parameter list +type Param1 a = '(a,Param0) + +-- | Two-element parameter list +type Param2 a b = '(a, Param1 b) + +-- | Three-element parameter list +type Param3 a b c = '(a, Param2 b c) + +-- | Four-element parameter list +type Param4 a b c d = '(a, Param3 b c d) diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,7 @@ +import qualified Simple +import qualified Advanced + +main = do + Simple.main + Advanced.main +