{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Syntactic.TH where



#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import Language.Haskell.TH

import Data.Hash (hashInt, combine)
import qualified Data.Hash as Hash

import Language.Syntactic



-- | Get the name and arity of a constructor
conName :: Con -> (Name, Int)
conName :: Con -> (Name, Int)
conName (NormalC Name
name [BangType]
args) = (Name
name, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
conName (RecC Name
name [VarBangType]
args)    = (Name
name, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
conName (InfixC BangType
_ Name
name BangType
_)   = (Name
name, Int
2)
conName (ForallC [TyVarBndr]
_ Cxt
_ Con
c)     = Con -> (Name, Int)
conName Con
c
#if __GLASGOW_HASKELL__ >= 800
conName (GadtC [Name
n] [BangType]
as Type
_)    = (Name
n, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
as)
conName (RecGadtC [Name
n] [VarBangType]
as Type
_) = (Name
n, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
as)
  -- I don't know what it means when a `GadtC` and `RecGadtC` don't have
  -- singleton lists of names
#endif

-- | Description of class methods
data Method
    = DefaultMethod Name Name
        -- ^ rhs = lhs
    | MatchingMethod Name (Con -> Int -> Name -> Int -> Clause) [Clause]
        -- ^ @MatchingMethod methodName mkClause extraClauses@
        --
        -- @mkClause@ takes as arguments (1) a description of the constructor,
        -- (2) the constructor's index, (3) the constructor's name, and (4) its
        -- arity.

-- | General method for class deriving
deriveClass
    :: Cxt       -- ^ Instance context
    -> Name      -- ^ Type constructor name
    -> Type      -- ^ Class head (e.g. @Render Con@)
    -> [Method]  -- ^ Methods
    -> DecsQ
deriveClass :: Cxt -> Name -> Type -> [Method] -> DecsQ
deriveClass Cxt
cxt Name
ty Type
clHead [Method]
methods = do
    Just [Con]
cs <- Info -> Maybe [Con]
viewDataDef (Info -> Maybe [Con]) -> Q Info -> Q (Maybe [Con])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
ty
    [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Cxt -> Type -> [Dec] -> Dec
instD Cxt
cxt Type
clHead ([Dec] -> Dec) -> [Dec] -> Dec
forall a b. (a -> b) -> a -> b
$
          [ Name -> [Clause] -> Dec
FunD Name
method ([Clause]
clauses [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause]
extra)
            | MatchingMethod Name
method Con -> Int -> Name -> Int -> Clause
mkClause [Clause]
extra <- [Method]
methods
            , let clauses :: [Clause]
clauses = [ Con -> Int -> Name -> Int -> Clause
mkClause Con
c Int
i Name
nm Int
ar | (Int
i,Con
c) <- [Int] -> [Con] -> [(Int, Con)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Con]
cs
                            , let (Name
nm,Int
ar) = Con -> (Name, Int)
conName Con
c
                            ]
          ] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
          [ Name -> [Clause] -> Dec
FunD Name
rhs [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (Name -> Exp
VarE Name
lhs)) []]
            | DefaultMethod Name
rhs Name
lhs <- [Method]
methods
          ]
      ]

-- | General method for class deriving
deriveClassSimple
    :: Name      -- ^ Class name
    -> Name      -- ^ Type constructor name
    -> [Method]  -- ^ Methods
    -> DecsQ
deriveClassSimple :: Name -> Name -> [Method] -> DecsQ
deriveClassSimple Name
cl Name
ty = Cxt -> Name -> Type -> [Method] -> DecsQ
deriveClass [] Name
ty (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cl) (Name -> Type
ConT Name
ty))

varSupply :: [Name]
varSupply :: [Name]
varSupply = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName ([String] -> [Name]) -> [String] -> [Name]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> [String] -> [[String]]
forall a. (a -> a) -> a -> [a]
iterate [String] -> [String]
step [[]]
  where
    step :: [String] -> [String]
    step :: [String] -> [String]
step [String]
vars = (Char -> [String]) -> String -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
c -> (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:) [String]
vars) [Char
'a' .. Char
'z']

-- | Derive 'Symbol' instance for a type
deriveSymbol
    :: Name  -- ^ Type name
    -> DecsQ
deriveSymbol :: Name -> DecsQ
deriveSymbol Name
ty =
    Name -> Name -> [Method] -> DecsQ
deriveClassSimple ''Symbol Name
ty [Name -> (Con -> Int -> Name -> Int -> Clause) -> [Clause] -> Method
MatchingMethod 'symSig  Con -> Int -> Name -> Int -> Clause
forall p p. p -> p -> Name -> Int -> Clause
symSigClause []]
  where
    symSigClause :: p -> p -> Name -> Int -> Clause
