rank2classes 1.2 → 1.2.1
raw patch · 3 files changed
+68/−41 lines, 3 files
Files
- CHANGELOG.md +4/−0
- rank2classes.cabal +1/−1
- src/Rank2/TH.hs +63/−40
CHANGELOG.md view
@@ -1,3 +1,7 @@+Version 1.2.1+---------------+* Added unsafeDeriveApply+ Version 1.2 --------------- * Added the class instances for Data.Functor.Const
rank2classes.cabal view
@@ -1,5 +1,5 @@ name: rank2classes-version: 1.2+version: 1.2.1 synopsis: standard type constructor class hierarchy, only with methods of rank 2 types description: A mirror image of the standard type constructor class hierarchy rooted in 'Functor', except with methods of rank 2
src/Rank2/TH.hs view
@@ -10,7 +10,7 @@ {-# Language TemplateHaskell #-} -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial -module Rank2.TH (deriveAll, deriveFunctor, deriveApply, deriveApplicative,+module Rank2.TH (deriveAll, deriveFunctor, deriveApply, unsafeDeriveApply, deriveApplicative, deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable) where @@ -40,6 +40,11 @@ (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty sequence [instanceD (return []) instanceType [genAp cs, genLiftA2 cs, genLiftA3 cs]] +unsafeDeriveApply :: Name -> Q [Dec]+unsafeDeriveApply ty = do+ (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty+ sequence [instanceD (return []) instanceType [genApUnsafely cs, genLiftA2Unsafely cs, genLiftA3Unsafely cs]]+ deriveApplicative :: Name -> Q [Dec] deriveApplicative ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty@@ -85,14 +90,23 @@ genFmap cs = funD '(Rank2.<$>) (map genFmapClause cs) genAp :: [Con] -> Q Dec-genAp [con] = funD '(Rank2.<*>) [genApClause con]+genAp [con] = funD '(Rank2.<*>) [genApClause False con] genLiftA2 :: [Con] -> Q Dec-genLiftA2 [con] = funD 'Rank2.liftA2 [genLiftA2Clause con]+genLiftA2 [con] = funD 'Rank2.liftA2 [genLiftA2Clause False con] genLiftA3 :: [Con] -> Q Dec-genLiftA3 [con] = funD 'Rank2.liftA3 [genLiftA3Clause con]+genLiftA3 [con] = funD 'Rank2.liftA3 [genLiftA3Clause False con] +genApUnsafely :: [Con] -> Q Dec+genApUnsafely cons = funD '(Rank2.<*>) (genApClause True <$> cons)++genLiftA2Unsafely :: [Con] -> Q Dec+genLiftA2Unsafely cons = funD 'Rank2.liftA2 (genLiftA2Clause True <$> cons)++genLiftA3Unsafely :: [Con] -> Q Dec+genLiftA3Unsafely cons = funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons)+ genPure :: [Con] -> Q Dec genPure cs = funD 'Rank2.pure (map genPureClause cs) @@ -137,51 +151,57 @@ ParensT ty -> genFmapField fun ty fieldAccess wrap _ -> fieldAccess -genLiftA2Clause :: Con -> Q Clause-genLiftA2Clause (NormalC name fieldTypes) = do+genLiftA2Clause :: Bool -> Con -> Q Clause+genLiftA2Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") fieldNames2 <- replicateM (length fieldTypes) (newName "y")- let pats = [varP f, tildeP (conP name $ map varP fieldNames1), tildeP (conP name $ map varP fieldNames2)]+ let pats = [varP f,+ (if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+ tildeP (conP name $ map varP fieldNames2)] body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newField :: (Name, Name) -> BangType -> Q Exp- newField (x, y) (_, fieldType) = genLiftA2Field (varE f) fieldType (varE x) (varE y) id+ newField (x, y) (_, fieldType) = genLiftA2Field unsafely (varE f) fieldType (varE x) (varE y) id clause pats body []-genLiftA2Clause (RecC name fields) = do+genLiftA2Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" y <- newName "y" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) =- fieldExp fieldName (genLiftA2Field (varE f) fieldType (getFieldOf x) (getFieldOf y) id)+ fieldExp fieldName (genLiftA2Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) id) where getFieldOf = appE (varE fieldName) . varE clause [varP f, varP x, varP y] body [] -genLiftA2Field :: Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp-genLiftA2Field fun fieldType field1Access field2Access wrap = do+genLiftA2Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genLiftA2Field unsafely fun fieldType field1Access field2Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> [| $(wrap fun) $field1Access $field2Access |] AppT _ ty | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA2) fun) $field1Access $field2Access |]- AppT t1 t2 | t1 /= VarT typeVar -> genLiftA2Field fun t2 field1Access field2Access (appE (varE 'liftA2) . wrap)- SigT ty _kind -> genLiftA2Field fun ty field1Access field2Access wrap- ParensT ty -> genLiftA2Field fun ty field1Access field2Access wrap- _ -> error ("Cannot apply liftA2 to field of type " <> show fieldType)+ AppT t1 t2 + | t1 /= VarT typeVar -> genLiftA2Field unsafely fun t2 field1Access field2Access (appE (varE 'liftA2) . wrap)+ SigT ty _kind -> genLiftA2Field unsafely fun ty field1Access field2Access wrap+ ParensT ty -> genLiftA2Field unsafely fun ty field1Access field2Access wrap+ _ | unsafely -> [| error "Cannot apply liftA2 to field" |]+ | otherwise -> error ("Cannot apply liftA2 to field of type " <> show fieldType) -genLiftA3Clause :: Con -> Q Clause-genLiftA3Clause (NormalC name fieldTypes) = do+genLiftA3Clause :: Bool -> Con -> Q Clause+genLiftA3Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") fieldNames2 <- replicateM (length fieldTypes) (newName "y") fieldNames3 <- replicateM (length fieldTypes) (newName "z")- let pats = [varP f, tildeP (conP name $ map varP fieldNames1), tildeP (conP name $ map varP fieldNames2), + let pats = [varP f,+ (if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+ tildeP (conP name $ map varP fieldNames2), tildeP (conP name $ map varP fieldNames3)] body = normalB $ appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes newField :: (Name, Name, Name) -> BangType -> Q Exp- newField (x, y, z) (_, fieldType) = genLiftA3Field (varE f) fieldType (varE x) (varE y) (varE z) id+ newField (x, y, z) (_, fieldType) = genLiftA3Field unsafely (varE f) fieldType (varE x) (varE y) (varE z) id clause pats body []-genLiftA3Clause (RecC name fields) = do+genLiftA3Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" y <- newName "y"@@ -189,12 +209,12 @@ let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) =- fieldExp fieldName (genLiftA3Field (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id)+ fieldExp fieldName (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id) where getFieldOf = appE (varE fieldName) . varE clause [varP f, varP x, varP y, varP z] body [] -genLiftA3Field :: Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp-genLiftA3Field fun fieldType field1Access field2Access field3Access wrap = do+genLiftA3Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genLiftA3Field unsafely fun fieldType field1Access field2Access field3Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _@@ -203,40 +223,43 @@ | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA3) fun) $(field1Access) $(field2Access) $(field3Access) |] AppT t1 t2 | t1 /= VarT typeVar- -> genLiftA3Field fun t2 field1Access field2Access field3Access (appE (varE 'liftA3) . wrap)- SigT ty _kind -> genLiftA3Field fun ty field1Access field2Access field3Access wrap- ParensT ty -> genLiftA3Field fun ty field1Access field2Access field3Access wrap- _ -> error ("Cannot apply liftA3 to field of type " <> show fieldType)+ -> genLiftA3Field unsafely fun t2 field1Access field2Access field3Access (appE (varE 'liftA3) . wrap)+ SigT ty _kind -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap+ ParensT ty -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap+ _ | unsafely -> [| error "Cannot apply liftA3 to field" |]+ | otherwise -> error ("Cannot apply liftA3 to field of type " <> show fieldType) -genApClause :: Con -> Q Clause-genApClause (NormalC name fieldTypes) = do+genApClause :: Bool -> Con -> Q Clause+genApClause unsafely (NormalC name fieldTypes) = do fieldNames1 <- replicateM (length fieldTypes) (newName "x") fieldNames2 <- replicateM (length fieldTypes) (newName "y")- let pats = [tildeP (conP name $ map varP fieldNames1), tildeP (conP name $ map varP fieldNames2)]+ let pats = [(if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+ tildeP (conP name $ map varP fieldNames2)] body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newField :: (Name, Name) -> BangType -> Q Exp- newField (x, y) (_, fieldType) = genApField fieldType (varE x) (varE y) id+ newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id clause pats body []-genApClause (RecC name fields) = do+genApClause unsafely (RecC name fields) = do x <- newName "x" y <- newName "y" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) =- fieldExp fieldName (genApField fieldType (getFieldOf x) (getFieldOf y) id)+ fieldExp fieldName (genApField unsafely fieldType (getFieldOf x) (getFieldOf y) id) where getFieldOf = appE (varE fieldName) . varE clause [varP x, varP y] body [] -genApField :: Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp-genApField fieldType field1Access field2Access wrap = do+genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genApField unsafely fieldType field1Access field2Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |] AppT _ ty | ty == VarT typeVar -> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |]- AppT t1 t2 | t1 /= VarT typeVar -> genApField t2 field1Access field2Access (appE (varE 'liftA2) . wrap)- SigT ty _kind -> genApField ty field1Access field2Access wrap- ParensT ty -> genApField ty field1Access field2Access wrap- _ -> error ("Cannot apply ap to field of type " <> show fieldType)+ AppT t1 t2 | t1 /= VarT typeVar -> genApField unsafely t2 field1Access field2Access (appE (varE 'liftA2) . wrap)+ SigT ty _kind -> genApField unsafely ty field1Access field2Access wrap+ ParensT ty -> genApField unsafely ty field1Access field2Access wrap+ _ | unsafely -> [| error ("Cannot apply ap to field" <> $(pure $ LitE $ StringL $ show fieldType)) |]+ | otherwise -> error ("Cannot apply ap to field of type " <> show fieldType) genPureClause :: Con -> Q Clause genPureClause (NormalC name fieldTypes) = do