{-# LANGUAGE TemplateHaskell #-}
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
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
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"
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
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) []]
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
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
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