module MonadLab.Reduction (reduceM) where

import Control.Monad
import Language.Haskell.TH

type Env = [(Exp , Exp)]

class Reducible a where
	recurse	:: (Exp -> Exp) -> a -> a
	reduce	:: a -> a
	reduceM	:: Monad m => m a -> m a
	subst	:: Env -> a -> a

	reduce	   = recurse simpleReduction
	reduceM m  = m >>= \r -> return (reduce r)
	subst env  = recurse $ expSubst env
	

instance Reducible Exp where
	recurse f (VarE n)				= f $ VarE n
	recurse f (ConE n)				= f $ ConE n
	recurse f (LitE l)				= f $ LitE l --error "recurse: undefined on LitE"
	recurse f (AppE e1 e2)				= f $ AppE (recurse f e1) (recurse f e2)
	recurse f (InfixE (Just e1) opE (Just e2))	= f $ InfixE (Just $ recurse f e1) (recurse f opE) (Just $ recurse f e2)
	recurse f (InfixE (Just e1) opE Nothing)	= f $ InfixE (Just $ recurse f e1) (recurse f opE) Nothing
	recurse f (InfixE Nothing  opE (Just e2))	= f $ InfixE Nothing (recurse f opE) (Just $ recurse f e2)
	recurse f (InfixE Nothing opE Nothing)		= f $ InfixE Nothing (recurse f opE) Nothing --error "recurse: undefined on partial InfixE application"
	recurse f (LamE pats e)				= f $ LamE pats (recurse f e)
	recurse f (TupE es)				= f $ TupE $ map (recurse f) es
	recurse f (CondE _ _ _)				= error "recurse: undefined on CondE"
	recurse f (LetE decs e)				= f $ LetE (map (recurse f) decs) (recurse f e)
	recurse f (CaseE e matches)			= f $ CaseE (recurse f e) (map (recurse f) matches)
	recurse f (DoE _)				= error "recurse: undefined on DoE"
	recurse f (CompE _)				= error "recurse: undefined on CompE"
	recurse f (ArithSeqE _)				= error "recurse: undefined on ArithSeqE"
	recurse f (ListE es)				= f $ ListE $ map (recurse f) es
	recurse f (SigE _ _)				= error "recurse: undefined on SigE"
	recurse f (RecConE _ _)				= error "recurse: undefined on RecConE"
	recurse f (RecUpdE _ _)				= error "recurse: undefined on RecUpdE"



instance Reducible Dec where
	recurse f (FunD _ _)				= error "recurse: undefined on FunD"
	recurse f (ValD pat body decs)			= ValD pat (recurse f body) (map (recurse f) decs)
	recurse f (DataD _ _ _ _ _)			= error "recurse: undefined on DataD"
	recurse f (NewtypeD _ _ _ _ _)			= error "recurse: undefined on NewtypeD"
	recurse f (TySynD _ _ _)			= error "recurse: undefined on TySynD"
	recurse f (ClassD _ _ _ _ _)			= error "recurse: undefined on ClassD"
	recurse f (InstanceD _ _ _)			= error "recurse: undefined on InstanceD"
	recurse f (SigD _ _)				= error "recurse: undefined on SigD"
	recurse f (ForeignD _)				= error "recurse: undefined on ForeignD"
	

instance Reducible Body where
	recurse f (GuardedB _)				= error "recurse: undefined on GuardedB"
	recurse f (NormalB e)				= NormalB (recurse f e)


instance Reducible Match where
	recurse f (Match pat body decs)			= Match pat (recurse f body) (map (recurse f) decs)



simpleReduction	:: Exp -> Exp
simpleReduction e@(VarE n)				= e
simpleReduction e@(ConE n)				= e
simpleReduction e@(LitE l)				= LitE l --error "simpleReduction: undefined on LitE"
simpleReduction e@(AppE e1 e2)				= case e1 of
								LamE (p:ps) e1'	  -> case bindPatterns p e2 of
											Just env  -> reduce $ LamE ps $ reduce $ subst env e1'
											Nothing   -> e
								otherwise	  -> e
								
simpleReduction e@(InfixE (Just e1) opE (Just e2))	= e
simpleReduction e@(InfixE _ _ _)			= e --error "simpleReduction: undefined on partial InfixE application"
simpleReduction e@(LamE pats e')			= case pats of
								[] 	  -> e'
								otherwise -> e
simpleReduction e@(TupE es)				= e
simpleReduction e@(CondE _ _ _)				= error "simpleReduction: undefined on CondE"
simpleReduction e@(LetE decs e')			= error "simpleReduction: undefined on LetE"
simpleReduction e@(CaseE e' matches)			= e
simpleReduction e@(DoE _)				= error "simpleReduction: undefined on DoE"
simpleReduction e@(CompE _)				= error "simpleReduction: undefined on CompE"
simpleReduction e@(ArithSeqE _)				= error "simpleReduction: undefined on ArithSeqE"
simpleReduction e@(ListE es)				= e
simpleReduction e@(SigE _ _)				= error "simpleReduction: undefined on SigE"
simpleReduction e@(RecConE _ _)				= error "simpleReduction: undefined on RecConE"
simpleReduction e@(RecUpdE _ _)				= error "simpleReduction: undefined on RecUpdE"


expSubst	:: Env -> Exp -> Exp
expSubst env e						= case lookup e env of
								Just x  -> x
								Nothing -> e


bindPatterns :: Pat -> Exp -> Maybe Env
bindPatterns (VarP n)         e  = Just [(VarE n, e)]
bindPatterns (WildP)          _  = Just []
bindPatterns (TupP ps) (TupE es) = if length ps /= length es
				   then Nothing
				   else do
				   	let tupEnvs = map2 bindPatterns ps es
					foldM addEnv [] tupEnvs
				   	where map2 f as bs = map (\(a,b) -> f a b) (zip as bs)
					      addEnv env        Nothing      = Nothing
					      addEnv env    (Just env')      = Just $ env ++ env'
bindPatterns _ _		 = Nothing

--test = bindPatterns p1 e1

var x = VarE $ mkName x
pat x = VarP $ mkName x

e1 = TupE [var "a", TupE [var "b", var "c"]]
p1 = TupP [pat "p1", TupP [pat "p2", pat "p3"]]