{-# LANGUAGE TemplateHaskell, PackageImports #-}

module Text.Papillon.List (
        listDec,
        optionalDec
) where

import Language.Haskell.TH
import Control.Applicative
import Control.Monad

{-

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 [PlainTV m, PlainTV a] [cp1, cp2] $
                        ArrowT  `AppT` (VarT m `AppT` VarT a)
                                `AppT` (VarT m `AppT` (ListT `AppT` VarT a)),
                SigD list1 $ ForallT [PlainTV m, PlainTV 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 [PlainTV m, PlainTV 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