content: {-# LANGUAGE TemplateHaskell, PackageImports #-}
  
  module Text.Papillon.List (
  	listDec,
  	optionalDec
  ) where
  
  import Language.Haskell.TH
  import Control.Applicative
  import Control.Monad
  import TemplateHaskell.Compat.V0208 (specifiedPlainTV)
  
  {-
  
  list, list1 :: (MonadPlus m, Applicative m) => m a -> m [a]
  list p = list1 p `mplus` return []
  list1 p = (:) <$> p <*> list p
  
  -}
  
  monadPlusN, mplusN, applicativeN, applyN, applyContN :: Bool -> Name
  monadPlusN True = ''MonadPlus
  monadPlusN False = mkName "MonadPlus"
  applicativeN True = ''Applicative
  applicativeN False = mkName "Applicative"
  mplusN True = 'mplus
  mplusN False = mkName "mplus"
  applyN True = '(<$>)
  applyN False = mkName "<$>"
  applyContN True = '(<*>)
  applyContN False = mkName "<*>"
  
  m, a, p :: Name
  m = mkName "m"
  a = mkName "a"
  p = mkName "p"
  
  listDec :: Name -> Name -> Bool -> Q [Dec]
  listDec list list1 th = do
  	cp1 <- classP (monadPlusN th) [return vm]
  	cp2 <- classP (applicativeN th) [return vm]
  	return [
  		SigD list $ ForallT [specifiedPlainTV m, specifiedPlainTV a] [cp1, cp2] $
  			ArrowT	`AppT` (VarT m `AppT` VarT a)
  				`AppT` (VarT m `AppT` (ListT `AppT` VarT a)),
  		SigD list1 $ ForallT [specifiedPlainTV m, specifiedPlainTV a] [cp1, cp2] $
  			ArrowT	`AppT` (VarT m `AppT` VarT a)
  				`AppT` (VarT m `AppT` (ListT `AppT` VarT a)),
  		FunD list $ (: []) $ flip (Clause [VarP p]) [] $ NormalB $
  			InfixE (Just $ VarE list1 `AppE` VarE p)
  				(VarE $ mplusN th)
  				(Just returnEmpty),
  		FunD list1 $ (: []) $ flip (Clause [VarP p]) [] $ NormalB $
  			InfixE (Just $ InfixE (Just cons) app (Just $ VarE p))
  				next
  				(Just $ VarE list `AppE` VarE p) ]
  	where
  	vm = VarT m
  	returnEmpty = VarE (mkName "return") `AppE` ListE []
  	cons = ConE $ mkName ":"
  	app = VarE $ applyN th
  	next = VarE $ applyContN th
  
  {-
  
  optional :: (MonadPlus m, Applicative m) => m a -> m (Maybe a)
  optional p = (Just <$> p) `mplus` return Nothing
  
  -}
  
  optionalDec :: Name -> Bool -> Q [Dec]
  optionalDec optionalN th = do
  	maa <- mplusAndApp $ (VarT m `AppT` VarT a) `arrT`
  		(VarT m `AppT` (ConT (mkName "Maybe") `AppT` VarT a))
  	return [
  		SigD optionalN maa,
  		FunD optionalN $ (: []) $ flip (Clause [VarP p]) [] $ NormalB $
  			ConE (mkName "Just") `app` VarE p `mplusE` returnNothing ]
  	where
  	mplusAndApp x = do
  		cp1 <- classP (monadPlusN th) [return $ VarT m]
  		cp2 <- classP (applicativeN th) [return $ VarT m]
  		return $ ForallT [specifiedPlainTV m, specifiedPlainTV a] [cp1, cp2] x
  	arrT f x = ArrowT `AppT` f `AppT` x
  	mplusE x = InfixE (Just x) (VarE $ mplusN th) . Just
  	returnNothing = VarE (mkName "return") `AppE` ConE (mkName "Nothing")
  	app x = InfixE (Just x) (VarE $ applyN th) . Just
  