{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
{-
support module for working with lambda-matches
-}
module ControlMonadMatch where
import Control.Monad
import Data.Maybe
infixr >|
-- we use Maybe as the default matching monad, but [] can be fun, too..
-- extract first successful match if any, splicing match monad
-- into pure expressions (so: splice (|..->e) = \..->e)
splice :: Ex (Maybe a) a b c => b -> c
splice = ex fromJust
-- compose two lambda-match groups, so that match failure
-- the first group falls through into the second group
(+++) :: (Lift (a b) c, MonadPlus a) => c -> c -> c
(+++) = lift2 mplus
-- explicit match failure
nomatch :: (Lift (a b) c, MonadPlus a) => c
nomatch = lift0 mzero
-- supply arguments to a match group, without splicing
expr >| matches = matches expr
-- case x of matches becomes syntactic sugar
caseOf x matches = x >| (splice matches)
-- the ok from do-notation translation (Section 3.14)
ok match = ex (>>=id) match
-- useful when writing out the translation by hand
match rhs = Match $ return rhs
-- we wrap lambda-match bodies, to steer lifting
-- (as we do not want to pin down the inner match monad
-- too early, we'd otherwise have too many ambiguities;
-- also, functions can be monads, so we need a marker
-- to know when lifting has reached the match body)
newtype Match m = Match { unMatch :: m } deriving Show
-- lift (mostly MonadPlus) operations over lambda-match parameters
class Lift a d | d -> a where
lift0 :: a -> d
lift1 :: (a -> a) -> d -> d
lift2 :: (a -> a -> a) -> d -> d -> d
instance Lift a (Match a) where
lift0 c = Match c
lift1 f a = Match (f (unMatch a))
lift2 op a b = Match (op (unMatch a) (unMatch b))
instance Lift a c => Lift a (b->c) where
lift0 c = \x-> lift0 c
lift1 f a = \x-> lift1 f (a x)
lift2 op a b = \x-> lift2 op (a x) (b x)
-- extract (with function) from inner match monad
-- (extraction is lifted over lambda-match parameters;
-- we cannot express all functional dependencies,
-- because the inner c could be a function type)
class Ex a c da dc | da -> a, dc da -> c, da c -> dc {- , dc a c -> da -} where
ex :: (a -> c) -> da -> dc
instance Ex a c (Match a) c where
ex f a = (f (unMatch a))
instance Ex a c da dc => Ex a c (b -> da) (b -> dc) where
ex f a = \x->(ex f (a x))