packages feed

one-liner 0.2.2 → 0.3

raw patch · 7 files changed

+359/−117 lines, 7 files

Files

one-liner.cabal view
@@ -1,7 +1,14 @@ Name:                 one-liner-Version:              0.2.2+Version:              0.3 Synopsis:             Constraint-based generics Description:          Write short and concise generic instances of type classes.+                      .+                      There are two separate parts: @Generics.OneLiner@ is for+                      writing generic functions using @GHC.Generics@.+                      The other modules show how to implement these same generic+                      functions with a traversal-style generics type class,+                      without the use of an intermediate generic representation+                      type. Homepage:             https://github.com/sjoerdvisscher/one-liner Bug-reports:          https://github.com/sjoerdvisscher/one-liner/issues License:              BSD3@@ -17,16 +24,17 @@  Library   HS-Source-Dirs:  src-  +   Exposed-modules:+    Generics.OneLiner     Generics.OneLiner.ADT     Generics.OneLiner.ADT1     Generics.OneLiner.Functions     Generics.OneLiner.Functions1     Generics.OneLiner.Info-  +   Build-depends:-      base         >= 4.5 && < 5 +      base         >= 4.5 && < 5     , transformers >= 0.3 && < 0.5     , ghc-prim
+ src/Generics/OneLiner.hs view
@@ -0,0 +1,236 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.OneLiner+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module is for writing generic functions on algebraic data types+-- of kind @*@. These data types must be an instance of the `Generic` type+-- class, which can be derived.+--+-----------------------------------------------------------------------------+{-# LANGUAGE+    RankNTypes+  , TypeFamilies+  , TypeOperators+  , ConstraintKinds+  , FlexibleContexts+  , FlexibleInstances+  , DefaultSignatures+  , ScopedTypeVariables+  #-}+module Generics.OneLiner (+  -- * Producing values+  create, createA, ctorIndex,+  -- * Traversing values+  gmap, gfoldMap, gtraverse,+  -- * Combining values+  gzipWith, mzipWith, zipWithA,+  -- * Single constructor functions+  op0, op1, op2,+  -- * Types+  ADT, ADTRecord, Constraints, For+) where++import GHC.Generics+import GHC.Prim (Constraint)+import Control.Applicative+import Data.Functor.Identity+import Data.Monoid++-- | Collect the constraint requirements for an instance for `t` of class `c`.+type family Constraints (t :: * -> *) (c :: * -> Constraint) :: Constraint+type instance Constraints V1 c = ()+type instance Constraints U1 c = ()+type instance Constraints (f :+: g) c = (Constraints f c, Constraints g c)+type instance Constraints (f :*: g) c = (Constraints f c, Constraints g c)+-- | This is the only instance where actual requirements are generated.+type instance Constraints (K1 i v) c = c v+type instance Constraints (M1 i t f) c = Constraints f c++class ADT' (t :: * -> *) where+  ctorIndex' :: t x -> Int+  ctorIndex' _ = 0+  ctorCount :: proxy (t x) -> Int+  ctorCount _ = 1+  f0 :: (Constraints t c, Applicative f)+     => for c -> (forall s. c s => f s) -> [f (t ())]+  f1 :: (Constraints t c, Applicative f)+     => for c -> (forall s. c s => s -> f s) -> t x -> f (t x)+  f2 :: (Constraints t c, Applicative f)+     => for c -> (forall s. c s => s -> s -> f s) -> t x -> t x -> Maybe (f (t x))++instance ADT' V1 where+  ctorCount _ = 0+  f0 _ _ = []+  f1 _ _ = pure+  f2 _ _ _ = Just . pure++instance (ADT' f, ADT' g) => ADT' (f :+: g) where+  ctorIndex' (L1 l) = ctorIndex' l+  ctorIndex' (R1 r) = ctorCount (undefined :: [f ()]) + ctorIndex' r+  ctorCount _ = ctorCount (undefined :: [f ()]) + ctorCount (undefined :: [g ()])+  f0 for f = map (fmap L1) (f0 for f) ++ map (fmap R1) (f0 for f)+  f1 for f (L1 l) = L1 <$> f1 for f l+  f1 for f (R1 r) = R1 <$> f1 for f r+  f2 for f (L1 a) (L1 b) = fmap (fmap L1) (f2 for f a b)+  f2 for f (R1 a) (R1 b) = fmap (fmap R1) (f2 for f a b)+  f2 _ _ _ _ = Nothing++instance ADT' U1 where+  f0 _ _ = [pure U1]+  f1 _ _ = pure+  f2 _ _ _ = Just . pure++instance (ADT' f, ADT' g) => ADT' (f :*: g) where+  f0 for f = [(:*:) <$> head (f0 for f) <*> head (f0 for f)]+  f1 for f (l :*: r) = (:*:) <$> f1 for f l <*> f1 for f r+  f2 for f (al :*: ar) (bl :*: br) = liftA2 (:*:) <$> f2 for f al bl <*> f2 for f ar br++instance ADT' (K1 i v) where+  f0 _ f = [K1 <$> f]+  f1 _ f (K1 v) = K1 <$> f v+  f2 _ f (K1 l) (K1 r) = Just $ K1 <$> f l r++instance ADT' f => ADT' (M1 i t f) where+  ctorIndex' = ctorIndex' . unM1+  ctorCount _ = ctorCount (undefined :: [M1 i t f ()])+  f0 for f = map (fmap M1) (f0 for f)+  f1 for f = fmap M1 . f1 for f . unM1+  f2 for f (M1 l) (M1 r) = fmap (fmap M1) (f2 for f l r)+++class ADTRecord' (f :: * -> *) where+instance ADTRecord' U1+instance ADTRecord' (f :*: g)+instance ADTRecord' (K1 i v)+instance ADTRecord' f => ADTRecord' (M1 i t f)+instance ADTRecord' f => ADTRecord' (V1 :+: f)+instance ADTRecord' f => ADTRecord' (f :+: V1)+++-- | `ADT` is a constraint type synonym. The `Generic` instance can be derived,+-- and any generic representation will be an instance of `ADT'`.+type ADT t = (Generic t, ADT' (Rep t))++-- | `ADTRecord` is a constraint type synonym. An instance is an `ADT` with exactly one constructor.+type ADTRecord t = (ADT t, ADTRecord' (Rep t))++-- | Tell the compiler which class we want to use in the traversal. Should be used like this:+--+-- > (For :: For Show)+--+-- Where @Show@ can be any class.+data For (c :: * -> Constraint) = For++-- | Create a value (one for each constructor), given how to construct the components.+--+-- @+-- `minBound` = `head` `$` `create` (`For` :: `For` `Bounded`) `minBound`+-- `maxBound` = `last` `$` `create` (`For` :: `For` `Bounded`) `maxBound`+-- @+create :: (ADT t, Constraints (Rep t) c)+       => for c -> (forall s. c s => s) -> [t]+create for f = map runIdentity (createA for (Identity f))++-- | Create a value (one for each constructor), given how to construct the components, under an applicative effect.+--+-- Here's how to implement `get` from the `binary` package:+--+-- @+-- get = getWord8 `>>=` \\ix -> `createA` (`For` :: `For` Binary) get `!!` `fromEnum` ix+-- @+createA :: (ADT t, Constraints (Rep t) c, Applicative f)+        => for c -> (forall s. c s => f s) -> [f t]+createA for f = map (fmap to) (f0 for f)++-- | Get the index in the lists returned by `create` and `createA` of the constructor of the given value.+--+-- For example, this is the implementation of `put` that generates the binary data that+-- the above implentation of `get` expects:+--+-- @+-- `put` t = `putWord8` (`toEnum` (`ctorIndex` t)) `<>` `gfoldMap` (`For` :: `For` `Binary`) `put` t+-- @+--+-- /Note that this assumes a straightforward `Monoid` instance of `Put` which `binary` unfortunately does not provide./+ctorIndex :: ADT t => t -> Int+ctorIndex = ctorIndex' . from++-- | Map over a structure, updating each component.+gmap :: (ADT t, Constraints (Rep t) c)+     => for c -> (forall s. c s => s -> s) -> t -> t+gmap for f = runIdentity . gtraverse for (Identity . f)++-- | Map each component of a structure to a monoid, and combine the results.+--+-- If you have a class `Size`, which measures the size of a structure, then this could be the default implementation:+--+-- @+-- size = `succ` `.` `getSum` `.` `gfoldMap` (`For` :: `For` Size) (`Sum` `.` size)+-- @+gfoldMap :: (ADT t, Constraints (Rep t) c, Monoid m)+         => for c -> (forall s. c s => s -> m) -> t -> m+gfoldMap for f = getConst . gtraverse for (Const . f)++-- | Map each component of a structure to an action, evaluate these actions from left to right, and collect the results.+gtraverse :: (ADT t, Constraints (Rep t) c, Applicative f)+          => for c -> (forall s. c s => s -> f s) -> t -> f t+gtraverse for f = fmap to . f1 for f . from++-- | Combine two values by combining each component of the structures with the given function.+-- Returns `Nothing` if the constructors don't match.+gzipWith :: (ADT t, Constraints (Rep t) c)+         => for c -> (forall s. c s => s -> s -> s) -> t -> t -> Maybe t+gzipWith for f l r = runIdentity <$> zipWithA for (\x y -> Identity (f x y)) l r++-- | Combine two values by combining each component of the structures to a monoid, and combine the results.+-- Returns `mempty` if the constructors don't match.+--+-- @+-- `compare` s t = `compare` (`ctorIndex` s) (`ctorIndex` t) `<>` `mzipWith` (`For` :: `For` `Ord`) `compare` s t+-- @+mzipWith :: (ADT t, Constraints (Rep t) c, Monoid m)+         => for c -> (forall s. c s => s -> s -> m) -> t -> t -> m+mzipWith for f l r = maybe mempty getConst $ zipWithA for (\x y -> Const (f x y)) l r++-- | Combine two values by combining each component of the structures with the given function, under an applicative effect.+-- Returns `Nothing` if the constructors don't match.+zipWithA :: (ADT t, Constraints (Rep t) c, Applicative f)+         => for c -> (forall s. c s => s -> s -> f s) -> t -> t -> Maybe (f t)+zipWithA for f l r = fmap (fmap to) (f2 for f (from l) (from r))++-- | Implement a nullary operator by calling the operator for each component.+--+-- @+-- `mempty` = `op0` (`For` :: `For` `Monoid`) `mempty`+-- `fromInteger` i = `op0` (`For` :: `For` `Num`) (`fromInteger` i)+-- @+op0 :: (ADTRecord t, Constraints (Rep t) c)+    => for c -> (forall s. c s => s) -> t+op0 for f = head $ create for f++-- | Implement a unary operator by calling the operator on the components.+-- This is here for consistency, it is the same as `gmap`.+--+-- @+-- `negate` = `op1` (`For` :: `For` `Num`) `negate`+-- @+op1 :: (ADTRecord t, Constraints (Rep t) c)+     => for c -> (forall s. c s => s -> s) -> t -> t+op1 = gmap++-- | Implement a binary operator by calling the operator on the components.+--+-- @+-- `mappend` = `op2` (`For` :: `For` `Monoid`) `mappend`+-- (`+`) = `op2` (`For` :: `For` `Num`) (`+`)+-- @+op2 :: (ADTRecord t, Constraints (Rep t) c)+    => for c -> (forall s. c s => s -> s -> s) -> t -> t -> t+op2 for f l r = case gzipWith for f l r of+  Just t -> t+  Nothing -> error "op2: constructor mismatch should not be possible for ADTRecord"
src/Generics/OneLiner/ADT.hs view
@@ -1,16 +1,15 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.OneLiner.ADT--- Copyright   :  (c) Sjoerd Visscher 2012 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  sjoerd@w3future.com -- Stability   :  experimental -- Portability :  non-portable ----- This module is for writing generic functions on algebraic data types +-- This module is for writing generic functions on algebraic data types -- of kind @*@. These data types must be an instance of the `ADT` type class.--- +-- -- Here's an example how to write such an instance for this data type: -- -- @@@ -24,7 +23,7 @@ --   `ctorInfo` _ 0 = `ctor` \"A\" --   `ctorInfo` _ 1 = `ctor` \"B\" --   type `Constraints` (T a) c = (c Int, c a, c (T a))---   `buildsRecA` `For` sub rec = +--   `buildsRecA` _ sub rec = --     [ A `<$>` sub (`FieldInfo` (\\(A i _) -> i)) `<*>` sub (`FieldInfo` (\\(A _ a) -> a)) --     , B `<$>` sub (`FieldInfo` (\\(B a _) -> a)) `<*>` rec (`FieldInfo` (\\(B _ t) -> t)) --     ]@@ -34,11 +33,11 @@ -- -- @ -- eqADT :: (`ADT` t, `Constraints` t `Eq`) => t -> t -> `Bool`--- eqADT s t = `ctorIndex` s == `ctorIndex` t `&&` +-- eqADT s t = `ctorIndex` s == `ctorIndex` t `&&` --   `getAll` (`mbuilds` (`For` :: `For` `Eq`) (\\fld -> `All` $ s `!` fld `==` t `!` fld) \``at`\` s) -- @ ------------------------------------------------------------------------------{-# LANGUAGE +{-# LANGUAGE     RankNTypes   , TypeFamilies   , ConstraintKinds@@ -47,12 +46,12 @@   , ScopedTypeVariables   #-} module Generics.OneLiner.ADT (-  +     -- * Re-exports     module Generics.OneLiner.Info   , Constraint     -- | The kind of constraints-    +     -- * The @ADT@ type class   , ADT(..)   , ADTRecord(..)@@ -61,7 +60,7 @@     -- * Helper functions   , (!)   , at-  +     -- * Derived traversal schemes   , builds   , mbuilds@@ -74,9 +73,9 @@   , op0   , op1   , op2-  +   ) where-  + import Generics.OneLiner.Info  import GHC.Prim (Constraint)@@ -95,96 +94,96 @@ -- Where @Show@ can be any class. data For (c :: * -> Constraint) = For --- | Type class for algebraic data types of kind @*@. Minimal implementation: `ctorIndex` and either `buildsA`+-- | Type class for algebraic data types of kind @*@. Implement either `buildsA` -- if the type @t@ is not recursive, or `buildsRecA` if the type @t@ is recursive. class ADT t where    -- | Gives the index of the constructor of the given value in the list returned by `buildsA` and `buildsRecA`.   ctorIndex :: t -> Int   ctorIndex _ = 0-  +   -- | @ctorInfo n@ gives constructor information, f.e. its name, for the @n@th constructor.   --   The first argument is a dummy argument and can be @(undefined :: t)@.   ctorInfo :: t -> Int -> CtorInfo -  -- | The constraints needed to run `buildsA` and `buildsRecA`. +  -- | The constraints needed to run `buildsA` and `buildsRecA`.   -- It should be a list of all the types of the subcomponents of @t@, each applied to @c@.   type Constraints t (c :: * -> Constraint) :: Constraint-  +   buildsA :: (Constraints t c, Applicative f)-          => For c -- ^ Witness for the constraint @c@.+          => for c -- ^ Witness for the constraint @c@.           -> (forall s. c s => FieldInfo (t -> s) -> f s) -- ^ This function should return a value-             -- for each subcomponent of @t@, wrapped in an applicative functor @f@. It is given -             -- information about the field, which contains a projector function to get the subcomponent +             -- for each subcomponent of @t@, wrapped in an applicative functor @f@. It is given+             -- information about the field, which contains a projector function to get the subcomponent              -- from a value of type @t@. The type of the subcomponent is an instance of class @c@.-          -> [f t] -- ^ A list of results, one for each constructor of type @t@. Each element is the -             -- result of applicatively applying the constructor to the results of the given function +          -> [f t] -- ^ A list of results, one for each constructor of type @t@. Each element is the+             -- result of applicatively applying the constructor to the results of the given function              -- for each field of the constructor.-  -  default buildsA :: (c t, Constraints t c, Applicative f) -                  => For c -> (forall s. c s => FieldInfo (t -> s) -> f s) -> [f t]++  default buildsA :: (c t, Constraints t c, Applicative f)+                  => for c -> (forall s. c s => FieldInfo (t -> s) -> f s) -> [f t]   buildsA for f = buildsRecA for f f-  -  buildsRecA :: (Constraints t c, Applicative f) -             => For c -- ^ Witness for the constraint @c@.++  buildsRecA :: (Constraints t c, Applicative f)+             => for c -- ^ Witness for the constraint @c@.              -> (forall s. c s => FieldInfo (t -> s) -> f s) -- ^ This function should return a value-                -- for each subcomponent of @t@, wrapped in an applicative functor @f@. It is given -                -- information about the field, which contains a projector function to get the subcomponent +                -- for each subcomponent of @t@, wrapped in an applicative functor @f@. It is given+                -- information about the field, which contains a projector function to get the subcomponent                 -- from a value of type @t@. The type of the subcomponent is an instance of class @c@.              -> (FieldInfo (t -> t) -> f t) -- ^ This function should return a value                 -- for each subcomponent of @t@ that is itself of type @t@.-             -> [f t] -- ^ A list of results, one for each constructor of type @t@. Each element is the -             -- result of applicatively applying the constructor to the results of the given function +             -> [f t] -- ^ A list of results, one for each constructor of type @t@. Each element is the+             -- result of applicatively applying the constructor to the results of the given function              -- for each field of the constructor.   buildsRecA for sub _ = buildsA for sub-  -  {-# MINIMAL ctorIndex, (buildsA | buildsRecA) #-} +  {-# MINIMAL ctorInfo, (buildsA | buildsRecA) #-}+ -- | Add an instance for this class if the data type has exactly one constructor. -- --   This class has no methods. class ADT t => ADTRecord t where  -- | `buildsA` specialized to the `Identity` applicative functor.-builds :: (ADT t, Constraints t c) -       => For c -> (forall s. c s => FieldInfo (t -> s) -> s) -> [t]-builds for f = runIdentity <$> buildsA for (Identity . f)  +builds :: (ADT t, Constraints t c)+       => for c -> (forall s. c s => FieldInfo (t -> s) -> s) -> [t]+builds for f = runIdentity <$> buildsA for (Identity . f)  -- | `buildsA` specialized to the `Constant` applicative functor, which collects monoid values @m@.-mbuilds :: forall t c m. (ADT t, Constraints t c, Monoid m) -        => For c -> (forall s. c s => FieldInfo (t -> s) -> m) -> [m]+mbuilds :: forall t c m for. (ADT t, Constraints t c, Monoid m)+        => for c -> (forall s. c s => FieldInfo (t -> s) -> m) -> [m] mbuilds for f = getConstant <$> (buildsA for (Constant . f) :: [Constant m t])  -- | Transform a value by transforming each subcomponent. gmap :: (ADT t, Constraints t c)-     => For c -> (forall s. c s => s -> s) -> t -> t+     => for c -> (forall s. c s => s -> s) -> t -> t gmap for f t = builds for (\fld -> f (t ! fld)) `at` t --- | Fold a value, by mapping each subcomponent to a monoid value and collecting those. +-- | Fold a value, by mapping each subcomponent to a monoid value and collecting those. gfoldMap :: (ADT t, Constraints t c, Monoid m)-         => For c -> (forall s. c s => s -> m) -> t -> m+         => for c -> (forall s. c s => s -> m) -> t -> m gfoldMap for f = getConstant . gtraverse for (Constant . f)  -- | Applicative traversal given a way to traverse each subcomponent.-gtraverse :: (ADT t, Constraints t c, Applicative f) -          => For c -> (forall s. c s => s -> f s) -> t -> f t+gtraverse :: (ADT t, Constraints t c, Applicative f)+          => for c -> (forall s. c s => s -> f s) -> t -> f t gtraverse for f t = buildsA for (\fld -> f (t ! fld)) `at` t  -- | `builds` for data types with exactly one constructor-build :: (ADTRecord t, Constraints t c) -      => For c -> (forall s. c s => FieldInfo (t -> s) -> s) -> t+build :: (ADTRecord t, Constraints t c)+      => for c -> (forall s. c s => FieldInfo (t -> s) -> s) -> t build for f = head $ builds for f  -- | Derive a 0-ary operation by applying the operation to every subcomponent.-op0 :: (ADTRecord t, Constraints t c) => For c -> (forall s. c s => s) -> t+op0 :: (ADTRecord t, Constraints t c) => for c -> (forall s. c s => s) -> t op0 for op = build for (const op)  -- | Derive a unary operation by applying the operation to every subcomponent.-op1 :: (ADTRecord t, Constraints t c) => For c -> (forall s. c s => s -> s) -> t -> t+op1 :: (ADTRecord t, Constraints t c) => for c -> (forall s. c s => s -> s) -> t -> t op1 for op t = build for (\fld -> op $ t ! fld)  -- | Derive a binary operation by applying the operation to every subcomponent.-op2 :: (ADTRecord t, Constraints t c) => For c -> (forall s. c s => s -> s -> s) -> t -> t -> t+op2 :: (ADTRecord t, Constraints t c) => for c -> (forall s. c s => s -> s -> s) -> t -> t -> t op2 for op s t = build for (\fld -> (s ! fld) `op` (t ! fld))  @@ -202,18 +201,18 @@   instance ADT () where-  +   type Constraints () c = ()   ctorInfo _ 0 = ctor "()"-  buildsA For _ = [ pure () ]+  buildsA _ _ = [ pure () ]  instance ADTRecord () where-  + instance ADT (a, b) where-  +   type Constraints (a, b) c = (c a, c b)   ctorInfo _ 0 = ctor "(,)"-  buildsA For f = [ (,) <$> f (FieldInfo fst) <*> f (FieldInfo snd) ]+  buildsA _ f = [ (,) <$> f (FieldInfo fst) <*> f (FieldInfo snd) ]  instance ADTRecord (a, b) where @@ -221,10 +220,10 @@    type Constraints (a, b, c) tc = (tc a, tc b, tc c)   ctorInfo _ 0 = ctor "(,,)"-  buildsA For f = [(,,) <$> f (FieldInfo (\(a, _, _) -> a))-                        <*> f (FieldInfo (\(_, b, _) -> b))-                        <*> f (FieldInfo (\(_, _, c) -> c))-                  ]+  buildsA _ f = [(,,) <$> f (FieldInfo (\(a, _, _) -> a))+                      <*> f (FieldInfo (\(_, b, _) -> b))+                      <*> f (FieldInfo (\(_, _, c) -> c))+                ]  instance ADTRecord (a, b, c) where @@ -232,11 +231,11 @@    type Constraints (a, b, c, d) tc = (tc a, tc b, tc c, tc d)   ctorInfo _ 0 = ctor "(,,,)"-  buildsA For f = [(,,,) <$> f (FieldInfo (\(a, _, _, _) -> a))-                         <*> f (FieldInfo (\(_, b, _, _) -> b))-                         <*> f (FieldInfo (\(_, _, c, _) -> c))-                         <*> f (FieldInfo (\(_, _, _, d) -> d))-                  ]+  buildsA _ f = [(,,,) <$> f (FieldInfo (\(a, _, _, _) -> a))+                       <*> f (FieldInfo (\(_, b, _, _) -> b))+                       <*> f (FieldInfo (\(_, _, c, _) -> c))+                       <*> f (FieldInfo (\(_, _, _, d) -> d))+                ]  instance ADTRecord (a, b, c, d) where @@ -248,7 +247,7 @@   ctorInfo _ 1 = ctor "True"    type Constraints Bool c = ()-  buildsA For _ = [ pure False, pure True ]+  buildsA for _ = [ pure False, pure True ]  instance ADT (Either a b) where @@ -258,11 +257,11 @@   ctorInfo _ 1 = ctor "Right"    type Constraints (Either a b) c = (c a, c b)-  buildsA For f = +  buildsA for f =     [ Left  <$> f (FieldInfo (\(Left a)  -> a))     , Right <$> f (FieldInfo (\(Right a) -> a))     ]-    + instance ADT (Maybe a) where    ctorIndex Nothing = 0@@ -271,7 +270,7 @@   ctorInfo _ 1 = ctor "Just"    type Constraints (Maybe a) c = c a-  buildsA For f = +  buildsA for f =     [ pure Nothing     , Just <$> f (FieldInfo fromJust)     ]@@ -284,7 +283,6 @@   ctorInfo _ 1 = CtorInfo ":" False (Infix RightAssociative 5)    type Constraints [a] c = (c a, c [a])-  buildsRecA For sub rec = +  buildsRecA for sub rec =     [ pure []     , (:) <$> sub (FieldInfo head) <*> rec (FieldInfo tail)]-
src/Generics/OneLiner/ADT1.hs view
@@ -1,17 +1,16 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.OneLiner.ADT1--- Copyright   :  (c) Sjoerd Visscher 2012 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  sjoerd@w3future.com -- Stability   :  experimental -- Portability :  non-portable ----- This module is for writing generic functions on algebraic data types --- of kind @* -> *@. +-- This module is for writing generic functions on algebraic data types+-- of kind @* -> *@. -- These data types must be an instance of the `ADT1` type class.--- +-- -- Here's an example how to write such an instance for this data type: -- -- @@@ -25,13 +24,13 @@ --   `ctorInfo` _ 0 = `ctor` \"A\" --   `ctorInfo` _ 1 = `ctor` \"B\" --   type `Constraints` T c = (c [], c T)---   `buildsRecA` `For` par sub rec = +--   `buildsRecA` _ par sub rec = --     [ A `<$>` sub (`component` (\\(A l) -> l) --     , B `<$>` par (`param` (\\(B a _) -> a)) `<*>` rec (`component` (\\(B _ t) -> t)) --     ] -- @ ------------------------------------------------------------------------------{-# LANGUAGE +{-# LANGUAGE     RankNTypes   , TypeFamilies   , TypeOperators@@ -46,26 +45,26 @@     module Generics.OneLiner.Info   , Constraint     -- | The kind of constraints-  +     -- * The @ADT1@ type class   , ADT1(..)   , ADT1Record(..)   , For(..)   , Extract(..)   , (:~>)(..)-  +     -- * Helper functions   , (!)   , (!~)   , at   , param   , component-  +   -- * Derived traversal schemes   , builds   , mbuilds   , build-  +   ) where  import Generics.OneLiner.Info@@ -90,68 +89,68 @@ -- Where @Show@ can be any class. data For (c :: (* -> *) -> Constraint) = For --- | Type class for algebraic data types of kind @* -> *@. Minimal implementation: `ctorIndex` and either `buildsA`+-- | Type class for algebraic data types of kind @* -> *@. Implement either `buildsA` -- if the type @t@ is not recursive, or `buildsRecA` if the type @t@ is recursive. class ADT1 t where    -- | Gives the index of the constructor of the given value in the list returned by `buildsA` and `buildsRecA`.   ctorIndex :: t a -> Int   ctorIndex _ = 0-  +   -- | @ctorInfo n@ gives constructor information, f.e. its name, for the @n@th constructor.   --   The first argument is a dummy argument and can be @(undefined :: t a)@.   ctorInfo :: t a -> Int -> CtorInfo -  -- | The constraints needed to run `buildsA` and `buildsRecA`. +  -- | The constraints needed to run `buildsA` and `buildsRecA`.   -- It should be a list of all the types of the subcomponents of @t@, each applied to @c@.   type Constraints t (c :: (* -> *) -> Constraint) :: Constraint   buildsA :: (Constraints t c, Applicative f)-          => For c -- ^ Witness for the constraint @c@.+          => for c -- ^ Witness for the constraint @c@.           -> (FieldInfo (Extract t) -> f b)           -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))           -> [f (t b)]-          +   default buildsA :: (c t, Constraints t c, Applicative f)-                  => For c+                  => for c                   -> (FieldInfo (Extract t) -> f b)                   -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))                   -> [f (t b)]-  buildsA for param sub = buildsRecA for param sub sub +  buildsA for param sub = buildsRecA for param sub sub    buildsRecA :: (Constraints t c, Applicative f)-             => For c -- ^ Witness for the constraint @c@.+             => for c -- ^ Witness for the constraint @c@.              -> (FieldInfo (Extract t) -> f b)              -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))              -> (FieldInfo (t :~> t) -> f (t b))              -> [f (t b)]   buildsRecA for param sub _ = buildsA for param sub-  -  {-# MINIMAL ctorIndex, (buildsA | buildsRecA) #-} +  {-# MINIMAL ctorInfo, (buildsA | buildsRecA) #-}+ -- | Add an instance for this class if the data type has exactly one constructor. -- --   This class has no methods. class ADT1 t => ADT1Record t where  -- | `buildsA` specialized to the `Identity` applicative functor.-builds :: (ADT1 t, Constraints t c) -       => For c+builds :: (ADT1 t, Constraints t c)+       => for c        -> (FieldInfo (Extract t) -> b)        -> (forall s. c s => FieldInfo (t :~> s) -> s b)        -> [t b] builds for f g = runIdentity <$> buildsA for (Identity . f) (Identity . g)  -- | `buildsA` specialized to the `Constant` applicative functor, which collects monoid values @m@.-mbuilds :: forall t c m. (ADT1 t, Constraints t c, Monoid m) -        => For c+mbuilds :: forall t c m for. (ADT1 t, Constraints t c, Monoid m)+        => for c         -> (FieldInfo (Extract t) -> m)         -> (forall s. c s => FieldInfo (t :~> s) -> m)         -> [m] mbuilds for f g = getConstant <$> (buildsA for (Constant . f) (Constant . g) :: [Constant m (t b)])  -- | `builds` for data types with exactly one constructor-build :: (ADT1Record t, Constraints t c) -       => For c+build :: (ADT1Record t, Constraints t c)+       => for c        -> (FieldInfo (Extract t) -> b)        -> (forall s. c s => FieldInfo (t :~> s) -> s b)        -> t b@@ -177,27 +176,27 @@   instance ADT1 Maybe where-  +   ctorIndex Nothing = 0   ctorIndex Just{}  = 1   ctorInfo _ 0 = ctor "Nothing"   ctorInfo _ 1 = ctor "Just"-  +   type Constraints Maybe c = ()-  buildsA For f _ = +  buildsA _ f _ =     [ pure Nothing     , Just <$> f (param fromJust)     ]-  + instance ADT1 [] where-  +   ctorIndex []    = 0   ctorIndex (_:_) = 1   ctorInfo _ 0 = ctor "[]"   ctorInfo _ 1 = CtorInfo ":" False (Infix RightAssociative 5)-  +   type Constraints [] c = c []-  buildsRecA For p _ r = +  buildsRecA _ p _ r =     [ pure []     , (:) <$> p (param head) <*> r (component tail)     ]
src/Generics/OneLiner/Functions.hs view
@@ -1,7 +1,6 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.OneLiner.Functions--- Copyright   :  (c) Sjoerd Visscher 2012 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  sjoerd@w3future.com@@ -33,11 +32,11 @@ import qualified Control.Monad.Trans.Class as T  eqADT :: (ADT t, Constraints t Eq) => t -> t -> Bool-eqADT s t = ctorIndex s == ctorIndex t && +eqADT s t = ctorIndex s == ctorIndex t &&   getAll (mbuilds (For :: For Eq) (\fld -> All $ s ! fld == t ! fld) `at` s)  compareADT :: (ADT t, Constraints t Ord) => t -> t -> Ordering-compareADT s t = compare (ctorIndex s) (ctorIndex t) <> +compareADT s t = compare (ctorIndex s) (ctorIndex t) <>   mbuilds (For :: For Ord) (\fld -> compare (s ! fld) (t ! fld)) `at` s  minBoundADT :: (ADT t, Constraints t Bounded) => t@@ -51,18 +50,18 @@   where     CtorInfo name rec fty = ctorInfo t (ctorIndex t) -    inner (Infix _ d') = showParen (d > d') $ let [f0, f1] = fields (d' + 1) in +    inner (Infix _ d') = showParen (d > d') $ let [f0, f1] = fields (d' + 1) in       f0 . showChar ' ' . showString name . showChar ' ' . f1     inner _ = showParen (d > 10) $ showString name . showChar ' ' . body -    body = if rec +    body = if rec       then showChar '{' . conc (showString ", ") (fields 0) . showChar '}'       else conc (showString " ") (fields 11)      fields d' = mbuilds (For :: For Show) (return . f d') `at` t      f :: Show s => Int -> FieldInfo (t -> s) -> ShowS-    f d' info = if rec +    f d' info = if rec       then showString (selectorName info) . showString " = " . showsPrec d' (t ! info)       else showsPrec d' (t ! info) @@ -73,11 +72,11 @@   where     ctorReads = ctorParse <$> zip (fmap (ctorInfo (undefined :: t)) [0..]) (buildsA (For :: For Read) fieldParse) -    ctorParse (CtorInfo name _ (Infix _ d), getFields) = +    ctorParse (CtorInfo name _ (Infix _ d), getFields) =       let flds = evalStateT getFields $ do { Symbol name' <- lexP; guard (name' == name) }       in prec d flds -    ctorParse (CtorInfo name rec _, getFields) = +    ctorParse (CtorInfo name rec _, getFields) =       let flds = evalStateT getFields (return ())       in prec (if rec then 11 else 10) $ do         Ident name' <- lexP@@ -98,7 +97,7 @@       Punc "=" <- lexP       res <- reset readPrec       parseOp-      return (res, return ())  +      return (res, return ())     fieldParse _ = StateT $ \parseOp -> do       res <- step readPrec       parseOp
src/Generics/OneLiner/Functions1.hs view
@@ -1,7 +1,6 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.OneLiner.Functions1--- Copyright   :  (c) Sjoerd Visscher 2013 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  sjoerd@w3future.com
src/Generics/OneLiner/Info.hs view
@@ -1,7 +1,6 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.OneLiner.Info--- Copyright   :  (c) Sjoerd Visscher 2012 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  sjoerd@w3future.com@@ -26,11 +25,15 @@ data Associativity = LeftAssociative | RightAssociative | NotAssociative   deriving (Eq, Show, Ord, Read) -data FieldInfo p +data FieldInfo p   = SelectorInfo     { selectorName :: String     , project      :: p     }   | FieldInfo-    { project      :: p +    { project      :: p     }++instance Functor FieldInfo where+  fmap f (SelectorInfo s p) = SelectorInfo s (f p)+  fmap f (FieldInfo p) = FieldInfo (f p)