{-# LANGUAGE TemplateHaskell #-}
module Data.Generics.Is.TH (
   -- | Predicates may be generated inline from a constructor name or quoted
   --   pattern, or in bulk from a type declaration.
   --
   --   You must enable the @TemplateHaskell@ extension to use the functions in this module.

   -- * From constructors
   is
  ,isNot

   -- * From patterns
  ,isP
  ,isNotP

   -- * From type declaration
   -- | Given a type @T@, for each constructor @K@, we can declare predicates
   --   @isK, isNotK : 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.Monad

import Data.Generics.Is.TH.Compat       

is, isNot :: Name -> Q Exp
-- | 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.
--
--   >>> $(is 'Just) (Just 5)
--   True
is     = isBase  'True  'False
-- | prop> $(isNot 'Con) ≡ not . $(is 'Con)
--
--   >>> $(isNot '(:)) [1,2,3]
--   False
isNot  = isBase  'False 'True

isP, isNotP :: Q Pat -> Q Exp

-- | 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> $(isP [p| Con{} |]) ≡ $(is 'Con)
--
--   >>> $(isP [p| Just{} |]) Nothing
--   False
isP    = isPBase 'True  'False


-- | prop> $(isNotP [p| P |]) ≡ not . $(isP [p| P |])
isNotP = isPBase 'False 'True

isPBase :: Name -> Name -> Q Pat -> Q Exp
isPBase yes no patm = do
  x <- newName "x"
  pat <- patm
  return $
    LamE [VarP x] $
      CaseE (VarE x)
        -- We use a guard to get around warnings of redundant patterns.
        [Match pat   (NormalB $ ConE yes) []
        ,Match WildP (NormalB $ ConE no ) []]

isBase :: Name -> Name -> Name -> Q Exp
isBase yes no n = isPBase yes no (return (RecP n []))

-- | Generates a predicate with name isK for each constructor K of the given
--   type T

derivePredicates :: Bool -> Bool -> Name -> Q [Dec]
derivePredicates gen_yes gen_no datatype = do
  names <- constructorNames datatype
  fmap concatList $ forM names $ \name -> do
    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
    -- Compatibility with GHC < 8.0
    concatList :: [[a]] -> [a]
    concatList = concat


-- | Generate predicates of the form @isK@
--
--   >>> $(makePredicates ''E)
--   >>> isPlus (Plus (Lit 1) (Lit 2))
--   True
makePredicates :: Name -> Q [Dec]
makePredicates    = derivePredicates True  False

-- | Generate predicates of the form @isNotK@
--
--   >>> $(makePredicatesNot ''E)
--   >>> isNotAnd (Showable True)
--   True
makePredicatesNot :: Name -> Q [Dec]
makePredicatesNot = derivePredicates False True

-- | Generate predicates of both forms, @isK@ and @isNotK@
--
--   prop> $(makePredicatesAll ''E) ≡ $(makePredicates ''E) ; $(makePredicatesNot ''E)
makePredicatesAll :: Name -> Q [Dec]
makePredicatesAll = derivePredicates True  True