{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Derive.IsDataCon (
    derive_is
    ) 
where

import Language.Haskell.TH
import Control.Monad

type TypeName = Name
type ConName = Name

nameToFunc :: ConName -> Int -> Dec
nameToFunc :: ConName -> Int -> Dec
nameToFunc ConName
name Int
numOfTyArg = ConName -> [Clause] -> Dec
FunD ConName
fname [Clause
isClause, Clause
defaultClause]
  where
    fname :: ConName
fname = String -> ConName
mkName (String -> ConName) -> String -> ConName
forall a b. (a -> b) -> a -> b
$ String
"is" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((if (ConName -> Bool
isNameOp ConName
name) then (ConName -> String
infixToStringName (ConName -> String) -> (String -> ConName) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConName
mkName) else String -> String
forall a. a -> a
id) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ConName -> String
nameBase ConName
name)
#if __GLASGOW_HASKELL__ >= 902
    isClause :: Clause
isClause = [Pat] -> Body -> [Dec] -> Clause
Clause [ConName -> [Type] -> [Pat] -> Pat
ConP ConName
name [] (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
numOfTyArg Pat
WildP)] (Exp -> Body
NormalB (ConName -> Exp
ConE 'True)) []
#else
    isClause = Clause [ConP name  (replicate numOfTyArg WildP)] (NormalB (ConE 'True)) []
#endif
    defaultClause :: Clause
defaultClause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (ConName -> Exp
ConE 'False)) []

infixToStringName :: Name -> String
infixToStringName :: ConName -> String
infixToStringName ConName
name = ((Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
charToString (ConName -> String
nameBase ConName
name))

isNameOp :: Name -> Bool
isNameOp :: ConName -> Bool
isNameOp ConName
n = Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> Char
forall a. HasCallStack => [a] -> a
head (ConName -> String
nameBase ConName
n)) String
"~!@#$%^&*-+=|\\/<>:?.[]"

charToString :: Char -> String
charToString :: Char -> String
charToString Char
'~' = String
"Tilde"
charToString Char
'!' = String
"Bang"
charToString Char
'@' = String
"At"
charToString Char
'#' = String
"Hash"
charToString Char
'$' = String
"Dollar"
charToString Char
'%' = String
"Percent"
charToString Char
'^' = String
"Caret"
charToString Char
'&' = String
"And"
charToString Char
'*' = String
"Star"
charToString Char
'-' = String
"Minus"
charToString Char
'+' = String
"Plus"
charToString Char
'=' = String
"Equal"
charToString Char
'|' = String
"Pipe"
charToString Char
'\\' = String
"Backslash"
charToString Char
'/' = String
"Slash"
charToString Char
'<' = String
"Lt"
charToString Char
'>' = String
"Gt"
charToString Char
':' = String
"Colon"
charToString Char
'?' = String
"Question"
charToString Char
'.' = String
"Dot"
charToString Char
x   = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show Char
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a valid operator symbol"

conToIsFunc :: Con -> [Dec]
conToIsFunc :: Con -> [Dec]
conToIsFunc (NormalC ConName
name [BangType]
ts)  = [ConName -> Int -> Dec
nameToFunc ConName
name ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
ts)]
conToIsFunc (RecC ConName
name [VarBangType]
vbts)   = [ConName -> Int -> Dec
nameToFunc ConName
name ([VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
vbts)]
conToIsFunc (InfixC BangType
_ ConName
name BangType
_)  = [ConName -> Int -> Dec
nameToFunc ConName
name Int
2]
conToIsFunc (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
con)  = Con -> [Dec]
conToIsFunc Con
con
conToIsFunc (GadtC [ConName]
ns [BangType]
ts Type
_)    = ((ConName, Int) -> Dec) -> [(ConName, Int)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map ((ConName -> Int -> Dec) -> (ConName, Int) -> Dec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ConName -> Int -> Dec
nameToFunc) [(ConName
n, [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
ts) | ConName
n <- [ConName]
ns]
conToIsFunc (RecGadtC [ConName]
ns [VarBangType]
ts Type
_) = ((ConName, Int) -> Dec) -> [(ConName, Int)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map ((ConName -> Int -> Dec) -> (ConName, Int) -> Dec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ConName -> Int -> Dec
nameToFunc) [(ConName
n, [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
ts) | ConName
n <- [ConName]
ns]

nameToSig :: ConName -> TypeName -> Int -> Q [Dec]
nameToSig :: ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
fn ConName
tn Int
tnNumOfVars = do
    ns <- Int -> Q ConName -> Q [ConName]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tnNumOfVars (String -> Q ConName
forall (m :: * -> *). Quote m => String -> m ConName
newName String
"a")
    let vars = (ConName -> Type) -> [ConName] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ConName -> Type
VarT [ConName]
ns
    let fname = String -> ConName
mkName (String -> ConName) -> String -> ConName
forall a b. (a -> b) -> a -> b
$ String
"is" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((if (ConName -> Bool
isNameOp ConName
fn) then (ConName -> String
infixToStringName (ConName -> String) -> (String -> ConName) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConName
mkName) else String -> String
forall a. a -> a
id) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ConName -> String
nameBase ConName
fn)
    return [SigD fname (AppT (AppT ArrowT (foldl AppT (ConT tn) vars)) (ConT ''Bool))]

conToSig :: TypeName -> Int -> Con -> Q [Dec]
conToSig :: ConName -> Int -> Con -> Q [Dec]
conToSig ConName
tn Int
numOfTyVars (NormalC ConName
name [BangType]
_)  = ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
name ConName
tn Int
numOfTyVars
conToSig ConName
tn Int
numOfTyVars (RecC ConName
name [VarBangType]
_)   = ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
name ConName
tn Int
numOfTyVars
conToSig ConName
tn Int
numOfTyVars (InfixC BangType
_ ConName
name BangType
_)  = ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
name ConName
tn Int
numOfTyVars
conToSig ConName
tn Int
numOfTyVars (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
con)  = ConName -> Int -> Con -> Q [Dec]
conToSig ConName
tn Int
numOfTyVars Con
con
conToSig ConName
tn Int
numOfTyVars (GadtC [ConName]
ns [BangType]
_ Type
_)    = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (ConName -> Q [Dec]) -> [ConName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ConName
fn -> ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
fn ConName
tn Int
numOfTyVars) [ConName]
ns
conToSig ConName
tn Int
numOfTyVars (RecGadtC [ConName]
ns [VarBangType]
_ Type
_) = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (ConName -> Q [Dec]) -> [ConName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ConName
fn -> ConName -> ConName -> Int -> Q [Dec]
nameToSig ConName
fn ConName
tn Int
numOfTyVars) [ConName]
ns

derive_is :: Name -> Q [Dec]
derive_is :: ConName -> Q [Dec]
derive_is ConName
name = do
  info <- ConName -> Q Info
reify ConName
name
  case info of
    TyConI (DataD [Type]
_ ConName
_ [TyVarBndr BndrVis]
tvbs Maybe Type
_ [Con]
cons [DerivClause]
_) -> do 
                                sigs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [Dec]) -> [Con] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ConName -> Int -> Con -> Q [Dec]
conToSig ConName
name ([TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
tvbs)) [Con]
cons
                                let defs = (Con -> [Dec]) -> [Con] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [Dec]
conToIsFunc [Con]
cons
                                return $ sigs ++ defs
    Info
i -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Info -> String
forall a. Show a => a -> String
show Info
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not data type"