{-# 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' :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' = Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *).
Monad m =>
Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
d where
d :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
d (TyConI tcon :: Dec
tcon) = do
(tcn :: Name
tcn, bs :: [TyVarBndr]
bs, r :: Con
r) <-
do (_cxt :: Cxt
_cxt, tcn :: Name
tcn, bs :: [TyVarBndr]
bs, _mk :: Maybe Type
_mk, [r :: Con
r], _ds :: Cxt
_ds) <- Dec -> Maybe (Cxt, Name, [TyVarBndr], Maybe Type, [Con], Cxt)
unDataD Dec
tcon
(Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr]
bs, Con
r)
Maybe (Name, [TyVarBndr], Con)
-> Maybe (Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do (_cxt :: Cxt
_cxt, tcn :: Name
tcn, bs :: [TyVarBndr]
bs, _mk :: Maybe Type
_mk, r :: Con
r , _ds :: Cxt
_ds) <- Dec -> Maybe (Cxt, Name, [TyVarBndr], Maybe Type, Con, Cxt)
unNewtypeD Dec
tcon
(Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr]
bs, Con
r)
let vns :: [Name]
vns = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTV [TyVarBndr]
bs
case Con
r of
NormalC dcn :: Name
dcn ts :: [BangType]
ts -> (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. a -> Maybe a
Just (((Name -> [Name] -> TypeQ
buildT Name
tcn [Name]
vns, [Name]
vns), Name -> ExpQ
conE Name
dcn), (Maybe [Name]
forall a. Maybe a
Nothing, [Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t | (_, t :: Type
t) <- [BangType]
ts]))
RecC dcn :: Name
dcn vts :: [VarBangType]
vts -> (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. a -> Maybe a
Just (((Name -> [Name] -> TypeQ
buildT Name
tcn [Name]
vns, [Name]
vns), Name -> ExpQ
conE Name
dcn), ([Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
ns, [m Type]
ts))
where (ns :: [Name]
ns, ts :: [m Type]
ts) = [(Name, m Type)] -> ([Name], [m Type])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name
n, Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t) | (n :: Name
n, _, t :: Type
t) <- [VarBangType]
vts]
_ -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. Maybe a
Nothing
d _ = Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. Maybe a
Nothing
getTV :: TyVarBndr -> Name
getTV (PlainTV n :: Name
n) = Name
n
getTV (KindedTV n :: Name
n _) = Name
n
buildT :: Name -> [Name] -> TypeQ
buildT tcn :: Name
tcn vns :: [Name]
vns = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tcn) [ Name -> TypeQ
varT Name
vn | Name
vn <- [Name]
vns ]
reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType recTypeName :: Name
recTypeName =
Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> ((((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msgOnErr)
(((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> (Info
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Info
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' (Info -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Q Info -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q Info
reify Name
recTypeName
where
recTypeNameS :: String
recTypeNameS = Name -> String
forall a. Show a => a -> String
show Name
recTypeName
recTypeNameB :: String
recTypeNameB = Name -> String
nameBase Name
recTypeName
msgOnErr :: String
msgOnErr =
"Valid record type constructor not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameS String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " Possible causes:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not a type name.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (Type name must be prefixed with double-single-quotes: e.g. ''" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ " has multiple data constructors.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (Currently, only types with exactly *one* data constructors are supported)\n"
defineProductConstructor :: Name
-> Q [Dec]
defineProductConstructor :: Name -> Q [Dec]
defineProductConstructor tyN :: Name
tyN = do
(((tyQ :: TypeQ
tyQ, _), dtQ :: ExpQ
dtQ), (_, colts :: [TypeQ]
colts)) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType Name
tyN
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) tyQ colts) where
productConstructor = $(dtQ)
|]
defineTupleProductConstructor :: Int
-> Q [Dec]
defineTupleProductConstructor :: Int -> Q [Dec]
defineTupleProductConstructor =
Name -> Q [Dec]
defineProductConstructor (Name -> Q [Dec]) -> (Int -> Name) -> Int -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
tupleTypeName