packages feed

one-liner 0.1 → 0.2

raw patch · 7 files changed

+240/−67 lines, 7 files

Files

examples/defaultsignature.hs view
@@ -25,7 +25,7 @@   enumAll :: [t]      default enumAll :: (ADT t, Constraints t EnumAll) => [t]-  enumAll = concatMap snd $ buildsA (For :: For EnumAll) (const enumAll)+  enumAll = concat $ buildsA (For :: For EnumAll) (const enumAll)  instance EnumAll Bool instance EnumAll a => EnumAll (Maybe a)@@ -38,13 +38,13 @@      ctorIndex Leaf{}  = 0   ctorIndex (_:^:_) = 1+  ctorInfo _ 0 = CtorInfo "Leaf" True Prefix+  ctorInfo _ 1 = CtorInfo ":^:"  False (Infix RightAssociative 5)      type Constraints (Tree a) c = (c a, c (Tree a))   buildsRecA For sub rec = -    [ (CtorInfo "Leaf" True Prefix, -         Leaf <$> sub (SelectorInfo "value" value))-    , (CtorInfo ":^:"  False (Infix RightAssociative 5),-        (:^:) <$> rec (FieldInfo (\(l :^: _) -> l)) <*> rec (FieldInfo (\(_ :^: r) -> r)))+    [ Leaf <$> sub (SelectorInfo "value" value)+    , (:^:) <$> rec (FieldInfo (\(l :^: _) -> l)) <*> rec (FieldInfo (\(_ :^: r) -> r))     ]  instance Show a => Show (Tree a) where showsPrec = showsPrecADT
examples/paradise.hs view
@@ -35,35 +35,42 @@  instance ADT Company where   type Constraints Company c = c [Dept]-  buildsA For f = [(ctor "C", C <$> f (FieldInfo $ \(C l) -> l))]+  ctorInfo _ 0 = ctor "C"+  buildsA For f = [C <$> f (FieldInfo $ \(C l) -> l)]  instance ADT Dept where   type Constraints Dept c = (c Name, c Manager, c [Unit])-  buildsA For f = [(ctor "D", D +  ctorInfo _ 0 = ctor "D"+  buildsA For f = [D      <$> f (FieldInfo $ \(D n _ _) -> n)      <*> f (FieldInfo $ \(D _ m _) -> m) -    <*> f (FieldInfo $ \(D _ _ u) -> u))]+    <*> f (FieldInfo $ \(D _ _ u) -> u)]  instance ADT Unit where   ctorIndex PU{} = 0   ctorIndex DU{} = 1+  ctorInfo _ 0 = ctor "PU"+  ctorInfo _ 1 = ctor "DU"   type Constraints Unit c = (c Employee, c Dept)   buildsA For f = -    [ (ctor "PU", PU <$> f (FieldInfo $ \(PU e) -> e))-    , (ctor "DU", DU <$> f (FieldInfo $ \(DU d) -> d))+    [ PU <$> f (FieldInfo $ \(PU e) -> e)+    , DU <$> f (FieldInfo $ \(DU d) -> d)     ]  instance ADT Employee where   type Constraints Employee c = (c Person, c Salary)-  buildsA For f = [(ctor "E", E <$> f (FieldInfo $ \(E p _) -> p) <*> f (FieldInfo $ \(E _ s) -> s))]+  ctorInfo _ 0 = ctor "E"+  buildsA For f = [E <$> f (FieldInfo $ \(E p _) -> p) <*> f (FieldInfo $ \(E _ s) -> s)]  instance ADT Person where   type Constraints Person c = (c Name, c Address)-  buildsA For f = [(ctor "P", P <$> f (FieldInfo $ \(P n _) -> n) <*> f (FieldInfo $ \(P _ a) -> a))]+  ctorInfo _ 0 = ctor "P"+  buildsA For f = [P <$> f (FieldInfo $ \(P n _) -> n) <*> f (FieldInfo $ \(P _ a) -> a)]  instance ADT Salary where   type Constraints Salary c = (c Float)-  buildsA For f = [(ctor "S", S <$> f (FieldInfo $ \(S s) -> s))]+  ctorInfo _ 0 = ctor "S"+  buildsA For f = [S <$> f (FieldInfo $ \(S s) -> s)]     class IncreaseSalary t where
one-liner.cabal view
@@ -1,5 +1,5 @@ Name:                 one-liner-Version:              0.1+Version:              0.2 Synopsis:             Constraint-based generics Description:          Write short and concise generic instances of type classes. Homepage:             https://github.com/sjoerdvisscher/one-liner@@ -22,6 +22,7 @@     Generics.OneLiner.ADT     Generics.OneLiner.ADT1     Generics.OneLiner.Functions+    Generics.OneLiner.Functions1     Generics.OneLiner.Info      Build-depends:
src/Generics/OneLiner/ADT.hs view
@@ -53,6 +53,7 @@          -- * The @ADT@ type class   , ADT(..)+  , ADTRecord(..)   , For(..)      -- * Helper functions@@ -65,6 +66,12 @@   , gmap   , gfoldMap   , gtraverse++    -- ** ...for single constructor data types+  , build+  , op0+  , op1+  , op2      ) where   @@ -93,6 +100,10 @@   -- | 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`.    -- It should be a list of all the types of the subcomponents of @t@, each applied to @c@.@@ -104,12 +115,12 @@              -- 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@.-          -> [(CtorInfo, f t)] -- ^ A list of pairs, one for each constructor of type @t@. Each pair-             -- consists of information about the constructor and the result of applicatively applying -             -- the constructor to the results of the given function for each field of the constructor.+          -> [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) -> [(CtorInfo, f t)]  +                  => 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) @@ -120,28 +131,30 @@                 -- 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@.-             -> [(CtorInfo, f t)] -- ^ A list of pairs, one for each constructor of type @t@. Each pair-                -- consists of information about the constructor and the result of applicatively applying -                -- the constructor to the results of the given functions for each field of the constructor.+             -> [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 +-- | 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) -> [(CtorInfo, t)]-builds for f = fmap runIdentity <$> buildsA for (Identity . f)  +       => 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) -> [(CtorInfo, m)]-mbuilds for f = fmap getConstant <$> ms-  where-    ms :: [(CtorInfo, Constant m t)]-    ms = buildsA for (Constant . f)+        => 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-gmap for f t = builds for (\info -> f (t ! info)) `at` 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.  gfoldMap :: (ADT t, Constraints t c, Monoid m)@@ -151,65 +164,122 @@ -- | 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 for f t = buildsA for (\info -> f (t ! info)) `at` 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 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 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 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 for op s t = build for (\fld -> (s ! fld) `op` (t ! fld))+++ infixl 9 ! -- | Get the subcomponent by using the projector from the field information. (!) :: t -> FieldInfo (t -> s) -> s-t ! info = project info t+t ! fld = project fld t  -- | Get the value from the result of one of the @builds@ functions that matches the constructor of @t@.-at :: ADT t => [(a, b)] -> t -> b-at ab t = snd (ab !! ctorIndex t)+at :: ADT t => [a] -> t -> a+at as t = as !! ctorIndex t    instance ADT () where      type Constraints () c = ()-  buildsA For _ = [ (ctor "()", pure ()) ]+  ctorInfo _ 0 = ctor "()"+  buildsA For _ = [ 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) ]++instance ADTRecord (a, b) where++instance ADT (a, b, c) where++  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))+                  ]++instance ADTRecord (a, b, c) where++instance ADT (a, b, c, d) where++  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))+                  ]++instance ADTRecord (a, b, c, d) where+ instance ADT Bool where    ctorIndex False = 0   ctorIndex True  = 1+  ctorInfo _ 0 = ctor "False"+  ctorInfo _ 1 = ctor "True"    type Constraints Bool c = ()-  buildsA For _ = -    [ (ctor "False", pure False)-    , (ctor "True",  pure True) ]+  buildsA For _ = [ pure False, pure True ]  instance ADT (Either a b) where    ctorIndex Left{}  = 0   ctorIndex Right{} = 1+  ctorInfo _ 0 = ctor "Left"+  ctorInfo _ 1 = ctor "Right"    type Constraints (Either a b) c = (c a, c b)   buildsA For f = -    [ (ctor "Left",  Left  <$> f (FieldInfo (\(Left a)  -> a)))-    , (ctor "Right", Right <$> f (FieldInfo (\(Right a) -> a)))+    [ Left  <$> f (FieldInfo (\(Left a)  -> a))+    , Right <$> f (FieldInfo (\(Right a) -> a))     ]  instance ADT (Maybe a) where    ctorIndex Nothing = 0   ctorIndex Just{}  = 1+  ctorInfo _ 0 = ctor "Nothing"+  ctorInfo _ 1 = ctor "Just"    type Constraints (Maybe a) c = c a   buildsA For f = -    [ (ctor "Nothing", pure Nothing)-    , (ctor "Just", Just <$> f (FieldInfo fromJust))+    [ pure Nothing+    , Just <$> f (FieldInfo fromJust)     ]  instance ADT [a] where    ctorIndex []    = 0   ctorIndex (_:_) = 1+  ctorInfo _ 0 = ctor "[]"+  ctorInfo _ 1 = CtorInfo ":" False (Infix RightAssociative 5)    type Constraints [a] c = (c a, c [a])   buildsRecA For sub rec = -    [ (ctor "[]", pure [])-    , (CtorInfo ":" False (Infix RightAssociative 5)-      ,(:) <$> sub (FieldInfo head) <*> rec (FieldInfo tail))]+    [ pure []+    , (:) <$> sub (FieldInfo head) <*> rec (FieldInfo tail)]
src/Generics/OneLiner/ADT1.hs view
@@ -47,6 +47,7 @@        -- * The @ADT1@ type class   , ADT1(..)+  , ADT1Record(..)   , For(..)   , Extract(..)   , (:~>)(..)@@ -61,6 +62,7 @@   -- * Derived traversal schemes   , builds   , mbuilds+  , build      ) where @@ -93,6 +95,10 @@   -- | 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`.    -- It should be a list of all the types of the subcomponents of @t@, each applied to @c@.@@ -101,13 +107,13 @@           => For c -- ^ Witness for the constraint @c@.           -> (FieldInfo (Extract t) -> f b)           -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))-          -> [(CtorInfo, f (t b))]+          -> [f (t b)]              default buildsA :: (c t, Constraints t c, Applicative f)                   => For c                   -> (FieldInfo (Extract t) -> f b)                   -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))-                  -> [(CtorInfo, f (t b))]+                  -> [f (t b)]   buildsA for param sub = buildsRecA for param sub sub     buildsRecA :: (Constraints t c, Applicative f)@@ -115,31 +121,41 @@              -> (FieldInfo (Extract t) -> f b)              -> (forall s. c s => FieldInfo (t :~> s) -> f (s b))              -> (FieldInfo (t :~> t) -> f (t b))-             -> [(CtorInfo, f (t b))]+             -> [f (t b)]   buildsRecA for param sub _ = buildsA for param sub +-- | 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        -> (FieldInfo (Extract t) -> b)        -> (forall s. c s => FieldInfo (t :~> s) -> s b)-       -> [(CtorInfo, t b)]-builds for f g = fmap runIdentity <$> buildsA for (Identity . f) (Identity . g)+       -> [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         -> (FieldInfo (Extract t) -> m)         -> (forall s. c s => FieldInfo (t :~> s) -> m)-        -> [(CtorInfo, m)]-mbuilds for f g = fmap getConstant <$> ms-  where-    ms :: [(CtorInfo, Constant m (t b))]-    ms = buildsA for (Constant . f) (Constant . g)+        -> [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+       -> (FieldInfo (Extract t) -> b)+       -> (forall s. c s => FieldInfo (t :~> s) -> s b)+       -> t b+build for f g = head $ builds for f g+ -- | Get the value from the result of one of the @builds@ functions that matches the constructor of @t@.-at :: ADT1 t => [(c, a)] -> t b -> a-at as t = snd (as !! ctorIndex t)+at :: ADT1 t => [a] -> t b -> a+at as t = as !! ctorIndex t  param :: (forall a. t a -> a) -> FieldInfo (Extract t) param f = FieldInfo (Extract f)@@ -160,20 +176,24 @@      ctorIndex Nothing = 0   ctorIndex Just{}  = 1+  ctorInfo _ 0 = ctor "Nothing"+  ctorInfo _ 1 = ctor "Just"      type Constraints Maybe c = ()   buildsA For f _ = -    [ (ctor "Nothing", pure Nothing)-    , (ctor "Just", Just <$> f (param fromJust))+    [ pure Nothing+    , Just <$> f (param fromJust)     ]    instance ADT1 [] where   -  ctorIndex [] = 0-  ctorIndex (_:_) = 1 +  ctorIndex []    = 0+  ctorIndex (_:_) = 1+  ctorInfo _ 0 = ctor "[]"+  ctorInfo _ 1 = CtorInfo ":" False (Infix RightAssociative 5)      type Constraints [] c = c []   buildsRecA For p _ r = -    [ (ctor "[]", pure [])-    , (CtorInfo ":" False (Infix RightAssociative 5), (:) <$> p (param head) <*> r (component tail))+    [ pure []+    , (:) <$> p (param head) <*> r (component tail)     ]
src/Generics/OneLiner/Functions.hs view
@@ -9,7 +9,19 @@ -- Portability :  non-portable ----------------------------------------------------------------------------- {-# LANGUAGE RankNTypes, ConstraintKinds, ScopedTypeVariables #-}-module Generics.OneLiner.Functions where+module Generics.OneLiner.Functions (+  -- * For all instances+    eqADT+  , compareADT+  , minBoundADT+  , maxBoundADT+  , showsPrecADT+  , readPrecADT+  -- * For datatypes with one constructor+  , memptyADT+  , mappendADT+  , fromIntegerADT+  ) where  import Generics.OneLiner.ADT import Control.Applicative@@ -29,15 +41,15 @@   mbuilds (For :: For Ord) (\fld -> compare (s ! fld) (t ! fld)) `at` s  minBoundADT :: (ADT t, Constraints t Bounded) => t-minBoundADT = snd $ head $ builds (For :: For Bounded) (const minBound)+minBoundADT = head $ builds (For :: For Bounded) (const minBound)  maxBoundADT :: (ADT t, Constraints t Bounded) => t-maxBoundADT = snd $ last $ builds (For :: For Bounded) (const maxBound)+maxBoundADT = last $ builds (For :: For Bounded) (const maxBound)  showsPrecADT :: forall t. (ADT t, Constraints t Show) => Int -> t -> ShowS showsPrecADT d t = inner fty   where-    CtorInfo name rec fty = fst $ builds (For :: For Show) (t !) !! ctorIndex t+    CtorInfo name rec fty = ctorInfo t (ctorIndex t)      inner (Infix _ d') = showParen (d > d') $ let [f0, f1] = fields (d' + 1) in        f0 . showChar ' ' . showString name . showChar ' ' . f1@@ -59,7 +71,7 @@ readPrecADT :: forall t. (ADT t, Constraints t Read) => ReadPrec t readPrecADT = parens (choice ctorReads)   where-    ctorReads = ctorParse <$> buildsA (For :: For Read) fieldParse+    ctorReads = ctorParse <$> zip (fmap (ctorInfo (undefined :: t)) [0..]) (buildsA (For :: For Read) fieldParse)      ctorParse (CtorInfo name _ (Infix _ d), getFields) =        let flds = evalStateT getFields $ do { Symbol name' <- lexP; guard (name' == name) }@@ -91,3 +103,13 @@       res <- step readPrec       parseOp       return (res, return ())+++memptyADT :: (ADTRecord t, Constraints t Monoid) => t+memptyADT = op0 (For :: For Monoid) mempty++mappendADT :: (ADTRecord t, Constraints t Monoid) => t -> t -> t+mappendADT = op2 (For :: For Monoid) mappend++fromIntegerADT :: (ADTRecord t, Constraints t Num) => Integer -> t+fromIntegerADT i = op0 (For :: For Num) (fromInteger i)
+ src/Generics/OneLiner/Functions1.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.OneLiner.Functions1+-- Copyright   :  (c) Sjoerd Visscher 2013+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+-----------------------------------------------------------------------------+{-# LANGUAGE RankNTypes, ConstraintKinds, ScopedTypeVariables #-}+module Generics.OneLiner.Functions1 (+  -- * For all instances+    fmapADT+  , foldMapADT+  , traverseADT+  -- * For datatypes with one constructor+  , pureADT+  , apADT+  , bindADT+  , mfixADT+) where++import Generics.OneLiner.ADT1+import Control.Applicative+import Control.Monad.Fix+import Data.Monoid+import Data.Foldable+import Data.Traversable++fmapADT :: (ADT1 t, Constraints t Functor) => (a -> b) -> t a -> t b+fmapADT f ta = builds (For :: For Functor) (\fld -> f (ta ! fld)) (\fld -> fmap f (ta !~ fld)) `at` ta++foldMapADT :: (ADT1 t, Constraints t Foldable, Monoid m) => (a -> m) -> t a -> m+foldMapADT f ta = mbuilds (For :: For Foldable) (\fld -> f (ta ! fld)) (\fld -> foldMap f (ta !~ fld)) `at` ta++traverseADT :: (ADT1 t, Constraints t Traversable, Applicative f) => (a -> f b) -> t a -> f (t b)+traverseADT f ta = buildsA (For :: For Traversable) (\fld -> f (ta ! fld)) (\fld -> traverse f (ta !~ fld)) `at` ta++-- unfoldADT :: (ADT1 t, Constraints t Unfoldable, Unfolder f) => f a -> f (t a)+-- unfoldADT fa = choose $ buildsA (For :: For Unfoldable) (const fa) (const $ unfold fa)++pureADT :: (ADT1Record t, Constraints t Applicative) => a -> t a+pureADT a = build (For :: For Applicative) (const a) (const $ pure a)++apADT :: (ADT1Record t, Constraints t Applicative) => t (a -> b) -> t a -> t b+apADT tf ta = build (For :: For Applicative) (\fld -> (tf ! fld) (ta ! fld)) (\fld -> (tf !~ fld) <*> (ta !~ fld))++bindADT :: (ADT1Record t, Constraints t Monad) => t a -> (a -> t b) -> t b+bindADT ta f = build (For :: For Monad) (\fld -> f (ta ! fld) ! fld) (\fld -> (ta !~ fld) >>= ((!~ fld) . f))++mfixADT :: (ADT1Record t, Constraints t MonadFix) => (a -> t a) -> t a+mfixADT f = build (For :: For MonadFix) (\fld -> fix ((! fld) . f)) (\fld -> mfix ((!~ fld) . f))