{-# LANGUAGE TemplateHaskell            #-}

-- | This module defines some utilities for working with Template
-- Haskell, which may be useful for defining 'Tool's, but should be
-- considered internal implementation details of this package.
module Data.API.TH
    ( applicativeE
    , optionalInstanceD
    , funSigD
    , simpleD
    , simpleSigD
    , mkNameText
    , fieldNameE
    , fieldNameVarE
    , typeNameE
    ) where

import           Data.API.TH.Compat
import           Data.API.Tools.Combinators
import           Data.API.Types

import           Control.Applicative
import           Control.Monad
import qualified Data.Text                      as T
import           Language.Haskell.TH
import           Prelude

-- | Construct an idiomatic expression (an expression in an
-- Applicative context), i.e.
--
-- > app ke []             = ke
-- > app ke [e1,e2,...,en] = ke <$> e1 <*> e2 ... <*> en
applicativeE :: ExpQ -> [ExpQ] -> ExpQ
applicativeE :: ExpQ -> [ExpQ] -> ExpQ
applicativeE ExpQ
ke [ExpQ]
es0 =
    case [ExpQ]
es0 of
      []   -> ExpQ
ke
      ExpQ
e:[ExpQ]
es -> forall {m :: * -> *}. Quote m => m Exp -> [m Exp] -> m Exp
app' (ExpQ
ke forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`dl` ExpQ
e) [ExpQ]
es
  where
    app' :: m Exp -> [m Exp] -> m Exp
app' m Exp
e []      = m Exp
e
    app' m Exp
e (m Exp
e':[m Exp]
es) = m Exp -> [m Exp] -> m Exp
app' (m Exp
e forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`st` m Exp
e') [m Exp]
es

    st :: m Exp -> m Exp -> m Exp
st m Exp
e1 m Exp
e2 = forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) m Exp
e1) m Exp
e2
    dl :: m Exp -> m Exp -> m Exp
dl m Exp
e1 m Exp
e2 = forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<$>)) m Exp
e1) m Exp
e2


-- | Add an instance declaration for a class, if such an instance does
-- not already exist
optionalInstanceD :: ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD :: ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
stgs Name
c [TypeQ]
tqs [DecQ]
dqs = do
    [Type]
ts <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
tqs
    [Dec]
ds <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [DecQ]
dqs
    Bool
exists <- Name -> [Type] -> Q Bool
isInstance Name
c [Type]
ts
    if Bool
exists then do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ToolSettings -> Bool
warnOnOmittedInstance ToolSettings
stgs) forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ forall {a}. Ppr a => a -> String
msg [Type]
ts
                      forall (m :: * -> *) a. Monad m => a -> m a
return []
              else forall (m :: * -> *) a. Monad m => a -> m a
return [[Type] -> Type -> [Dec] -> Dec
mkInstanceD [] (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
c) [Type]
ts) [Dec]
ds]
  where
    msg :: a -> String
msg a
ts = String
"instance " forall a. [a] -> [a] -> [a]
++ forall {a}. Ppr a => a -> String
pprint Name
c forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall {a}. Ppr a => a -> String
pprint a
ts forall a. [a] -> [a] -> [a]
++ String
" already exists, so it was not generated"


-- | Construct a TH function with a type signature
funSigD :: Name -> TypeQ -> [ClauseQ] -> Q [Dec]
funSigD :: Name -> TypeQ -> [ClauseQ] -> Q [Dec]
funSigD Name
n TypeQ
t [ClauseQ]
cs = (\ Dec
x Dec
y -> [Dec
x,Dec
y]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n TypeQ
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [ClauseQ]
cs

-- | Construct a simple TH definition
simpleD :: Name -> ExpQ -> Q Dec
simpleD :: Name -> ExpQ -> DecQ
simpleD Name
n ExpQ
e = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
e) []]

-- | Construct a simple TH definition with a type signature
simpleSigD :: Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD :: Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
n TypeQ
t ExpQ
e = Name -> TypeQ -> [ClauseQ] -> Q [Dec]
funSigD Name
n TypeQ
t [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
e) []]


mkNameText :: T.Text -> Name
mkNameText :: Text -> Name
mkNameText = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack


-- | Field name as a string expression
fieldNameE :: FieldName -> ExpQ
fieldNameE :: FieldName -> ExpQ
fieldNameE = forall (m :: * -> *). Quote m => String -> m Exp
stringE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
_FieldName

-- | Field name as a variable
fieldNameVarE :: FieldName -> ExpQ
fieldNameVarE :: FieldName -> ExpQ
fieldNameVarE = forall (m :: * -> *). Quote m => Name -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
mkNameText forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
_FieldName

typeNameE :: TypeName -> ExpQ
typeNameE :: TypeName -> ExpQ
typeNameE = forall (m :: * -> *). Quote m => String -> m Exp
stringE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
_TypeName