module Data.Fieldwise
( Fieldwise(..)
, deriveFieldwise
)
where
import Language.Haskell.TH
import Data.Monoid
import Control.Applicative
class Fieldwise r where
type UnliftedRecord r
sequenceR :: Applicative f => r f -> f (UnliftedRecord r)
hoistR :: (forall a . f a -> g a) -> r f -> r g
zipWithR :: (forall a . f a -> g a -> h a) -> r f -> r g -> r h
appR :: (forall a . f a -> (UnliftedRecord r -> a) -> g a) -> r f -> r g
liftR :: Applicative f => UnliftedRecord r -> r f
deriveFieldwise :: Name -> (String -> String) -> Q [Dec]
deriveFieldwise t upName = do
info <- reify t
case info of
TyConI (DataD ctx _name vars tcons@(firsttcon:_) _derivings) -> do
let dname = mkName (upName (nameBase t))
f <- newName "f"
fg <- newName "fg"
q <- newName "q"
let upCon (NormalC nm stypes) = NormalC (mkName (upName (nameBase nm))) (map upStrictType stypes)
upCon (RecC nm vstypes) = RecC (mkName (upName (nameBase nm))) (map upVarStrictType vstypes)
upCon (InfixC stype1 nm stype2) = InfixC (upStrictType stype1) (mkName (upName (nameBase nm))) (upStrictType stype2)
upCon (ForallC favars ctx2 con2) = ForallC favars ctx2 (upCon con2)
upStrictType (strict, tp) = (strict, AppT (VarT f) tp)
upVarStrictType (nm, strict, tp) = (mkName (upName (nameBase nm)), strict, AppT (VarT f) tp)
getName (NormalC nm _) = nm
getName (RecC nm _) = nm
getName (InfixC _ nm _) = nm
getName (ForallC _ _ c) = getName c
getArity (NormalC _nm stypes) = length stypes
getArity (RecC _nm vstypes) = length vstypes
getArity (InfixC stype1 _nm stype2) = 2
getArity (ForallC favars ctx2 con2) = getArity con2
selectorNth i (RecC _nm vstypes) = VarE (fst3 (vstypes!!(i1)))
selectorNth i (NormalC nm stypes) = LamE [ConP nm [ if idx==i then VarP q else WildP | (_,idx) <- zip stypes [1..] ]]
(VarE q)
selectorNth 1 (InfixC _ nm _) = LamE [InfixP (VarP q) nm WildP] (VarE q)
selectorNth 2 (InfixC _ nm _) = LamE [InfixP WildP nm (VarP q)] (VarE q)
selectorNth i (ForallC _ _ c) = selectorNth i c
fst3 (a,_,_) = a
return
[ DataD ctx dname (PlainTV f : vars) (map upCon tcons) []
, InstanceD ([ClassP ''Alternative [VarT f]])
(AppT (ConT ''Monoid) (ConT dname `AppT` VarT f))
[
FunD 'mempty [Clause [] (NormalB (foldl AppE (ConE (getName (upCon firsttcon)))
(take (getArity firsttcon) (repeat (VarE 'empty))))) []]
, FunD 'mappend [Clause [ConP (getName (upCon tc)) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity tc]],
ConP (getName (upCon tc)) [VarP (mkName ("r" ++ show i)) | i <- [1..getArity tc]]]
(NormalB (foldl AppE (ConE (getName (upCon tc)))
[InfixE (Just (VarE (mkName ("l" ++ show i)))) (VarE '(<|>)) (Just (VarE (mkName ("r" ++ show i)))) |
i <- [1..getArity tc]])) []
| tc <- tcons
]
]
, InstanceD [] (ConT ''Fieldwise `AppT` ConT dname)
[ TySynInstD ''UnliftedRecord [ConT dname] (ConT t)
, FunD 'sequenceR [Clause [ConP (getName (upCon firsttcon)) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity firsttcon]]]
(NormalB (foldl (\l r -> InfixE (Just l) (VarE '(<*>)) (Just r)) (VarE 'pure `AppE` ConE (getName firsttcon))
[VarE (mkName ("l" ++ show i)) | i <- [1..getArity firsttcon]])) []]
, FunD 'hoistR [Clause [VarP fg, ConP (getName (upCon tc)) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity tc]]]
(NormalB (foldl AppE (ConE (getName (upCon tc)))
[VarE fg `AppE` VarE (mkName ("l" ++ show i)) | i <- [1..getArity tc]])) []
| tc <- tcons ]
, FunD 'zipWithR [Clause [VarP fg,
ConP (getName (upCon tc)) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity tc]],
ConP (getName (upCon tc)) [VarP (mkName ("r" ++ show i)) | i <- [1..getArity tc]]]
(NormalB (foldl AppE (ConE (getName (upCon tc)))
[VarE fg `AppE` VarE (mkName ("l" ++ show i)) `AppE` VarE (mkName ("r" ++ show i)) |
i <- [1..getArity tc]])) []
| tc <- tcons ]
, FunD 'appR [Clause [VarP fg,
ConP (getName (upCon tc)) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity tc]]]
(NormalB (foldl AppE (ConE (getName (upCon tc)))
[VarE fg `AppE` VarE (mkName ("l" ++ show i)) `AppE` selectorNth i tc |
i <- [1..getArity tc]])) []
| tc <- tcons ]
, FunD 'liftR [Clause [ConP (getName tc) [VarP (mkName ("l" ++ show i)) | i <- [1..getArity tc]]]
(NormalB (foldl AppE (ConE (getName (upCon tc)))
[VarE 'pure `AppE` VarE (mkName ("l" ++ show i)) |
i <- [1..getArity tc]])) []
| tc <- tcons ]
]
]
_ -> error $ "Not a data with single constructor declaration: " ++ show info