{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Registry.TH (
TypeclassOptions
, makeTypeclass
, makeTypeclassWith
) where
import Data.Text as T (drop, splitOn)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type, Strict)
makeTypeclass :: Name -> DecsQ
makeTypeclass = makeTypeclassWith (TypeclassOptions ("With" <>) (T.drop 1))
data TypeclassOptions = TypeclassOptions {
_typeclassName :: Text -> Text
, _functionName :: Text -> Text
}
makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ
makeTypeclassWith (TypeclassOptions typeclassNameMaker functionNameMaker) componentType = do
info <- reify componentType
case info of
TyConI (DataD _ name typeVars _ [RecC _ types] _) -> do
readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types
pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types
<> readertInstance
TyConI (NewtypeD _ name typeVars _ (RecC _ types) _) -> do
readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types
pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types
<> readertInstance
other -> do
qReport True ("can only generate a typeclass for a record of functions, got: " <> show other)
pure []
createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
createTypeclass typeclassNameMaker functionNameMaker name typeVars types =
let typeclassName = modifyName typeclassNameMaker (dropQualified name)
functions = fmap (makeFunctionDeclaration functionNameMaker) types
in [ClassD [] typeclassName typeVars [] functions]
createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance typeclassNameMaker functionNameMaker name [tvar] types =
let tvarName = case tvar of PlainTV v -> v; KindedTV v _ -> v
typeclassName = modifyName typeclassNameMaker (dropQualified name)
functions = fmap (makeFunctionInstance functionNameMaker (mkName "ReaderT")) types
typeclassT = ConT typeclassName
components = mkName "c"
componentTypeT = ConT name
componentsTypeT = VarT components
readerT = ConT (mkName "ReaderT")
hasTypeT = ConT (mkName "HasType")
tvarT = VarT tvarName
in pure [InstanceD Nothing
[AppT (AppT hasTypeT (AppT componentTypeT tvarT)) componentsTypeT]
(AppT typeclassT (AppT (AppT readerT componentsTypeT) tvarT))
functions]
createReadertInstance _ _ _ tvars _ = do
qReport True ("can only generate a instance for a component typeclass when it has only one type variable, got: " <> show tvars)
pure []
makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration functionNameMaker (name, _, type') =
SigD (modifyName functionNameMaker (dropQualified name)) type'
makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance functionNameMaker runnerName (name, _, functionType) =
let functionName = modifyName functionNameMaker (dropQualified name)
readerT = ConE runnerName
component = mkName "component"
numberOfParameters = countNumberOfParameters functionType
parameterNames = (\i -> mkName ("p" <> show i)) <$> [1..numberOfParameters]
parameters = VarP <$> parameterNames
firstApplication = AppE (VarE name) (AppE (VarE (mkName "getTyped")) (VarE component))
body = foldl' (\r p -> AppE r (VarE p)) firstApplication parameterNames
in
FunD functionName [Clause parameters (NormalB (AppE readerT (LamE [VarP component] body))) []]
countNumberOfParameters :: Type -> Int
countNumberOfParameters (ForallT _ _ t) = countNumberOfParameters t
countNumberOfParameters (AppT (AppT ArrowT _) t) = 1 + countNumberOfParameters t
countNumberOfParameters _ = 0
modifyName :: (Text -> Text) -> Name -> Name
modifyName f n = mkName (toS . f . show $ n)
dropQualified :: Name -> Name
dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))