{-# LANGUAGE Trustworthy, TemplateHaskell, LambdaCase, ViewPatterns #-}
------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.TH
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
------------------------------------------------------------------------
module Data.Extensible.TH (mkField
  , mkFieldAs) where

import Data.Extensible.Class (itemAssoc)
import Data.Extensible.Field
import Language.Haskell.TH
import Data.Char
import Control.Monad
import Type.Membership

-- | Generate fields using 'itemAssoc'.
-- @'mkField' "foo Bar"@ defines:
--
-- @
-- foo :: FieldOptic "foo"
-- foo = itemAssoc (Proxy :: Proxy "foo")
-- _Bar :: FieldOptic "Bar"
-- _Bar = itemAssoc (Proxy :: Proxy "Bar")
-- @
--
mkField :: String -> DecsQ
mkField :: String -> DecsQ
mkField String
str = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> DecsQ) -> Q [[Dec]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (String -> [String]
words String
str) ((String -> DecsQ) -> Q [[Dec]]) -> (String -> DecsQ) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \String
s ->
  let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ case String
s of
        Char
x : String
xs -> if Char -> Bool
isLower Char
x then Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs else Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
        String
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"Impossible"
  in Name -> String -> DecsQ
mkFieldAs Name
name String
s

-- | @'mkFieldAs' (mkName "foo") "bar"@ defines a field for "bar" as @foo@.
mkFieldAs :: Name -> String -> DecsQ
mkFieldAs :: Name -> String -> DecsQ
mkFieldAs Name
name String
s = do
  let st :: Q Type
st = Q TyLit -> Q Type
forall (m :: Type -> Type). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: Type -> Type). Quote m => String -> m TyLit
strTyLit String
s)
  let lbl :: Q Exp
lbl = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
conE 'Proxy Q Exp -> Q Type -> Q Exp
forall (m :: Type -> Type). Quote m => m Exp -> m Type -> m Exp
`sigE` (Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT ''Proxy Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Q Type
st)
  [Q Dec] -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence [Name -> Q Type -> Q Dec
forall (m :: Type -> Type). Quote m => Name -> m Type -> m Dec
sigD Name
name (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT ''FieldOptic Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Q Type
st
    , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
name) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE 'itemAssoc Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
lbl) []
    , Dec -> Q Dec
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
name Inline
Inline RuleMatch
FunLike Phases
AllPhases
    ]