{-# 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
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Gets a list of constructors for a Name.
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 []


------------------------------------------------------------------------------
-- | Gets a list of constructors for a Dec.
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 []


------------------------------------------------------------------------------
-- | Gets a list of constructors for a Type.
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 []


------------------------------------------------------------------------------
-- | Derives a HasFormlet instance for a data type.
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"


------------------------------------------------------------------------------
-- | Generates interpreted splices for a data type.  All of the data type's
-- fields must be instances of the PrimSplice type class.
--
-- Usage:
--
-- > fooSplices :: Monad m => Foo -> [(Text, I.Splice m)]
-- > fooSplices = $(iSplices ''Foo)
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)) |]
--              return $ TupE [LitE $ StringL $ nameBase fn, f]
              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"


------------------------------------------------------------------------------
-- | Generates compiled splices for a data type.  All of the data type's
-- fields must be instances of the PrimSplice type class.
--
-- Usage:
--
-- > fooSplices = $(cSplices ''Foo)
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) |]
--              return $ TupE [LitE $ StringL $ nameBase fn, f]
              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"