{-# 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 (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
$ \s :: String
s@(Char
x:String
xs) ->
  let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ 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
  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 :: TypeQ
st = TyLitQ -> TypeQ
litT (String -> TyLitQ
strTyLit String
s)
  let lbl :: ExpQ
lbl = Name -> ExpQ
conE 'Proxy ExpQ -> TypeQ -> ExpQ
`sigE` (Name -> TypeQ
conT ''Proxy TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
st)
  [Q Dec] -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Name -> TypeQ -> Q Dec
sigD Name
name (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
conT ''FieldOptic TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
st
    , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
name) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'itemAssoc ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
lbl) []
    , Dec -> Q Dec
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
    ]