symSigClause p
_ p
_ Name
con Int
arity =
      [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
con (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
arity Pat
WildP)] (Exp -> Body
NormalB (Name -> Exp
VarE 'signature)) []

-- | Derive 'Equality' instance for a type
--
-- > equal Con1 Con1 = True
-- > equal (Con2 a1 ... x1) (Con2 a2 ... x2) = and [a1==a2, ... x1==x2]
-- > equal _ _ = False
--
-- > hash Con1           = hashInt 0
-- > hash (Con2 a ... x) = foldr1 combine [hashInt 1, hash a, ... hash x]
deriveEquality
    :: Name  -- ^ Type name
    -> DecsQ
deriveEquality :: Name -> DecsQ
deriveEquality Name
ty = do
    Just [Con]
cs <- Info -> Maybe [Con]
viewDataDef (Info -> Maybe [Con]) -> Q Info -> Q (Maybe [Con])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
ty
    let equalFallThrough :: [Clause]
equalFallThrough = if [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
          then [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP, Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'False) []]
          else []
    Name -> Name -> [Method] -> DecsQ
deriveClassSimple ''Equality Name
ty
      [ Name -> (Con -> Int -> Name -> Int -> Clause) -> [Clause] -> Method
MatchingMethod 'equal Con -> Int -> Name -> Int -> Clause
forall p p. p -> p -> Name -> Int -> Clause
equalClause [Clause]
equalFallThrough
      , Name -> (Con -> Int -> Name -> Int -> Clause) -> [Clause] -> Method
MatchingMethod 'hash Con -> Int -> Name -> Int -> Clause
forall a p. Integral a => p -> a -> Name -> Int -> Clause
hashClause []
      ]
  where
    equalClause :: p -> p -> Name -> Int -> Clause
equalClause p
_ p
_ Name
con Int
arity = [Pat] -> Body -> [Dec] -> Clause
Clause
        [ Name -> [Pat] -> Pat
ConP Name
con [Name -> Pat
VarP Name
v | Name
v <- [Name]
vs1]
        , Name -> [Pat] -> Pat
ConP Name
con [Name -> Pat
VarP Name
v | Name
v <- [Name]
vs2]
        ]
        (Exp -> Body
NormalB Exp
body)
        []
      where
        vs1 :: [Name]
vs1 = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
arity [Name]
varSupply
        vs2 :: [Name]
vs2 = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
arity ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop Int
arity [Name]
varSupply

        body :: Exp
body = case Int
arity of
          Int
0 -> Name -> Exp
ConE 'True
          Int
_ -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'and)
                 ( [Exp] -> Exp
ListE
                     [ Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
v1)) (Name -> Exp
VarE '(==)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
v2))
                       | (Name
v1,Name
v2) <- [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vs1 [Name]
vs2
                     ]
                 )

    hashClause :: p -> a -> Name -> Int -> Clause
hashClause p
_ a
i Name
con Int
arity = [Pat] -> Body -> [Dec] -> Clause
Clause
        [Name -> [Pat] -> Pat
ConP Name
con [Name -> Pat
VarP Name
v | Name
v <- [Name]
vs]]
        (Exp -> Body
NormalB Exp
body)
        []
      where
        vs :: [Name]
vs = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
arity [Name]
varSupply
        body :: Exp
body = case Int
arity of
          Int
0 -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'hashInt) (Lit -> Exp
LitE (Integer -> Lit
IntegerL (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
i)))
          Int
_ -> (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
AppE
                [ Name -> Exp
VarE 'foldr1
                , Name -> Exp
VarE 'combine
                , [Exp] -> Exp
ListE
                    ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'hashInt) (Lit -> Exp
LitE (Integer -> Lit
IntegerL (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
i)))
                    Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hash.hash) (Name -> Exp
VarE Name
v)
                        | Name
v <- [Name]
vs
                      ]
                ]

-- | Derive 'Render' instance for a type
--
-- > renderSym Con1           = "Con1"
-- > renderSym (Con2 a ... x) = concat ["(", unwords ["Con2", show a, ... show x], ")"]
deriveRender
    :: (String -> String)  -- ^ Constructor name modifier
    -> Name                -- ^ Type name
    -> DecsQ
deriveRender :: (String -> String) -> Name -> DecsQ
deriveRender String -> String
modify Name
ty =
    Name -> Name -> [Method] -> DecsQ
