{-# 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))