{-# LANGUAGE TemplateHaskell #-}
-- | Generate predicates from constructor names or from quoted patterns.
--
--   You must enable the @TemplateHaskell@ extension to use this module.
module Data.Generics.Is(
   -- * From constructors
   -- | Given a constructor (or pattern synonym) for type @T@, 'is' generates
   --   a function of type @T → Bool@.
   --
   --   The function evaluates its argument to WHNF, and returns
   --   'True' if the head constructor matches the given one, 'False'
   --   otherwise.
   --
   --   prop> $(isNot 'Con) ≡ not . $(is 'Con)
   -- 
   --   >>> $(is 'Just) (Just 5)
   --   True
   --   >>> $(isNot '(:)) [1,2,3]
   --   False
   is
  ,isNot

   -- * From patterns
   -- | Given a pattern for type @T@, 'isP' generates a function of type
   --   @T → Bool@.
   --
   --   The function returns 'True' if the expression matches the pattern; a
   --   and 'False' otherwise. 
   --
   --   prop> $(isNot patQ) ≡ not . $(isP patQ)
   --   prop> $(isP [p| Con{} |]) ≡ $(is 'Con)
   --
   --   >>> $(isP [p| Just _ |]) Nothing
   --   False
   --   >>> $(isNotP [_,_,_]) [2,1]
   --   True
  ,isP
  ,isNotP

   -- * Predicate declarations
   -- | Given a type @T@, for each constructor @C@, we can declare predicates
   --   @isC, isNotC : T → Bool@.
   --
   --   Type @T@ can be a @newtype@, @data@, or @GADT@ declaration.
   --
   --   Constructors with non-alphanumeric names (e.g. @:+:@) are ignored
   --   silently. As a workaround, we suggest giving the constructors
   --   alphanumeric names, and creating pattern synonyms with the desired
   --   symbolic names.
   --
   -- @
   -- data E a where
   --    Plus     :: E Int -> E Int -> E Int
   --    And      :: E Bool -> E Bool -> E Bool 
   --    Lit      :: a -> E a
   --    (:*:)    :: (Num a) => E a -> E a -> E a
   --    Showable :: (Show a) => a -> E String
   --
   -- pattern a :+: b = Plus a b
   -- @
  ,makePredicates
  ,makePredicatesNot
  ,makePredicatesAll
  ) where

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

is, isNot :: Name -> Q Exp
is     = isBase  'True  'False 
isNot  = isBase  'False 'True

isP, isNotP :: Q Pat -> Q Exp
isP    = isPBase 'True  'False 
isNotP = isPBase 'False 'True

isPBase yes no patm = do
  x <- newName "x"
  pat <- patm
  return $
    LamE [VarP x] $
      CaseE (VarE x)
        [Match pat   (NormalB $ ConE yes) []
        ,Match WildP (NormalB $ ConE no ) []]

isBase yes no n = isPBase yes no (return (RecP n []))

-- | Generates a predicate with name isC for each constructor C of the given
--   type T

derivePredicates :: Bool -> Bool -> Name -> Q [Dec]
derivePredicates gen_yes gen_no datatype = do
  i <- reify datatype 
  let constructors = case i of
        TyConI (DataD _ _ _ cs _) -> cs
        TyConI (NewtypeD _ _ _ c _) -> [c]
        _ -> error $ "Can't derive predicates for " ++ nameBase datatype ++ "."

  fmap concat $ forM constructors $ \c -> do
    let name = conName c
    let base = nameBase name
    x <- newName "x"
    case base of
      ':':_ -> return []
      _ -> do
         yesd <- if gen_yes then do
           f  <- is name
           return [FunD (mkName ("is" ++ base)) [Clause [VarP x] (NormalB (AppE f (VarE x))) []]]
                 else return []              
         nod <- if gen_no then do
           f <- isNot name
           return [FunD (mkName ("isNot" ++ base)) [Clause [VarP x] (NormalB (AppE f (VarE x))) []]]
                else return []              
         return $ yesd ++ nod

  where 
    conName c = case c of
      NormalC n _    -> n
      RecC n _       -> n
      InfixC _ n _   -> n 
      ForallC _ _ c' -> conName c'

-- | Generate predicates of the form @isC@
--
--   >>> $(makePredicates ''T)
--   >>> isPlus (Plus (Lit 1) (Lit 2))
--   True
makePredicates    = derivePredicates True  False 

-- | Generate predicates of the form @isNotC@
--
--   >>> $(makePredicatesNot ''T)
--   >>> isNotAnd (Showable True)
--   True
makePredicatesNot = derivePredicates False True

-- | Generate predicates of both forms, @isC@ and @isNotC@
--
--   prop> $(makePredicatesAll ''T) ≡ $(makePredicates ''T) ; $(makePredicatesNot ''T)
makePredicatesAll = derivePredicates True  True