{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Registry.TH (
TypeclassOptions
, checkRegistry
, makeTypeclass
, makeTypeclassWith
, unsafeCoerceRegistry
) where
import Data.List (nubBy)
import Data.Registry
import Data.Set (difference)
import qualified Data.Set as Set
import Data.Text as T (drop, splitOn)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude (String)
import Protolude hiding (Strict, Type)
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)))
checkRegistry :: Name -> Q Exp
checkRegistry registryName = do
registryInfo <- reify registryName
case registryInfo of
VarI _ registryType _ ->
case registryType of
AppT (AppT (ConT actualType) ins) out -> do
let actual = show actualType :: String
if actual == "Data.Registry.Registry.Registry" then do
let insTypes = fst <$> typesOf ins
let outTypes = fst <$> typesOf out
let missingFromOutputs = Set.fromList insTypes `difference` Set.fromList outTypes
if null missingFromOutputs then
[| unsafeCoerceRegistry $(varE registryName) :: $(returnQ $ AppT (AppT (ConT actualType) (normalizeTypes ins)) (normalizeTypes out)) |]
else
reportErrorWith $ "Some input values cannot be built from the registry. " <> show (Set.toList missingFromOutputs)
else
reportErrorWith $ "We can only check the coverage of a Registry, got: " <> actual
_ ->
reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry), Got: " <> show registryType
other ->
reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry). Got: " <> show other
where reportErrorWith msg = do
reportError msg
varE registryName
typesOf :: Type -> [(String, Type)]
typesOf (AppT (AppT PromotedConsT t) rest) = (typeName t, t) : typesOf rest
typesOf _ = []
typeName :: Type -> String
typeName (ConT n) = nameBase n
typeName (AppT (AppT (TupleT 2) t1) t2) = "(" <> typeName t1 <> "," <> typeName t2 <> ")"
typeName (AppT (AppT (AppT (TupleT 3) t1) t2) t3) = "(" <> typeName t1 <> "," <> typeName t2 <> "," <> typeName t3 <> ")"
typeName (AppT (AppT (AppT (AppT (TupleT 4) t1) t2) t3) t4) = "(" <> typeName t1 <> "," <> typeName t2 <> "," <> typeName t3 <> "," <> typeName t4 <> ")"
typeName (AppT (TupleT i) t) = "Tuple" <> show i <> "(" <> typeName t <> ")"
typeName (AppT (AppT ArrowT t1) t2) = typeName t1 <> " -> " <> typeName t2
typeName (AppT (AppT (AppT ArrowT t1) t2) t3) = typeName t1 <> " -> " <> typeName t2 <> " -> " <> typeName t3
typeName (AppT (AppT (AppT (AppT ArrowT t1) t2) t3) t4) = typeName t1 <> " -> " <> typeName t2 <> " -> " <> typeName t3 <> " -> " <> typeName t4
typeName (AppT ArrowT t) = typeName t <> " -> "
typeName (AppT ListT t) = "[" <> typeName t <> "]"
typeName (AppT t1 t2) = typeName t1 <> "(" <> typeName t2 <> ")"
typeName t = show t
normalizeTypes :: Type -> Type
normalizeTypes t =
rebuild $ nubBy (\(n1, _) (n2, _) -> n1 == n2) (typesOf t)
where rebuild [] = SigT PromotedNilT (AppT ListT StarT)
rebuild ((_, t1) : rest) = AppT (AppT PromotedConsT t1) (rebuild rest)
unsafeCoerceRegistry :: Registry ins out -> Registry ins1 out1
unsafeCoerceRegistry (Registry a b c d) = Registry a b c d