Ticket #114: ControlMonadMatch.hs

{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}

{-
  support module for working with lambda-matches
 -}

module ControlMonadMatch where

import Control.Monad
import Data.Maybe

infixr >|

-- extract first successful match if any, splicing match monad
-- into pure expressions (so: splice (|..->e) = \..->e)

-- we use Maybe as the default matching monad
splice :: Ex (Maybe a) a b c => b -> c
splice  = ex (maybe (error "no match in splice") id)

-- using (Either String), we can preserve error messages
spliceE :: Ex (Either String a) a b c => b -> c
spliceE = ex (either error id)

-- using List
spliceL :: Ex ([] a) a b c => b -> c
spliceL = ex (list (error "no match in spliceL") head)
  where list n c l = if null l then n else c l

allMatches matches = ex id matches

-- compose two lambda-match groups, so that match failure 
-- in 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

-- explicit match failure, with message 
matchError msg = lift0 $ fail msg 

-- default alternative
fall_through x = lift0 $ return x

-- 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

-- 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 a = Match { unMatch :: m a } deriving Show

-- useful when writing out the translation by hand
match rhs = Match $ return rhs

-- Match m is just a tagged Monad m
instance Monad m => Monad (Match m) where
  fail = Match . fail
  return = Match . return
  a >>= b = Match $ unMatch a >>= (unMatch . b)

-- join nested matches, if MatchMonads are the same
-- the parameter prefix of the outer match remains,
-- but may be extended (via nest') if the inner match
-- has parameters as well
nest :: (Ex (m a) b da dc, Nest (Match m a) b,
         MatchMonad a m, MatchMonad dc m, MatchMonad da m) 
     => da -> dc
nest match = ex (nest' . Match) match

-- auxiliary
-- base case: join the tagged match monads themselves
-- function case: shift parameters from inner to outer match 
--                using eta-extension to promise functions where
--                there used to be matches possibly returning functions;
class Nest a b | a -> b, b -> a where
  nest' :: a -> b

instance Monad m => Nest (Match m (Match m a)) (Match m a) where
  nest' outer = Match $ ex (>>=unMatch) outer 

instance (Nest (Match m b) c, Monad m) => Nest (Match m (a -> b)) (a -> c) where
  nest' outer = (\a-> nest' $ Match $ ex (\inner-> inner >>= \f-> return $ f a) outer)

-- extract match monads from possibly parameterised matches
-- (so that we can relate them, eg, in nest)
class MatchMonad match m | match -> m where annoyingKindConstraint :: match -> m ()
                                            annoyingKindConstraint = undefined
instance MatchMonad (Match m a) m
instance MatchMonad match m => MatchMonad (a->match) m

-- 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 (m a) (Match m 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 (m a) c (Match m 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))