contravariant-extras 0.3.5.1 → 0.3.5.2
raw patch · 3 files changed
+85/−112 lines, 3 filesdep ~template-haskell-compat-v0208PVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell-compat-v0208
API changes (from Hackage documentation)
Files
- contravariant-extras.cabal +3/−3
- library/Contravariant/Extras/Contrazip.hs +1/−1
- library/Contravariant/Extras/TH.hs +81/−108
contravariant-extras.cabal view
@@ -1,5 +1,5 @@ name: contravariant-extras-version: 0.3.5.1+version: 0.3.5.2 category: Control synopsis: Extras for the "contravariant" package homepage: https://github.com/nikita-volkov/contravariant-extras@@ -27,10 +27,10 @@ Contravariant.Extras.Op Contravariant.Extras.Op.Contrazip other-modules:- Contravariant.Extras.TH Contravariant.Extras.Prelude+ Contravariant.Extras.TH build-depends: base >=4.10 && <5, contravariant >=1.3 && <2, template-haskell >=2.8 && <3,- template-haskell-compat-v0208 >=0.1.2 && <2+ template-haskell-compat-v0208 >=0.1.4 && <2
library/Contravariant/Extras/Contrazip.hs view
@@ -17,5 +17,5 @@ -- Generate the @contrazip@ functions:-return (join (map (TH.divisibleContrazipDecs "contrazip") (reverse [2..42])))+return (join (map (TH.contrazipDecs "contrazip") (reverse [2..42])))
library/Contravariant/Extras/TH.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE CPP #-}-module Contravariant.Extras.TH where+module Contravariant.Extras.TH (+ opContrazipDecs,+ contrazipDecs,+ contrazipExp,+ ) where import Contravariant.Extras.Prelude import Data.Functor.Contravariant@@ -8,14 +11,15 @@ import qualified TemplateHaskell.Compat.V0208 as Compat --- |--- Generates declarations like the following:--- --- @--- tuple3 :: Monoid a => Op a b1 -> Op a b2 -> Op a b3 -> Op a ( b1 , b2 , b3 )--- tuple3 ( Op op1 ) ( Op op2 ) ( Op op3 ) =--- Op $ \( v1 , v2 , v3 ) -> mconcat [ op1 v1 , op2 v2 , op3 v3 ]--- @+{-|+Generates declarations in the spirit of the following:++@+tuple3 :: Monoid a => Op a b1 -> Op a b2 -> Op a b3 -> Op a ( b1 , b2 , b3 )+tuple3 ( Op op1 ) ( Op op2 ) ( Op op3 ) =+ Op $ \( v1 , v2 , v3 ) -> mconcat [ op1 v1 , op2 v2 , op3 v3 ]+@+-} opContrazipDecs :: String -> Int -> [ Dec ] opContrazipDecs baseName arity = [ signature , value ]@@ -29,7 +33,7 @@ ForallT vars cxt type_ where vars =- map (PlainTV . mkName) ("a" : bs)+ map (Compat.specifiedPlainTV . mkName) ("a" : bs) where bs = map b (enumFromTo 1 arity)@@ -40,7 +44,7 @@ [ pred ] where pred =- classP ''Monoid [ a ]+ Compat.classP ''Monoid [ a ] where a = VarT (mkName "a") @@ -118,96 +122,72 @@ varName = mkName (showString "v" (show index)) --- |--- Generates declarations in the spirit of the following:--- --- @--- contrazip4 :: Divisible f => f a1 -> f a2 -> f a3 -> f a4 -> f ( a1 , a2 , a3 , a4 )--- contrazip4 f1 f2 f3 f4 =--- divide $(TupleTH.splitTupleAt 4 1) f1 $--- divide $(TupleTH.splitTupleAt 3 1) f2 $--- divide $(TupleTH.splitTupleAt 2 1) f3 $--- f4--- @-divisibleContrazipDecs :: String -> Int -> [Dec]-divisibleContrazipDecs baseName arity =- [signature, value]- where- name =- mkName (showString baseName (show arity))- signature =- SigD name type_- where- type_ =- ForallT vars cxt type_- where- fName =- mkName "f"- aNames =- map aName (enumFromTo 1 arity)- where- aName index =- mkName (showString "a" (show index))- vars =- map PlainTV (fName : aNames)- cxt =- [pred]- where- pred =- classP ''Divisible [VarT fName]- type_ =- foldr appArrowT result params- where- appArrowT a b =- AppT (AppT ArrowT a) b- result =- AppT (VarT fName) tuple- where- tuple =- foldl AppT (TupleT arity) (map VarT aNames)- params =- map param aNames- where- param aName =- AppT (VarT fName) (VarT aName)- value =- FunD name clauses- where- clauses =- [clause]- where- clause =- Clause pats body []- where- pats =- map pat (enumFromTo 1 arity)- where- pat index =- VarP name- where- name =- mkName (showString "f" (show index))- body =- NormalB (exp arity)- where- exp index =- case index of- 1 ->- VarE (mkName (showString "f" (show arity)))- _ ->- foldl1 AppE- [- VarE 'divide- ,- splitTupleAtE index 1- ,- VarE (mkName (showString "f" (show (arity - index + 1))))- ,- exp (pred index)- ]+{-|+Generates declarations in the spirit of the following: -splitTupleAtE :: Int -> Int -> Exp-splitTupleAtE arity position =+@+contrazip4 :: Divisible f => f a1 -> f a2 -> f a3 -> f a4 -> f ( a1 , a2 , a3 , a4 )+contrazip4 f1 f2 f3 f4 =+ divide $(TupleTH.splitTupleAt 4 1) f1 $+ divide $(TupleTH.splitTupleAt 3 1) f2 $+ divide $(TupleTH.splitTupleAt 2 1) f3 $+ f4+@+-}+contrazipDecs :: String -> Int -> [Dec]+contrazipDecs baseName arity = [signature, value] where+ name = mkName (showString baseName (show arity))+ signature = SigD name (contrazipType arity)+ value = FunD name clauses where+ clauses = [clause] where+ clause = Clause [] body [] where+ body = NormalB (contrazipExp arity)++contrazipType :: Int -> Type+contrazipType arity = ForallT vars cxt type_ where+ fName = mkName "f"+ aNames = map aName (enumFromTo 1 arity) where+ aName index = mkName (showString "a" (show index))+ vars = map Compat.specifiedPlainTV (fName : aNames)+ cxt = [pred] where+ pred = Compat.classP ''Divisible [VarT fName]+ type_ = foldr appArrowT result params where+ appArrowT a b = AppT (AppT ArrowT a) b+ result = AppT (VarT fName) tuple where+ tuple = foldl AppT (TupleT arity) (map VarT aNames)+ params = map param aNames where+ param aName = AppT (VarT fName) (VarT aName)++{-|+Contrazip lambda expression of specified arity.++Allows to create contrazip expressions of any arity:++>>>:t $(return (contrazipExp 2))+$(return (contrazipExp 2))+ :: Data.Functor.Contravariant.Divisible.Divisible f =>+ f a1 -> f a2 -> f (a1, a2)+-}+contrazipExp :: Int -> Exp+contrazipExp arity = SigE (LamE pats body) (contrazipType arity) where+ pats = map pat (enumFromTo 1 arity) where+ pat index = VarP name where+ name = mkName (showString "f" (show index))+ body = exp arity where+ exp index = case index of+ 1 -> VarE (mkName (showString "f" (show arity)))+ _ -> foldl1 AppE [+ VarE 'divide+ ,+ splitTupleAtExp index 1+ ,+ VarE (mkName (showString "f" (show (arity - index + 1))))+ ,+ exp (pred index)+ ]++splitTupleAtExp :: Int -> Int -> Exp+splitTupleAtExp arity position = let nameByIndex index = Name (OccName ('_' : show index)) NameS names = enumFromTo 0 (pred arity) & map nameByIndex@@ -216,10 +196,3 @@ exps = names & map VarE body = splitAt position exps & \ (a, b) -> Compat.tupE [Compat.tupE a, Compat.tupE b] in LamE [pat] body--classP :: Name -> [Type] -> Pred-#if MIN_VERSION_template_haskell(2,10,0)-classP n tl = foldl AppT (ConT n) tl-#else-classP = ClassP-#endif