{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Data.Recollections.TH
  (  -- * Collections generator
    mkCollection
  , mkIndices

    -- * Distributive
    -- $distributive
  , mkDistribute

    -- * Representable
    -- $representable
  , mkIndex
  , mkTabulate
  ) where

import Data.Char
import Data.Foldable
import Data.Traversable
import GHC.Generics (Generic, Generic1, Generically1)
import Language.Haskell.TH

{- | Generate a @Collection a@ type from a enum-like type.

Every constructor is represented by a field.
Reserved words like @type@ get a @'@ suffix.'

> data Things = This | That
>   deriving (Eq, Ord, Show, Enum, Bounded)
>
> mkCollection ''Things
>
> -- resulting splice
> data Collection a = { this, that :: a}
>   deriving (Eq, Show, Generic, Generic1, Functor, Foldable, Traversable)
>   deriving Applicative via (Generically1 Collection)
-}
mkCollection :: Name -> Q [Dec]
mkCollection :: Name -> Q [Dec]
mkCollection Name
tags = do
  let nothingsBanger :: Q Bang
nothingsBanger = Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness
  let collectionName :: Name
collectionName = String -> Name
mkName String
"Collection"

  [String]
names <- Name -> Q [String]
tagNames Name
tags
  let
    fields :: [Q VarBangType]
fields = do
      String
name <- [String]
names
      pure $ Name -> Q BangType -> Q VarBangType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
fieldNameOf String
name) (Q BangType -> Q VarBangType) -> Q BangType -> Q VarBangType
forall a b. (a -> b) -> a -> b
$ Q Bang -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType Q Bang
nothingsBanger (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a"))
  let constr :: Q Con
constr = Name -> [Q VarBangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
collectionName [Q VarBangType]
fields
  let
    derivs :: [Q DerivClause]
derivs =
      [ Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy)
          [ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Show
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Eq
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Generic
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Generic1
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Functor
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Foldable
          , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Traversable
          ]
      , Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just (DerivStrategy -> Maybe DerivStrategy)
-> DerivStrategy -> Maybe DerivStrategy
forall a b. (a -> b) -> a -> b
$ Type -> DerivStrategy
ViaStrategy (Type -> DerivStrategy) -> Type -> DerivStrategy
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Generically1 Type -> Type -> Type
`AppT` Name -> Type
ConT Name
collectionName)
        [ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Applicative
        ]
      ]
  Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD Q Cxt
forall a. Monoid a => a
mempty Name
collectionName [TyVarBndr BndrVis
collectionTyVar] Maybe Type
forall a. Maybe a
Nothing [Q Con
constr] [Q DerivClause]
derivs

-- | The @a@ binder of @data Collection a@.
--
-- @template-haskell-2.21@ (GHC 9.8) changed the binder flag of 'dataD'
-- from @()@ to 'BndrVis'.
#if MIN_VERSION_template_haskell(2,21,0)
collectionTyVar :: TyVarBndrVis
collectionTyVar :: TyVarBndr BndrVis
collectionTyVar = Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV (String -> Name
mkName String
"a") BndrVis
BndrReq
#else
collectionTyVar :: TyVarBndrUnit
collectionTyVar = PlainTV (mkName "a") ()
#endif

{- | Generate a value filled with the indices matching the fields.

> indices :: Collection Things
> indices = Collection { this = This, that = That }

This is useful with the Applicative instance to provide indexed operations:

> indexed c :: Collection a -> Collection (Things, a)
> indexed c = (,) <$> indices <*> c
-}
mkIndices :: Name -> Q [Dec]
mkIndices :: Name -> Q [Dec]
mkIndices Name
tags = do
  let collectionName :: Name
collectionName = String -> Name
mkName String
"Collection"
  let indicesName :: Name
indicesName = String -> Name
mkName String
"indices"
  [String]
names <- Name -> Q [String]
tagNames Name
tags
  Dec
sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
indicesName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
collectionName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tags
  let body :: Q Exp
body = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
collectionName) ((String -> Q Exp) -> [String] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) [String]
names)
  Dec
fun <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
indicesName [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) [] ]
  pure [Dec
sig, Dec
fun]

-- * Distributive

{- $distributive

<https://hackage-content.haskell.org/package/distributive-0.6.3/docs/Data-Distributive.html>
-}

{- | Generate a dual of sequenceA.

> distribute :: Functor f => f (Collection a) -> Collection (f a)
> distribute f = Collection
>   { this      = this      <$> f
>   , that      = that      <$> f
>   , something = something <$> f
>   , else'     = else'     <$> f
>   , entirely  = entirely  <$> f
>   }
-}
mkDistribute :: Name -> Q [Dec]
mkDistribute :: Name -> Q [Dec]
mkDistribute Name
tags = do
  let collectionName :: Name
collectionName = String -> Name
mkName String
"Collection"
  let distributeName :: Name
distributeName = String -> Name
mkName String
"distribute"
  [String]
names <- Name -> Q [String]
tagNames Name
tags
  let f :: Name
f = String -> Name
mkName String
"f"
  let a :: Name
a = String -> Name
mkName String
"a"
  {- The binder must not shadow any field selector the body refers to by
     'mkName' (those are resolved lexically, by occurrence name). Field names
     always start with a lowercase letter, so a leading underscore is safe;
     plain @f@ would break for a tag named @F@. -}
  Name
arg <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
  Dec
sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
distributeName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
    [TyVarBndr Specificity] -> Q Cxt -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [] ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Functor Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f]) (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
collectionName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a)))) (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
        (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
collectionName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a))
  let
    body :: Q Exp
body =
      (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
collectionName) do
        String
name <- [String]
names
        let fieldSelector :: Q Exp
