contravariant-extras (empty) → 0.2
raw patch · 8 files changed
+365/−0 lines, 8 filesdep +basedep +base-preludedep +contravariantsetup-changed
Dependencies added: base, base-prelude, contravariant, template-haskell, tuple-th
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- contravariant-extras.cabal +57/−0
- library/Contravariant/Extras.hs +9/−0
- library/Contravariant/Extras/Contramap.hs +21/−0
- library/Contravariant/Extras/Op.hs +11/−0
- library/Contravariant/Extras/Op/Contramap.hs +23/−0
- library/Contravariant/Extras/TH.hs +220/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2015, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ contravariant-extras.cabal view
@@ -0,0 +1,57 @@+name:+ contravariant-extras+version:+ 0.2+category:+ Control+synopsis:+ Extras for the "contravariant" package+homepage:+ https://github.com/nikita-volkov/contravariant-extras +bug-reports:+ https://github.com/nikita-volkov/contravariant-extras/issues +author:+ Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+ Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+ (c) 2015, Nikita Volkov+license:+ MIT+license-file:+ LICENSE+build-type:+ Simple+cabal-version:+ >=1.10+++source-repository head+ type:+ git+ location:+ git://github.com/nikita-volkov/contravariant-extras.git+++library+ hs-source-dirs:+ library+ ghc-options:+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ other-modules:+ Contravariant.Extras.TH+ exposed-modules:+ Contravariant.Extras+ Contravariant.Extras.Contramap+ Contravariant.Extras.Op+ Contravariant.Extras.Op.Contramap+ build-depends:+ tuple-th >= 0.2.5 && < 0.3,+ template-haskell >= 2.8 && < 3,+ contravariant >= 1.3 && < 2,+ base-prelude >= 0.1.19 && < 0.2,+ base >= 4.6 && < 5+
+ library/Contravariant/Extras.hs view
@@ -0,0 +1,9 @@+module Contravariant.Extras+(+ -- |+ -- A berserk collection of @contramap@ functions with arities of up to 42.+ module Contravariant.Extras.Contramap,+)+where++import Contravariant.Extras.Contramap
+ library/Contravariant/Extras/Contramap.hs view
@@ -0,0 +1,21 @@+-- |+-- A berserk collection of @contramap@ functions with arities of up to 42.+-- +-- Why 42?+-- Well, naturally, because it's the answer to the ultimate question of life,+-- the universe and everything.+-- +-- It's exported as a separate module from "Contravariant.Extras"+-- only to not pollute its documentation.+-- The "Contravariant.Extras" module still reexports this module,+-- so you can simply import that only.+-- +module Contravariant.Extras.Contramap where++import BasePrelude+import qualified Contravariant.Extras.TH as TH+++-- Generate the @contramap@ functions:+return (join (map (TH.divisibleContramapDecs "contramap") (reverse [2..42])))+
+ library/Contravariant/Extras/Op.hs view
@@ -0,0 +1,11 @@+-- |+-- This module exports functions specialized for the `Op` type.+module Contravariant.Extras.Op+(+ -- |+ -- A berserk collection of @contramap@ functions with arities of up to 42.+ module Contravariant.Extras.Op.Contramap,+)+where++import Contravariant.Extras.Op.Contramap
+ library/Contravariant/Extras/Op/Contramap.hs view
@@ -0,0 +1,23 @@+-- |+-- A berserk collection of @contramap@ functions with arities of up to 42,+-- which are specialized to the 'Op' type,+-- and jump thru less hoops than their 'Divisible'-based siblings.+-- +-- Why 42?+-- Well, naturally, because it's the answer to the ultimate question of life,+-- the universe and everything.+-- +-- It's exported as a separate module from "Contravariant.Extras.Op"+-- only to not pollute its documentation.+-- The "Contravariant.Extras.Op" module still reexports this module,+-- so you can simply import that only.+-- +module Contravariant.Extras.Op.Contramap where++import BasePrelude+import qualified Contravariant.Extras.TH as TH+++-- Generate the @contramap@ functions:+return (join (map (TH.opContramapDecs "contramap") (reverse [2..42])))+
+ library/Contravariant/Extras/TH.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE CPP #-}+module Contravariant.Extras.TH where++import BasePrelude+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Language.Haskell.TH hiding (classP)+import qualified TupleTH+++-- |+-- 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 ]+-- @+opContramapDecs :: String -> Int -> [ Dec ]+opContramapDecs baseName arity =+ [ signature , value ]+ where+ name =+ mkName (showString baseName (show arity))+ signature =+ SigD name type_+ where+ type_ =+ ForallT vars cxt type_+ where+ vars =+ map (PlainTV . mkName) ("a" : bs)+ where+ bs =+ map b (enumFromTo 1 arity)+ where+ b index =+ showString "b" (show index)+ cxt =+ [ pred ]+ where+ pred =+ classP ''Monoid [ a ]+ where+ a =+ VarT (mkName "a") + type_ =+ foldr appArrowT result params+ where+ appArrowT a b =+ AppT (AppT ArrowT a) b+ a =+ VarT (mkName "a")+ result =+ AppT (AppT (ConT ''Op) a) tuple+ where+ tuple =+ foldl AppT (TupleT arity) params+ where+ params =+ map param (enumFromTo 1 arity)+ where+ param index =+ VarT (mkName (showString "b" (show index)))+ params =+ map param (enumFromTo 1 arity)+ where+ param index =+ AppT (AppT (ConT ''Op) a) b+ where+ b =+ VarT (mkName (showString "b" (show index)))+ value =+ FunD name clauses+ where+ clauses =+ [ clause ]+ where+ clause =+ Clause pats body []+ where+ pats =+ map pat (enumFromTo 1 arity)+ where+ pat index =+ ConP 'Op pats+ where+ pats =+ [ VarP name ]+ where+ name =+ mkName (showString "op" (show index))+ body =+ NormalB (AppE (ConE 'Op) lambda)+ where+ lambda =+ LamE pats exp+ where+ pats =+ [ TupP pats ]+ where+ pats =+ map pat (enumFromTo 1 arity)+ where+ pat index =+ VarP (mkName (showString "v" (show index)))+ exp =+ AppE (VarE 'mconcat) (ListE applications)+ where+ applications =+ map application (enumFromTo 1 arity)+ where+ application index =+ AppE (VarE opName) (VarE varName)+ where+ opName =+ mkName (showString "op" (show index))+ varName =+ mkName (showString "v" (show index))++-- |+-- Generates declarations in the spirit of the following:+-- +-- @+-- contramap4 :: Divisible f => f a1 -> f a2 -> f a3 -> f a4 -> f ( a1 , a2 , a3 , a4 )+-- contramap4 f1 f2 f3 f4 =+-- divide $(TupleTH.splitTupleAt 4 1) f1 $+-- divide $(TupleTH.splitTupleAt 3 1) f2 $+-- divide $(TupleTH.splitTupleAt 2 1) f3 $+-- f4+-- @+divisibleContramapDecs :: String -> Int -> [Dec]+divisibleContramapDecs 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)+ ]++splitTupleAtE :: Int -> Int -> Exp+splitTupleAtE arity position =+ unsafePerformIO $+ runQ $+ TupleTH.splitTupleAt arity position++classP :: Name -> [Type] -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+classP n tl = foldl AppT (ConT n) tl+#else+classP = ClassP+#endif