module Control.Isomorphism.Partial.TH
( constructorIso
, defineIsomorphisms
) where
import Control.Monad
import Data.Char (toLower)
import Data.List (find)
import Language.Haskell.TH
import Control.Isomorphism.Partial.Unsafe (Iso (Iso))
gadtError :: a
gadtError = error "Control.Isomorphism.Partial.TH: GADTs currently not supported."
conName :: Con -> Name
conName (NormalC name _) = name
conName (RecC name _) = name
conName (InfixC _ name _) = name
conName (ForallC _ _ con) = conName con
conName (GadtC _ _ _) = gadtError
conName (RecGadtC _ _ _) = gadtError
conFields :: Con -> [Type]
conFields (NormalC _ fields) = map (\(_, t) -> t) fields
conFields (RecC _ fields) = map (\(_, _, t) -> t) fields
conFields (InfixC lhs _ rhs) = map (\(_, t) -> t) [lhs, rhs]
conFields (ForallC _ _ con) = conFields con
conFields (GadtC _ _ _) = gadtError
conFields (RecGadtC _ _ _) = gadtError
data DecInfo = DecInfo Type [TyVarBndr] [Con]
decInfo :: Dec -> Q DecInfo
decInfo (DataD _ name tyVars _ cs _) = return $ DecInfo (ConT name) tyVars cs
decInfo (NewtypeD _ name tyVars _ c _) = return $ DecInfo (ConT name) tyVars [c]
decInfo _ = fail "partial isomorphisms can only be derived for constructors of data type or newtype declarations."
tyVarBndrToType :: TyVarBndr -> Type
tyVarBndrToType (PlainTV n) = VarT n
tyVarBndrToType (KindedTV n k) = SigT (VarT n) k
isoType :: Type -> [TyVarBndr] -> [Type] -> Q Type
isoType typ tyVarBndrs fields = do
isoCon <- [t| Iso |]
return $ ForallT tyVarBndrs [] $ isoCon `AppT` (isoArgs fields) `AppT` (applyAll typ $ map tyVarBndrToType tyVarBndrs)
isoArgs :: [Type] -> Type
isoArgs [] = TupleT 0
isoArgs [x] = x
isoArgs (x:xs) = AppT (AppT (TupleT 2) x) (isoArgs xs)
applyAll :: Type -> [Type] -> Type
applyAll = foldl AppT
constructorIso :: Name -> ExpQ
constructorIso name = do
DataConI n _ d <- reify name
TyConI dec <- reify d
DecInfo _ _ cs <- decInfo dec
let Just con = find (\c -> n == conName c) cs
isoFromCon (wildcard cs) con
wildcard :: [Con] -> [MatchQ]
wildcard cs
= if length cs > 1
then [match (wildP) (normalB [| Nothing |]) []]
else []
rename :: Name -> Name
rename n
= mkName (toLower c : cs) where c : cs = nameBase n
defineIsomorphisms :: Name -> Q [Dec]
defineIsomorphisms d = do
TyConI dec <- reify d
DecInfo typ tyVarBndrs cs <- decInfo dec
join `fmap` mapM (\a -> defFromCon (wildcard cs) typ tyVarBndrs a) cs
defFromCon :: [MatchQ] -> Type -> [TyVarBndr] -> Con -> DecsQ
defFromCon matches t tyVarBndrs con = do
let funName = rename $ conName con
sig <- SigD funName `fmap` isoType t tyVarBndrs (conFields con)
fun <- funD funName [ clause [] (normalB (isoFromCon matches con)) [] ]
return [sig, fun]
isoFromCon :: [MatchQ] -> Con -> ExpQ
isoFromCon matches con = do
let c = conName con
let fs = conFields con
let n = length fs
(ps, vs) <- genPE n
v <- newName "x"
let f = lamE [nested tupP ps]
[| Just $(foldl appE (conE c) vs) |]
let g = lamE [varP v]
(caseE (varE v) $
[ match (conP c ps)
(normalB [| Just $(nested tupE vs) |]) []
] ++ matches)
[| Iso $f $g |]
genPE :: Int -> Q ([PatQ], [ExpQ])
genPE n = do
ids <- replicateM n (newName "x")
return (map varP ids, map varE ids)
nested :: ([t] -> t) -> [t] -> t
nested tup [] = tup []
nested _ [x] = x
nested tup (x:xs) = tup [x, nested tup xs]