module Data.Functor.ProductIsomorphic.TH.Internal (
defineProductConstructor, defineTupleProductConstructor,
reifyRecordType,
) where
import Language.Haskell.TH
(Q, Name, tupleTypeName, Info (..), reify,
TypeQ, arrowT, appT, conT, varT,
Dec, ExpQ, conE, Con (..), TyVarBndr (..), )
import Language.Haskell.TH.Compat.Data (unDataD)
import Data.List (foldl')
import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..))
recordInfo' :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' = d where
d (TyConI tcon) = do
(_cxt, tcn, bs, _mk, [r], _ds) <- unDataD tcon
let vns = map getTV bs
case r of
NormalC dcn ts -> Just (((buildT tcn vns, vns), conE dcn), (Nothing, [return t | (_, t) <- ts]))
RecC dcn vts -> Just (((buildT tcn vns, vns), conE dcn), (Just ns, ts))
where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts]
_ -> Nothing
d _ = Nothing
getTV (PlainTV n) = n
getTV (KindedTV n _) = n
buildT tcn vns = foldl' appT (conT tcn) [ varT vn | vn <- vns ]
reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType recTypeName =
maybe
(fail $ "Defined record type constructor not found: " ++ show recTypeName)
return
. recordInfo' =<< reify recTypeName
defineProductConstructor :: Name
-> Q [Dec]
defineProductConstructor tyN = do
(((tyQ, _), dtQ), (_, colts)) <- reifyRecordType tyN
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) tyQ colts) where
productConstructor = $(dtQ)
|]
defineTupleProductConstructor :: Int
-> Q [Dec]
defineTupleProductConstructor =
defineProductConstructor . tupleTypeName