data-combinator-gen (empty) → 0.1.0.0

raw patch · 8 files changed

+609/−0 lines, 8 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

CHANGELOG.md +5/−0
LICENSE +20/−0
README.md +78/−0
Setup.hs +2/−0
data-combinator-gen.cabal +86/−0
examples/Cp.hs +273/−0
examples/Main.hs +62/−0
src/Data/Combinators/TH.hs +83/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for data-combinator-gen++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2019 Armando Santos++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.

+ README.md view

@@ -0,0 +1,78 @@+# Data Combinator Generator++Generate a special combinator from any data type.++## Description++This library provides a function to generate a special combinator from any data+type (GADTs are not currently supported).++This was inspired by the recursion-schemes library where they have a function to+automagically generate a base functor. Although, this new base functor data type+has custom constructors and to define the \*-morphism algebras turns into+boring pattern matching.++So, this library provides a function called `makeCombinator` that produces a+nice combinator to deal with data types as they were defined in terms of Pairs+(`(,)`) and Sums (`Either`). With this nice combinator we are able to view a+data type as its equivalent categorical isomorphism and manipulate it with an+interface similar as the `either` function provided from `base`.++## Example++To create this special combinator you just need to call `makeCombinator ''<data+type name>` as in the example below:++```Haskell++-- List type+data List a = Nil | List a (List a)++makeCombinator ''List+```++This example will generate the following code:++```Haskell+makeCombinator ''ListF+  ======>+    listf f_acw7 f_acw8 Nil = f_acw7 ()+    listf f_acw7 f_acw8 (Cons a_acw9 a_acwa) = f_acw8 (a_acw9, a_acwa)+```++As you can see it's pretty close as to have the type defined as the set of+sums and pairs `data List a = Either () (a, List a)`, which we could then use+`either` function as well as other convinent `(,)` combinators.++An **important** note is that the generated function has always the same name as+the data type but in low characters **and** the order of the functions to be+applied to the type constructors it's the same order which they were declared.++A simple example on how we can beneficiate from using this special combinator+when defining catamorphisms using recursion-schemes:++- Without the combinator:+  ```Haskell+  length :: [a] -> Int+  length = cata gene+    where+      gene Nil = 0+      gene (Cons a x) = x + 1+  ```++- With the combinator:+  ```Haskell+  makeCombinator'' ListF++  length :: [a] -> Int+  length = cata (listf (const 0) (succ . snd))+  ```++I recognize that for such a simple data type and catamorphism it's hard to see+any gain in readability/implementation. But with this special combinator it's a+lot easier to go from paper to code as it's almost a direct translation.++There's a fully working example in the `examples` folder that uses the+recursion-schemes library as well as a nice small program calculus (AoP+inspired) combinators library to show how simple and straightforward it is to+use it with this new combinator.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ data-combinator-gen.cabal view

@@ -0,0 +1,86 @@+cabal-version:       >=1.10++-- Initial package description 'data-combinator-gen.cabal' generated by+-- 'cabal init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                data-combinator-gen++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            Generate a special combinator from any data type.++-- A longer description of the package.+description: +  This library provides a function to generate a special combinator from any data type (GADTs are not currently supported).++  This was inspired by the recursion-schemes library where they have a function to automagically generate a base functor. Although, this new base functor data type has custom constructors and to define the *-morphism algebras turns into boring pattern matching.++  So, this library provides a function called `makeCombinator` that produces a+  nice combinator to deal with data types as they were defined in terms of Pairs+  ( (,) ) and Sums (`Either`). With this nice combinator we are able to view a+  data type as its equivalent categorical isomorphism and manipulate it with an+  interface similar as the `either` function provided from `base`.++-- URL for the project homepage or repository.+homepage:            https://github.com/bolt12/data-combinator-gen++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Armando Santos++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer:          armandoifsantos@gmail.com++-- A copyright notice.+-- copyright:++category:            Data++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files:  CHANGELOG.md,+                     README.md,+                     examples/Cp.hs,+                     examples/Main.hs+++library+  -- Modules exported by the library.+  exposed-modules: Data.Combinators.TH++  -- Modules included in this library but not exported.+  -- other-modules:++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:++  -- Other library packages from which modules are imported.+  build-depends:       base >=4.12 && <4.13,+                       template-haskell >= 2.5.0.0 && < 2.16++  -- Directories containing source files.+  hs-source-dirs:      src++  -- Base language which the package is written in.+  default-language:    Haskell2010+

