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