diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for czipwith + +## 1.0.0.0 -- May 2017 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Lennart Spitzner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lennart Spitzner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/czipwith.cabal b/czipwith.cabal new file mode 100644 --- /dev/null +++ b/czipwith.cabal @@ -0,0 +1,51 @@ +name: czipwith +version: 1.0.0.0 +synopsis: CZipWith class and deriving via TH +description: A typeclass similar to Data.Distributive, but for + data parameterised with a type constructor. The name + comes from the resemblance of its method to the regular + zipWith function. The abstraction is useful for example + for program config handling. +license: BSD3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +copyright: Copyright (C) 2017 Lennart Spitzner +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +homepage: https://github.com/lspitzner/czipwith/ +bug-reports: https://github.com/lspitzner/czipwith/issues + +source-repository head + type: git + location: https://github.com/lspitzner/czipwith.git + +library + exposed-modules: Data.CZipWith + -- other-modules: + -- other-extensions: + build-depends: + { base >=4.7 && <4.10 + , template-haskell >=2.9 && <2.12 + } + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: { + -Wall + } + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + buildable: True + build-depends: + { czipwith + , base >=4.7 && <4.10 + , transformers >= 0.4.1.0 && <666 + -- no upper bound. The dep only gets used for old bases anyways + } + ghc-options: -Wall + main-is: Test.hs + hs-source-dirs: src-test diff --git a/src-test/Test.hs b/src-test/Test.hs new file mode 100644 --- /dev/null +++ b/src-test/Test.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module Main where + + + +import Data.CZipWith +import Data.Functor.Identity + + + +data A f = A + { a_str :: f String + , a_bool :: f Bool + } + +data B f = B + { b_int :: f Int + , b_float :: f Float + , b_a :: A f + } + +deriving instance Show (A Identity) +deriving instance Eq (A Identity) + + +deriveCZipWith ''A +deriveCZipWith ''B + +main :: IO () +main = do + let x1 = A (Identity "string") (Identity True) + let x2 = A (Just "just") Nothing + let x3 = cZipWith + ( \x my -> case my of + Nothing -> x + Just y -> Identity y + ) + x1 + x2 + errorIf (x3 /= A (Identity "just") (Identity True)) $ return () + +errorIf :: Bool -> a -> a +errorIf False = id +errorIf True = error "errorIf" diff --git a/src/Data/CZipWith.hs b/src/Data/CZipWith.hs new file mode 100644 --- /dev/null +++ b/src/Data/CZipWith.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +-- | A typeclass for an operation resembling 'zipWith' for types that are +-- parameterized over a constructor, plus template-haskell magic to +-- automatically derive instances. +-- +-- @ +-- zipWith :: (g -> h -> i ) -> [g] -> [h] -> [i] +-- cZipWith :: CZipWith k => (forall a . g a -> h a -> i a) -> k g -> k h -> k i +-- @ +-- +-- Types of the corresponding kind occur for example when handling program +-- configuration: When we define our an example configuration type like +-- +-- @ +-- data MyConfig f = MyConfig +-- { flag_foo :: f Bool +-- , flag_bar :: f Bool +-- , flag_someLimit :: f Int +-- } +-- @ +-- +-- then +-- +-- * @MyConfig Maybe@ can be used as the result-type of parsing the +-- commandline or a configuration file; it includes the option that some +-- field was not specified; +-- * @MyConfig Identity@ can be used to represent both the default +-- configuration and the actual configuration derived from +-- defaults and the user input; +-- * @MyConfig (Const Text)@ type to represent documentation for our config, +-- to be displayed to the user. +-- +-- This has the advantage that our configuration is defined in one place only, +-- so that changes are easy to make and we do not ever run into any internal +-- desynchonization of different datatypes. And once we obtained the final +-- config @:: MyConfig Identity@, we don't have to think about @Nothing@ cases +-- anymore. +-- +-- The @'CZipWith'@ helps with this use-case, more specifically the merging of +-- input and default config: we can express the merging of user/default config +-- @:: MyConfig Maybe -> MyConfig Identity -> MyConfig Identity@ in terms of +-- @'cZipWith'@ (and get the implementation for free via 'deriveCZipWith'). +-- +-- As an example for such usage, the +-- package uses this approach +-- together with using automatically-derived Semigroup-instances that allow +-- merging of config values (for example when commandline args do not override, +-- but are added to those settings read from config file). See +-- . +module Data.CZipWith + ( CZipWith(..) + , deriveCZipWith + ) +where + + + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + + + +-- | laws: +-- +-- * @'cZipWith' (\\x _ -> x) g _ = g@ +-- * @'cZipWith' (\\_ y -> y) _ h = h@ +-- +-- This class is morally related to the class from the +-- package, +-- even when its method might not look similar to +-- those from @'Distributive'@. From the corresponding docs: +-- +-- > To be distributable a container will need to have a way to consistently +-- > zip a potentially infinite number of copies of itself. This effectively +-- > means that the holes in all values of that type, must have the same +-- > cardinality, fixed sized vectors, infinite streams, functions, etc. +-- > and no extra information to try to merge together. +-- +-- Especially "all values of that type must have the same cardinality" is +-- true for instances of CZipWith, the only difference being that the "holes" +-- are instantiations of the @f :: * -> *@ to some type, where they are simply +-- @a :: *@ for @'Distributive'@. +-- +-- For many @'Distributive'@ instances there are corresponding datatypes that +-- are instances of @'CZipWith'@ (although they do not seem particularly +-- useful..), for example: +-- +-- @ +-- newtype CUnit a f = CUnit (f a) -- corresponding to 'Identity' +-- data CPair a b f = CPair (f a) (f b) -- corresponding to 'data MonoPair a = MonoPair a a' +-- -- (the trivial fixed-size vector example :) +-- data CStream a f = CStream (f a) (CStream a f) -- corresponding to an infinite stream +-- @ +class CZipWith (k :: (* -> *) -> *) where + -- | zipWith on constructors instead of values. + cZipWith :: (forall a . g a -> h a -> i a) -> k g -> k h -> k i + + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap + +-- | Derives a 'CZipWith' instance for a datatype of kind @(* -> *) -> *@. +-- +-- Requires that for this datatype (we shall call its argument @f :: * -> *@ here) +-- +-- * there is exactly one constructor; +-- * all fields in the one constructor are either of the form @f x@ for some +-- @x@ or of the form @X f@ for some type @X@ where there is an +-- @instance CZipWith X@. +-- +-- For example, the following would be valid usage: +-- +-- @ +-- data A f = A +-- { a_str :: f String +-- , a_bool :: f Bool +-- } +-- +-- data B f = B +-- { b_int :: f Int +-- , b_float :: f Float +-- , b_a :: A f +-- } +-- +-- deriveCZipWith ''A +-- deriveCZipWith ''B +-- @ +-- +-- This produces the following instances: +-- +-- @ +-- instance CZipWith A where +-- cZipWith f (A x1 x2) (A y1 y2) = A (f x1 y1) (f x2 y2) +-- +-- instance CZipWith B where +-- cZipWith f (B x1 x2 x3) (B y1 y2 y3) +-- = B (f x1 y1) (f x2 y2) (cZipWith f x3 y3) +-- @ +deriveCZipWith :: Name -> DecsQ +deriveCZipWith name = do + info <- reify name + case info of +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (DataD _ _ [tyvarbnd] _ [con] []) -> do +#else + TyConI (DataD _ _ [tyvarbnd] [con] []) -> do +#endif + let (cons, elemTys) = case con of + NormalC c tys -> (c, tys <&> \(_, t) -> t) + RecC c tys -> (c, tys <&> \(_, _, t) -> t) + _ -> + error + $ "Deriving requires non-GADT, non-infix data type/record!" + ++ " (Found: " + ++ show con + ++ ")" + let tyvar = case tyvarbnd of + PlainTV n -> n + KindedTV n _ -> n + let fQ = mkName "f" + let indexTys = zip [1 ..] elemTys + let indexTysVars = indexTys <&> \(i :: Int, ty) -> + (ty, mkName $ "x" ++ show i, mkName $ "y" ++ show i) + let dPat1 = conP cons $ indexTysVars <&> \(_, x, _) -> varP x + let dPat2 = conP cons $ indexTysVars <&> \(_, _, x) -> varP x + let pats = [varP fQ, dPat1, dPat2] + let + params = indexTysVars <&> \(ty, x, y) -> case ty of + AppT (VarT a1) _ | a1 == tyvar -> [|$(varE fQ) $(varE x) $(varE y)|] + AppT ConT{} (VarT a2) | a2 == tyvar -> + [|cZipWith $(varE fQ) $(varE x) $(varE y)|] + _ -> + error + $ "All constructor arguments must have either type k a for some a or C k for some C (with instance CZip C)!" + ++ " (Found: " + ++ show ty + ++ ")" + let body = normalB $ appsE $ conE cons : params + let funQ = funD 'cZipWith [clause pats body []] + sequence [instanceD (cxt []) [t|CZipWith $(conT name)|] [funQ]] + TyConI (DataD{}) -> + error + $ "datatype must have kind (* -> *) -> *!" + ++ " (Found: " + ++ show info + ++ ")" + _ -> + error + $ "name does not refer to a datatype!" + ++ " (Found: " + ++ show info + ++ ")" +