+ examples/Cp.hs view

@@ -0,0 +1,273 @@+{-# LANGUAGE TypeOperators #-}++-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2017/8)++module Cp where++infixl 4  ><+infixl 5  -|-++-- (1) Product -----------------------------------------------------------------++-- Type alias+type a >< b = (a, b)++split :: (a -> b) -> (a -> c) -> a -> b >< c+split f g x = (f x, g x)++(><) :: (a -> b) -> (c -> d) -> a >< c -> b >< d+f >< g = split (f . p1) (g . p2)++-- the 0-adic split ++(!) :: a -> ()+(!) = const ()++-- Renamings:++p1 :: a >< b -> a+p1 = fst++p2 :: a >< b -> b+p2 = snd++-- (2) Coproduct ---------------------------------------------------------------++-- Type alias++type a -|- b = Either a b++-- Renamings:++i1 :: a -> a -|- b+i1 = Left++i2 :: b -> a -|- b+i2 = Right++-- either is predefined++(-|-) :: (a -> b) -> (c -> d) -> a -|- c -> b -|- d+f -|- g = either (i1 . f) (i2 . g)++-- McCarthy's conditional:++cond :: (b -> Bool) -> (b -> c) -> (b -> c) -> b -> c+cond p f g = either f g . grd p++-- (3) Exponentiation ---------------------------------------------------------++-- curry is predefined++ap :: (a -> b) >< a -> b+ap = uncurry ($)++expn :: (b -> c) -> (a -> b) -> a -> c+expn f = curry (f . ap)++p2p :: a >< a -> Bool -> a+p2p p b = if b then snd p else fst p -- pair to predicate++-- exponentiation functor is (a->) predefined ++-- instance Functor ((->) s) where+--	fmap f g = f . g++-- (4) Others -----------------------------------------------------------------++--const :: a -> b -> a st const a x = a is predefined++grd :: (a -> Bool) -> a -> a -|- a+grd p x = if p x then Left x else Right x++-- (5) Natural isomorphisms ----------------------------------------------------++swap :: a >< b -> b >< a+swap = split p2 p1++assocr :: ((a >< b) >< c) -> (a >< (b >< c))+assocr = split (p1 . p1) (p2 >< id)++assocl :: (a >< (b >< c)) -> ((a >< b) >< c)+assocl = split (id >< p1) (p2 . p2)++undistr :: (a >< b) -|- (a >< c) -> a >< (b -|- c)+undistr = either (id >< i1) (id >< i2)++undistl :: (b >< c) -|- (a >< c) -> (b -|- a) >< c+undistl = either (i1 >< id) (i2 >< id)++flatr :: (a >< (b >< c)) -> (a, b, c)+flatr (a, (b, c)) = (a, b, c)++flatl :: ((a >< b) >< c) -> (a, b, c)+flatl ((b, c), d) = (b, c, d)++-- pwnil = split id (!)++br :: a -> a >< ()+br = split id (!) -- bang on the right, old pwnil means "pair with nil"++bl :: a -> () >< a+bl = swap . br++coswap :: a -|- b -> b -|- a+coswap = either i2 i1++coassocr :: ((a -|- b) -|- c) -> (a -|- (b -|- c))+coassocr = either (id -|- i1) (i2 . i2)++coassocl :: (b -|- (a -|- c)) -> ((b -|- a) -|- c)+coassocl = either (i1 . i1) (i2 -|- id)++distl :: ((c -|- a) >< b) -> (c >< b) -|- (a >< b)+distl = uncurry (either (curry i1) (curry i2))++distr :: (b >< c -|- a) -> (b >< c) -|- (b >< a)+distr = (swap -|- swap) . distl . swap++-- (6) Class bifunctor ---------------------------------------------------------++class BiFunctor f where+      bmap :: (a -> b) -> (c -> d) -> (f a c -> f b d)++instance BiFunctor Either where+    bmap f g = f -|- g++instance BiFunctor (,) where+    bmap f g  = f >< g++-- (7) Monads: -----------------------------------------------------------------++-- (7.1) Kleisli monadic composition -------------------------------------------++infix 4  .!++(.!) :: Monad a => (b -> a c) -> (d -> a b) -> d -> a c+(f .! g) a = g a >>= f++mult :: (Monad m) => m (m b) -> m b+-- also known as join+mult = (>>= id)++-- (7.2) Monadic binding ---------------------------------------------------------++ap' :: (Monad m) => (a -> m b, m a) -> m b+ap' = uncurry (=<<)++-- (7.3) Lists++singl :: a -> [a]+singl = return++-- (7.4) Strong monads -----------------------------------------------------------++class (Functor f, Monad f) => Strong f where+      rstr :: (f a >< b) -> f (a >< b)+      rstr (x, b) = do a <- x ; return (a, b)++      lstr :: (b >< f a) -> f (b >< a)+      lstr(b, x) = do a <- x ; return (b, a)++instance Strong IO++instance Strong []++instance Strong Maybe++dstr :: Strong m => (m a, m b) -> m (a, b)       --- double strength+--dstr = mult . fmap rstr . lstr+dstr = rstr .! lstr++splitm :: Strong ff => ff (a -> b) -> a -> ff b+-- Exercise 4.8.13 in Jacobs' "Introduction to Coalgebra" (2012)+splitm = curry (fmap ap . rstr)++{--+-- (7.5) Monad transformers ------------------------------------------------------++class (Monad m, Monad (t m))  => MT t m where   -- monad transformer class+      lift :: m a -> t m a++-- nested lifting:++dlift :: (MT t (t1 m), MT t1 m) => m a -> t (t1 m) a+dlift = lift . lift++--}++-- (8) Basic functions, abbreviations ------------------------------------------++bang :: a -> ()+bang = (!)++dup :: c -> c >< c+dup = split id id++zero :: b -> Integer+zero = const 0++one :: b -> Integer+one  = const 1++nil :: b -> [a]+nil = const []++cons :: (a >< [a]) -> [a]+cons = uncurry (:)++add :: (Integer >< Integer) -> Integer+add = uncurry (+)++mul :: (Integer, Integer) -> Integer+mul = uncurry (*)++conc :: ([a] >< [a]) -> [a]+conc = uncurry (++)++true :: b -> Bool+true = const True++nothing :: b -> Maybe a+nothing = const Nothing++false :: b -> Bool+false = const False++inMaybe :: () -|- a -> Maybe a+inMaybe = either (const Nothing) Just++-- (9) Advanced ----------------------------------------------------------------++class (Functor f) => Unzipable f where+      unzp :: f (a >< b) -> (f a >< f b)+      unzp = split (fmap p1) (fmap p2)++class Functor g => DistL g where+      lamb :: Monad m => g (m a) -> m (g a)++instance DistL [] where lamb = sequence++instance DistL Maybe where+      lamb Nothing  = return Nothing+      lamb (Just a) = fmap Just a  -- where mp f = (return.f).!id++aap :: Monad m  => m (a->b) -> m a -> m b+-- to convert Monad into Applicative+-- (<*>) = curry(lift ap) where lift h (x,y) = do { a <- x; b <- y; return ((curry h a b)) }+aap mf mx = do f <- mf ; f <$> mx++-- gather: n-ary split++gather :: [a -> b] -> a -> [b]+gather l x = map ($ x) l++-- the dual of zip++cozip :: (Functor f) => f a -|- f b -> f (a -|- b)+cozip = either (fmap Left) (fmap Right)++--------------------------------------------------------------------------------+tot :: (a -> b) -> (a -> Bool) -> a -> Maybe b+tot f p = cond p (return . f) nothing+--------------------------------------------------------------------------------

+ examples/Main.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE KindSignatures, TypeFamilies, DeriveFunctor, DeriveTraversable,+    DeriveFoldable #-}++module Main where++import Data.Combinators.TH+import Cp -- Program Calculus Combinators library+import Data.Functor.Foldable -- Recursion schemes library+import Data.Functor.Foldable.TH -- Recursion schemes makeBaseFunctor+import Data.List (foldl')++makeCombinator ''ListF++l :: [a] -> Integer+l = cata (listf zero (succ . p2))++data BTree a = Empty | Node(a, (BTree a, BTree a)) deriving Show++makeBaseFunctor ''BTree+makeCombinator ''BTree+makeCombinator ''BTreeF++countBTree :: BTree a -> Integer+countBTree = cata (btreef (const 0) (succ . uncurry (+) . p2))++data Expr a+    = Lit a+    | Add (Expr a) (Expr a)+    | Expr a :* [Expr a]+    deriving (Show)++makeBaseFunctor ''Expr+makeCombinator ''Expr+makeCombinator ''ExprF++eval :: Expr Integer -> Integer+eval = cata (exprf id add (uncurry $ foldl' (*)))++expr1 :: Expr Integer+expr1 = Add (Lit 2) (Mul (Lit 3) [Lit 4])++data A a = C { v :: a, w :: a } | D { x :: a, z :: a }++makeCombinator ''A++data ExprInfix a+    = ExprInfix a :** [ExprInfix a]+    | AddI (ExprInfix a) (ExprInfix a)+    | LitI a+  deriving (Show)++makeCombinator ''ExprInfix++{- GADTs are not currently supported!+data B = forall a. Eq a => B [a]++makeCombinator ''B+-}++main :: IO ()+main = undefined+

+ src/Data/Combinators/TH.hs view

@@ -0,0 +1,83 @@+module Data.Combinators.TH (makeCombinator) where++import Language.Haskell.TH+import Control.Monad+import Data.Char++-- (1) Main generation function -----++{- | Build a special combinator given a data type name.+e.g.++@++-- List type+data List a = Nil | List a (List a)++makeCombinator ''List+@++This example will generate the following code:++@ +makeCombinator ''ListF+ ======>+  listf f_acw7 f_acw8 Nil = f_acw7 ()+  listf f_acw7 f_acw8 (Cons a_acw9 a_acwa) = f_acw8 (a_acw9, a_acwa)+@+-}+makeCombinator :: Name -> Q [Dec]+makeCombinator t = do+    TyConI (DataD _ _ _ _ constructors _) <- reify t++    pe <- genPE "f" (length constructors)++    let combName = mkName . map toLower . nameBase $ t+        clauses  = map (combinClause pe) $ zip constructors [0..]+    r <- funD combName clauses+    return [r]++-----++-- (2) makeCombinator auxiliary function -----+-- Generates a single function clause++combinClause :: ([PatQ], [ExpQ]) -- Function arguments pattern+             -> (Con, Int) -- (Constructor, Indice of current constructor)+             -> ClauseQ+combinClause (patsF, varsF) (NormalC name fields, i) = do (patsC, varsC) <- genPE "a" (length fields)+                                                          funClause patsF varsF patsC varsC name (length fields) i+combinClause (patsF, varsF) (RecC name fields, i)    = do (patsC, varsC) <- genPE "a" (length fields)+                                                          funClause patsF varsF patsC varsC name (length fields) i+combinClause (patsF, varsF) (InfixC _ name _, i)     = do (patsC, varsC) <- genPE "a" 2+                                                          funClause patsF varsF patsC varsC name 2 i+combinClause _ (ForallC{}, _)  = error "makeCombinator: GADTs are not currently supported."+combinClause _ (GadtC{}, _)    = error "makeCombinator: GADTs are not currently supported."+combinClause _ (RecGadtC{}, _) = error "makeCombinator: GADTs are not currently supported."++-----++-- (3) combinClause auxiliary functions -----+funClause :: [PatQ] -> [ExpQ] -> [PatQ] -> [ExpQ] -> Name -> Int -> Int -> ClauseQ+funClause pF vF pC vC name l i = +    clause (pF ++ [conP name pC]) +           (normalB (appE (vF !! i) +                          (applyConVars vC name vC (l - 1)))) +           []++applyConVars :: [ExpQ] -> t -> [a] -> Int -> ExpQ+applyConVars _ _ [] _             = conE (mkName "()")+applyConVars varsC _ [_] n        = varsC !! n+applyConVars varsC name' (_:fs) n = tupE (applyConVars varsC name' fs (n-1) : [varsC !! n])++------++-- (4) General auxiliary functions -----++-- Generate n unique variables and return them in form of patterns and expressions+genPE :: String -> Int -> Q ([PatQ], [ExpQ])+genPE x n = do+  ids <- replicateM n (newName x)+  return (map varP ids, map varE ids)++-----