deriveClassSimple ''Render Name
ty [Name -> (Con -> Int -> Name -> Int -> Clause) -> [Clause] -> Method
MatchingMethod 'renderSym Con -> Int -> Name -> Int -> Clause
renderClause []]
  where
    conName :: Name -> String
conName = String -> String
modify (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

    renderClause :: Con -> Int -> Name -> Int -> Clause
renderClause Con
_ Int
_ Name
con Int
arity = [Pat] -> Body -> [Dec] -> Clause
Clause
        [Name -> [Pat] -> Pat
ConP Name
con [Name -> Pat
VarP Name
v | Name
v <- Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
arity [Name]
varSupply]]
        (Exp -> Body
NormalB Exp
body)
        []
      where
        body :: Exp
body = case Int
arity of
            Int
0 -> Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
conName Name
con
            Int
_ -> Name -> [Name] -> Exp
renderRHS Name
con ([Name] -> Exp) -> [Name] -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
arity [Name]
varSupply

    renderRHS :: Name -> [Name] -> Exp
    renderRHS :: Name -> [Name] -> Exp
renderRHS Name
con [Name]
args =
      Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'concat)
        ( [Exp] -> Exp
ListE
            [ Lit -> Exp
LitE (String -> Lit
StringL String
"(")
            , Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'unwords)
                ([Exp] -> Exp
ListE (Lit -> Exp
LitE (String -> Lit
StringL (Name -> String
conName Name
con)) Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
showArg [Name]
args))
            , Lit -> Exp
LitE (String -> Lit
StringL String
")")
            ]
        )

    showArg :: Name -> Exp
    showArg :: Name -> Exp
showArg Name
arg = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'show) (Name -> Exp
VarE Name
arg)



--------------------------------------------------------------------------------
-- * Portability
--------------------------------------------------------------------------------

-- Using `__GLASGOW_HASKELL__` instead of `MIN_VERSION_template_haskell`,
-- because the latter doesn't work when the package is compiled with `-f-th`.

-- | Construct an instance declaration
instD
    :: Cxt    -- ^ Context
    -> Type   -- ^ Instance
    -> [Dec]  -- ^ Methods, etc.
    -> Dec
#if __GLASGOW_HASKELL__ >= 800
instD :: Cxt -> Type -> [Dec] -> Dec
instD = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
#else
instD = InstanceD
#endif

-- | Get the constructors of a data type definition
viewDataDef :: Info -> Maybe [Con]
#if __GLASGOW_HASKELL__ >= 800
viewDataDef :: Info -> Maybe [Con]
viewDataDef (TyConI (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Type
_ [Con]
cs [DerivClause]
_)) = [Con] -> Maybe [Con]
forall a. a -> Maybe a
Just [Con]
cs
#else
viewDataDef (TyConI (DataD _ _ _ cs _)) = Just cs
#endif
viewDataDef Info
_ = Maybe [Con]
forall a. Maybe a
Nothing

-- | Portable method for constructing a 'Pred' of the form @(t1 ~ t2)@
eqPred :: Type -> Type -> Pred
#if __GLASGOW_HASKELL__ >= 710
eqPred :: Type -> Type -> Type
eqPred Type
t1 Type
t2 = (Type -> Type -> Type) -> Cxt -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
AppT [Type
EqualityT,Type
t1,Type
t2]
#else
eqPred = EqualP
#endif

-- | Portable method for constructing a 'Pred' of the form @SomeClass t1 t2 ...@
classPred
    :: Name            -- ^ Class name
    -> (Name -> Type)  -- ^ How to make a type for the class (typically 'ConT' or 'VarT')
    -> [Type]          -- ^ Class arguments
    -> Pred
#if __GLASGOW_HASKELL__ >= 710
classPred :: Name -> (Name -> Type) -> Cxt -> Type
classPred Name
cl Name -> Type
con = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
con Name
cl)
#else
classPred cl con = ClassP cl
#endif

-- | Portable method for constructing a type synonym instance
tySynInst :: Name -> [Type] -> Type -> Dec
#if __GLASGOW_HASKELL__ >= 808
tySynInst :: Name -> Cxt -> Type -> Dec
tySynInst Name
t Cxt
as Type
rhs = TySynEqn -> Dec
TySynInstD (TySynEqn -> Dec) -> TySynEqn -> Dec
forall a b. (a -> b) -> a -> b
$
  Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) Cxt
as) Type
rhs
#elif __GLASGOW_HASKELL__ >= 708
tySynInst t as rhs = TySynInstD t (TySynEqn as rhs)
#else
tySynInst = TySynInstD
#endif