fieldSelector = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> String
fieldNameOf String
name
        Q Exp -> [Q Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Exp -> [Q Exp]) -> Q Exp -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fmap) Q Exp
fieldSelector Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arg
  Dec
fun <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
distributeName
    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arg] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
    ]
  Dec
inl <- Name -> Q Dec
inlineP Name
distributeName
  pure [Dec
sig, Dec
fun, Dec
inl]

-- * Representable

{- $representabl

<https://hackage-content.haskell.org/package/adjunctions-4.4.4/docs/Data-Functor-Rep.html>
-}

{- | Read a collection field using an index value.

> index :: Collection a -> Things -> a
> index c = \case This -> this c; That -> that c; …
-}
mkIndex :: Name -> Q [Dec]
mkIndex :: Name -> Q [Dec]
mkIndex Name
tags = do
  let collectionName :: Name
collectionName = String -> Name
mkName String
"Collection"
  let indexName :: Name
indexName = String -> Name
mkName String
"index"
  [String]
names <- Name -> Q [String]
tagNames Name
tags
  let a :: Name
a = String -> Name
mkName String
"a"
  Dec
sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
indexName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
collectionName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a)) (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tags)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a)
  [(String, Name)]
bounds <- [String] -> (String -> Q (String, Name)) -> Q [(String, Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
names \String
name ->
    (,) String
name (Name -> (String, Name)) -> Q Name -> Q (String, Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> String
fieldNameOf String
name)
  let
    body :: Q Exp
body = [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE do
      (String
name, Name
bound) <- [(String, Name)]
bounds
      Q Match -> [Q Match]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Match -> [Q Match]) -> Q Match -> [Q Match]
forall a b. (a -> b) -> a -> b
$ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
name) []) (Q Exp -> Q Body
forall (m :: * -> *). 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 :: * -> *). Quote m => Name -> m Exp
varE Name
bound) []

  Dec
fun <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
indexName
    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
        [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
collectionName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ ((String, Name) -> Q Pat) -> [(String, Name)] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat)
-> ((String, Name) -> Name) -> (String, Name) -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Name) -> Name
forall a b. (a, b) -> b
snd) [(String, Name)]
bounds
        ]
        (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
        []
    ]
  Dec
inl <- Name -> Q Dec
inlineP Name
indexName
  pure [Dec
sig, Dec
fun, Dec
inl]

{- | Generate a collection with a function from its indices

> tabulate :: (Things -> a) -> Collection a
> tabulate k = Collection { this = k This, that = k That }
-}
mkTabulate :: Name -> Q [Dec]
mkTabulate :: Name -> Q [Dec]
mkTabulate Name
tags = do
  let collectionName :: Name
collectionName = String -> Name
mkName String
"Collection"
  let tabulateName :: Name
tabulateName = String -> Name
mkName String
"tabulate"
  [String]
names <- Name -> Q [String]
tagNames Name
tags
  let a :: Name
a = String -> Name
mkName String
"a"
  Dec
sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
tabulateName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tags)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a))) (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
      Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
collectionName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
  let
    body :: Q Exp
body =
      (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
collectionName) do
        String
name <- [String]
names
        pure $ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
name)
  Dec
fun <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
tabulateName
    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
    ]
  Dec
inl <- Name -> Q Dec
inlineP Name
tabulateName
  pure [Dec
sig, Dec
fun, Dec
inl]

-- * Utils

tagNames :: Name -> Q [String]
tagNames :: Name -> Q [String]
tagNames Name
tags =
 Name -> Q Info
reify Name
tags Q Info -> (Info -> Q [String]) -> Q [String]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) ->
      (Con -> [String] -> Q [String]) -> [String] -> [Con] -> Q [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (([String] -> Con -> Q [String]) -> Con -> [String] -> Q [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> Con -> Q [String]
extractTags) [] [Con]
constructors
    Info
_ ->
      String -> Q [String]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a type constructor name"

extractTags :: [String] -> Con -> Q [String]
extractTags :: [String] -> Con -> Q [String]
extractTags [String]
acc = \case
  NormalC Name
name [] ->
    [String] -> Q [String]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> Q [String]) -> [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc
  Con
huh ->
    -- Skipping would produce a 'Collection' with fewer fields than there are
    -- tags, making the generated 'index' silently non-exhaustive.
    String -> Q [String]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [String]) -> String -> Q [String]
forall a b. (a -> b) -> a -> b
$ String
"Expected a nullary constructor, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a. Show a => a -> String
show Con
huh

-- | Lowercase the leading character and dodge reserved words.
fieldNameOf :: String -> String
fieldNameOf :: String -> String
fieldNameOf = \case
  [] -> []
  Char
n : String
ame -> String -> String
legalizeVariableName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
n Char -> String -> String
forall a. a -> [a] -> [a]
: String
ame

legalizeVariableName :: String -> String
legalizeVariableName :: String -> String
legalizeVariableName String
name
  | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
illegal = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
  | Bool
otherwise = String
name

-- | Haskell 2010 reserved words, which cannot be used as record field names.
illegal :: [String]
illegal :: [String]
illegal =
  [ String
"case", String
"class", String
"data", String
"default", String
"deriving", String
"do"
  , String
"else", String
"foreign", String
"if", String
"import", String
"in"
  , String
"infix", String
"infixl", String
"infixr", String
"instance"
  , String
"let", String
"module", String
"newtype", String
"of"
  , String
"then", String
"type", String
"where", String
"_"
  ]

inlineP :: Name -> Q Dec
inlineP :: Name -> Q Dec
inlineP Name
name = Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
name Inline
Inline RuleMatch
FunLike Phases
AllPhases