{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.Functor.ProductIsomorphic.TH.Internal (
defineProductConstructor, defineTupleProductConstructor,
reifyRecordType,
) where
import Control.Applicative ((<|>))
import Language.Haskell.TH
(Q, Name, tupleTypeName, Info (..), reify,
TypeQ, arrowT, appT, conT, varT,
Dec, ExpQ, conE, Con (..), TyVarBndr (..), nameBase,)
import Language.Haskell.TH.Compat.Data (unDataD, unNewtypeD)
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
(tcn, bs, r) <-
do (_cxt, tcn, bs, _mk, [r], _ds) <- unDataD tcon
Just (tcn, bs, r)
<|>
do (_cxt, tcn, bs, _mk, r , _ds) <- unNewtypeD tcon
Just (tcn, bs, r)
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 msgOnErr)
return
. recordInfo' =<< reify recTypeName
where
recTypeNameS = show recTypeName
recTypeNameB = nameBase recTypeName
msgOnErr =
"Valid record type constructor not found: " ++ recTypeNameS ++ ".\n"
++ " Possible causes:\n"
++ " - " ++ recTypeNameB ++ " is not a type name.\n"
++ " (Type name must be prefixed with double-single-quotes: e.g. ''" ++ recTypeNameB ++ ")\n"
++ " - " ++ recTypeNameB ++ " has multiple data constructors.\n"
++ " (Currently, only types with exactly *one* data constructors are supported)\n"
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