{-# 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 -> ExpQ -> [ExpQ] -> ExpQ
app' (ExpQ
ke ExpQ -> ExpQ -> ExpQ
`dl` ExpQ
e) [ExpQ]
es
  where
    app' :: ExpQ -> [ExpQ] -> ExpQ
app' ExpQ
e []      = ExpQ
e
    app' ExpQ
e (ExpQ
e':[ExpQ]
es) = ExpQ -> [ExpQ] -> ExpQ
app' (ExpQ
e ExpQ -> ExpQ -> ExpQ
`st` ExpQ
e') [ExpQ]
es

    st :: ExpQ -> ExpQ -> ExpQ
st ExpQ
e1 ExpQ
e2 = ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE '(<*>)) ExpQ
e1) ExpQ
e2
    dl :: ExpQ -> ExpQ -> ExpQ
dl ExpQ
e1 ExpQ
e2 = ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE '(<$>)) ExpQ
e1) ExpQ
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 <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
tqs
    [Dec]
ds <- [DecQ] -> Q [Dec]
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 Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ToolSettings -> Bool
warnOnOmittedInstance ToolSettings
stgs) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [Type] -> String
forall a. Ppr a => a -> String
msg [Type]
ts
                      [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
              else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type] -> Type -> [Dec] -> Dec
mkInstanceD [] ((Type -> Type -> Type) -> Type -> [Type] -> Type
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Ppr a => a -> String
pprint Name
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Ppr a => a -> String
pprint a
ts String -> String -> String
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]) (Dec -> Dec -> [Dec]) -> DecQ -> Q (Dec -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TypeQ -> DecQ
sigD Name
n TypeQ
t Q (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> [ClauseQ] -> DecQ
funD Name
n [ClauseQ]
cs

-- | Construct a simple TH definition
simpleD :: Name -> ExpQ -> Q Dec
simpleD :: Name -> ExpQ -> DecQ
simpleD Name
n ExpQ
e = Name -> [ClauseQ] -> DecQ
funD Name
n [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
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 [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
e) []]


mkNameText :: T.Text -> Name
mkNameText :: Text -> Name
mkNameText = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
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 = String -> ExpQ
stringE (String -> ExpQ) -> (FieldName -> String) -> FieldName -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (FieldName -> Text) -> FieldName -> String
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 = Name -> ExpQ
varE (Name -> ExpQ) -> (FieldName -> Name) -> FieldName -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
mkNameText (Text -> Name) -> (FieldName -> Text) -> FieldName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
_FieldName

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