{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Snap.Restful.TH
( deriveHasFormlet
, iSplices
, cSplices
) where
import Control.Applicative
import Language.Haskell.TH
import Snap.Restful
import Text.Digestive
nameCons :: Name -> Q [Con]
nameCons :: Name -> Q [Con]
nameCons Name
n = do
Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI Dec
dec -> Dec -> Q [Con]
decCons Dec
dec
Info
_ -> [Con] -> Q [Con]
forall (m :: * -> *) a. Monad m => a -> m a
return []
decCons :: Dec -> Q [Con]
#if MIN_VERSION_template_haskell(0, 11, 0)
decCons :: Dec -> Q [Con]
decCons (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) = [Con] -> Q [Con]
forall (m :: * -> *) a. Monad m => a -> m a
return [Con]
cons
decCons (NewtypeD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ Con
con [DerivClause]
_) = [Con] -> Q [Con]
forall (m :: * -> *) a. Monad m => a -> m a
return [Con
con]
#else
decCons (DataD _ _ _ cons _) = return cons
decCons (NewtypeD _ _ _ con _) = return [con]
#endif
decCons (TySynD Name
_ [TyVarBndr]
_ Kind
t) = Kind -> Q [Con]
typeCons Kind
t
decCons Dec
_ = [Con] -> Q [Con]
forall (m :: * -> *) a. Monad m => a -> m a
return []
typeCons :: Type -> Q [Con]
typeCons :: Kind -> Q [Con]
typeCons (AppT Kind
a Kind
_) = Kind -> Q [Con]
typeCons Kind
a
typeCons (ConT Name
n) = Name -> Q [Con]
nameCons Name
n
typeCons Kind
_ = [Con] -> Q [Con]
forall (m :: * -> *) a. Monad m => a -> m a
return []
deriveHasFormlet :: Name -> Q [Dec]
deriveHasFormlet :: Name -> Q [Dec]
deriveHasFormlet Name
n = do
[Con]
cons <- Name -> Q [Con]
nameCons Name
n
case [Con]
cons of
[RecC Name
conName [VarBangType]
fields] -> do
Name
defName <- String -> Q Name
newName String
"d"
let fieldFormlet :: (Name, b, c) -> ExpQ
fieldFormlet (Name
fn,b
_,c
_) = do
let name :: ExpQ
name = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fn
[| $name .: formlet ( $(varE fn) <$> $(varE defName) ) |]
(Exp
f:[Exp]
fs) <- (VarBangType -> ExpQ) -> [VarBangType] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> ExpQ
forall b c. (Name, b, c) -> ExpQ
fieldFormlet [VarBangType]
fields
let start :: Exp
start = Exp -> Exp -> Exp -> Exp
UInfixE (Name -> Exp
ConE Name
conName) (Name -> Exp
VarE '(<$>)) Exp
f
splat :: Exp
splat = Name -> Exp
VarE '(<*>)
res :: Exp
res = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
a Exp
b -> Exp -> Exp -> Exp -> Exp
UInfixE Exp
a Exp
splat Exp
b) Exp
start [Exp]
fs
func :: [Dec]
func = [Name -> [Clause] -> Dec
FunD 'formlet [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
defName] (Exp -> Body
NormalB Exp
res) []]]
#if MIN_VERSION_template_haskell(0, 11, 0)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''HasFormlet) (Name -> Kind
ConT Name
n)) [Dec]
func]
#else
return $ [InstanceD [] (AppT (ConT ''HasFormlet) (ConT n)) func]
#endif
[Con]
_ -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"You can only generate formlets for a data type with a single constructor and named record fields"
iSplices :: Name -> Q Exp
iSplices :: Name -> ExpQ
iSplices Name
n = do
[Con]
cons <- Name -> Q [Con]
nameCons Name
n
case [Con]
cons of
[RecC Name
conName [VarBangType]
fields] -> do
Name
param <- String -> Q Name
newName String
"x"
let fieldToSplice :: (Name, b, c) -> Q Stmt
fieldToSplice (Name
fn,b
_,c
_) = do
Exp
f <- [| iPrimSplice $ $(appE (varE fn) (varE param)) |]
Stmt -> Q Stmt
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt -> Q Stmt) -> Stmt -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
UInfixE (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
nameBase Name
fn) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"##") Exp
f
[Stmt]
fs <- (VarBangType -> Q Stmt) -> [VarBangType] -> Q [Stmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> Q Stmt
forall b c. (Name, b, c) -> Q Stmt
fieldToSplice [VarBangType]
fields
Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
param] ([Stmt] -> Exp
DoE [Stmt]
fs)
[Con]
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"You can only generate splices for a data type with a single constructor and named record fields"
cSplices :: Name -> Q Exp
cSplices :: Name -> ExpQ
cSplices Name
n = do
[Con]
cons <- Name -> Q [Con]
nameCons Name
n
case [Con]
cons of
[RecC Name
conName [VarBangType]
fields] -> do
let fieldToSplice :: (Name, b, c) -> Q Stmt
fieldToSplice (Name
fn,b
_,c
_) = do
Exp
f <- [| cPrimSplice . $(varE fn) |]
Stmt -> Q Stmt
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt -> Q Stmt) -> Stmt -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
UInfixE (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
nameBase Name
fn) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"##") Exp
f
[Stmt]
fs <- (VarBangType -> Q Stmt) -> [VarBangType] -> Q [Stmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> Q Stmt
forall b c. (Name, b, c) -> Q Stmt
fieldToSplice [VarBangType]
fields
Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
DoE [Stmt]
fs
[Con]
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"You can only generate splices for a data type with a single constructor and named record fields"