diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/contravariant-extras.cabal b/contravariant-extras.cabal new file mode 100644 --- /dev/null +++ b/contravariant-extras.cabal @@ -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 +maintainer: + Nikita Volkov +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 + diff --git a/library/Contravariant/Extras.hs b/library/Contravariant/Extras.hs new file mode 100644 --- /dev/null +++ b/library/Contravariant/Extras.hs @@ -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 diff --git a/library/Contravariant/Extras/Contramap.hs b/library/Contravariant/Extras/Contramap.hs new file mode 100644 --- /dev/null +++ b/library/Contravariant/Extras/Contramap.hs @@ -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]))) + diff --git a/library/Contravariant/Extras/Op.hs b/library/Contravariant/Extras/Op.hs new file mode 100644 --- /dev/null +++ b/library/Contravariant/Extras/Op.hs @@ -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 diff --git a/library/Contravariant/Extras/Op/Contramap.hs b/library/Contravariant/Extras/Op/Contramap.hs new file mode 100644 --- /dev/null +++ b/library/Contravariant/Extras/Op/Contramap.hs @@ -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]))) + diff --git a/library/Contravariant/Extras/TH.hs b/library/Contravariant/Extras/TH.hs new file mode 100644 --- /dev/null +++ b/library/Contravariant/Extras/TH.hs @@ -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