packages feed

one-liner (empty) → 0

raw patch · 9 files changed

+734/−0 lines, 9 filesdep +basedep +ghc-primdep +transformerssetup-changed

Dependencies added: base, ghc-prim, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Sjoerd Visscher++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 Sjoerd Visscher 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/defaultsignature.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies, DefaultSignatures, ConstraintKinds, TypeOperators #-}++import Generics.OneLiner.ADT+import Generics.OneLiner.Functions++import Data.Monoid+import Control.Applicative++import Text.Read (readPrec)+++class Size t where+  +  size :: t -> Int+  +  default size :: (ADT t, Constraints t Size) => t -> Int+  size = succ . getSum . gfoldMap (For :: For Size) (Sum . size)+  +instance Size Bool+instance Size a => Size (Maybe a)+++class EnumAll t where+  +  enumAll :: [t]+  +  default enumAll :: (ADT t, Constraints t EnumAll) => [t]+  enumAll = concatMap snd $ buildsA (For :: For EnumAll) (const enumAll)++instance EnumAll Bool+instance EnumAll a => EnumAll (Maybe a)+++infixr 5 :^:+data Tree a = Leaf { value :: a } | Tree a :^: Tree a++instance ADT (Tree a) where+  +  ctorIndex Leaf{}  = 0+  ctorIndex (_:^:_) = 1+  +  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)))+    ]++instance Show a => Show (Tree a) where showsPrec = showsPrecADT+instance Read a => Read (Tree a) where readPrec = readPrecADT+instance Size a => Size (Tree a)+instance EnumAll a => EnumAll (Tree a)++trees :: [Tree (Maybe Bool)]+trees = enumAll++sizes :: [Int]+sizes = map size trees
+ examples/paradise.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE +    TypeFamilies+  , ConstraintKinds+  , FlexibleInstances+  , DefaultSignatures+  , OverlappingInstances+  , TypeSynonymInstances+  #-}++import Generics.OneLiner.ADT+import Control.Applicative+++data Company  = C [Dept]               deriving (Eq, Read, Show)               +data Dept     = D Name Manager [Unit]  deriving (Eq, Read, Show)+data Unit     = PU Employee | DU Dept  deriving (Eq, Read, Show)+data Employee = E Person Salary        deriving (Eq, Read, Show)+data Person   = P Name Address         deriving (Eq, Read, Show)+data Salary   = S Float                deriving (Eq, Read, Show)                  +type Manager  = Employee +type Name     = String+type Address  = String++-- An illustrative company+genCom :: Company+genCom = C [D "Research" laemmel [PU joost, PU marlow],+            D "Strategy" blair   []]++laemmel, joost, marlow, blair :: Employee+laemmel = E (P "Laemmel" "Amsterdam") (S 8000)+joost   = E (P "Joost"   "Amsterdam") (S 1000)+marlow  = E (P "Marlow"  "Cambridge") (S 2000)+blair   = E (P "Blair"   "London")    (S 100000)+++instance ADT Company where+  type Constraints Company c = c [Dept]+  buildsA For f = [(ctor "C", 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 +    <$> f (FieldInfo $ \(D n _ _) -> n) +    <*> f (FieldInfo $ \(D _ m _) -> m) +    <*> f (FieldInfo $ \(D _ _ u) -> u))]++instance ADT Unit where+  ctorIndex PU{} = 0+  ctorIndex DU{} = 1+  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))+    ]++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))]++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))]++instance ADT Salary where+  type Constraints Salary c = (c Float)+  buildsA For f = [(ctor "S", S <$> f (FieldInfo $ \(S s) -> s))]++  +class IncreaseSalary t where+  increaseSalary :: Float -> t -> t+  default increaseSalary :: (ADT t, Constraints t IncreaseSalary) => Float -> t -> t+  increaseSalary k = gmap (For :: For IncreaseSalary) (increaseSalary k)++instance IncreaseSalary Company+instance IncreaseSalary Dept+instance IncreaseSalary Unit+instance IncreaseSalary Employee+instance IncreaseSalary Person+instance IncreaseSalary Salary where+  increaseSalary k (S s) = S (s * (1+k))+instance IncreaseSalary a => IncreaseSalary [a]+instance IncreaseSalary String where+  increaseSalary _ = id+  +main :: IO ()+main = print $ increaseSalary 0.1 genCom
+ one-liner.cabal view
@@ -0,0 +1,34 @@+Name:                 one-liner+Version:              0+Synopsis:             Constraint-based generics+Description:          Write short and concise generic instances of type classes.+Homepage:             https://github.com/sjoerdvisscher/one-liner+Bug-reports:          https://github.com/sjoerdvisscher/one-liner/issues+License:              BSD3+License-file:         LICENSE+Author:               Sjoerd Visscher+Maintainer:           sjoerd@w3future.com+Category:             Generics+Build-type:           Simple+Cabal-version:        >= 1.6++Extra-Source-Files:+  examples/*.hs++Library+  HS-Source-Dirs:  src+  +  Exposed-modules:+    Generics.OneLiner.ADT+    Generics.OneLiner.ADT1+    Generics.OneLiner.Functions+    Generics.OneLiner.Info+  +  Build-depends:+      base         >= 4.5 && < 5 +    , transformers >= 0.3 && < 0.4+    , ghc-prim++source-repository head+  type:     git+  location: git://github.com/sjoerdvisscher/one-liner.git
+ src/Generics/OneLiner/ADT.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- |+-- 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 +-- 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:+--+-- @+-- data T a = A Int a | B a (T a)+-- @+--+-- @+-- instance `ADT` (T a) where+--   `ctorIndex` A{} = 0+--   `ctorIndex` B{} = 1+--   type `Constraints` (T a) c = (c Int, c a, c (T a))+--   `buildsRecA` `For` sub rec = +--     [ (`ctor` \"A\", A `<$>` sub (`FieldInfo` (\\(A i _) -> i)) `<*>` sub (`FieldInfo` (\\(A _ a) -> a)))+--     , (`ctor` \"B\", B `<$>` sub (`FieldInfo` (\\(B a _) -> a)) `<*>` rec (`FieldInfo` (\\(B _ t) -> t)))+--     ]+-- @+--+-- And this is how you would write generic equality, using the `All` monoid:+--+-- @+-- eqADT :: (`ADT` t, `Constraints` t `Eq`) => t -> t -> `Bool`+-- eqADT s t = `ctorIndex` s == `ctorIndex` t `&&` +--   `getAll` (`mbuilds` (`For` :: `For` `Eq`) (\\fld -> `All` $ s `!` fld `==` t `!` fld) \``at`\` s)+-- @+-----------------------------------------------------------------------------+{-# LANGUAGE +    RankNTypes+  , TypeFamilies+  , ConstraintKinds+  , FlexibleInstances+  , DefaultSignatures+  , ScopedTypeVariables+  #-}+module Generics.OneLiner.ADT (+  +    -- * Re-exports+    module Generics.OneLiner.Info+  , Constraint+    -- | The kind of constraints+    +    -- * The @ADT@ type class+  , ADT(..)+  , For(..)++    -- * Helper functions+  , (!)+  , at+  +    -- * Derived traversal schemes+  , builds+  , mbuilds+  , gmap+  , gfoldMap+  , gtraverse+  +  ) where+  +import Generics.OneLiner.Info++import GHC.Prim (Constraint)+import Control.Applicative+import Data.Functor.Identity+import Data.Functor.Constant+import Data.Monoid++import Data.Maybe (fromJust)+++-- | 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++-- | Type class for algebraic data types of kind @*@. Minimal implementation: `ctorIndex` and 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++  -- | 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+  +  buildsA :: (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 +             -- 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.+  +  default buildsA :: (c t, Constraints t c, Applicative f) +                  => For c -> (forall s. c s => FieldInfo (t -> s) -> f s) -> [(CtorInfo, f t)]  +  buildsA for f = buildsRecA for f f+  +  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 +                -- 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.+  buildsRecA for sub _ = buildsA for sub++-- | `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)  ++-- | `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)++-- | 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++-- | 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+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 for f t = buildsA for (\info -> f (t ! info)) `at` t+++infixl 9 !+-- | Get the subcomponent by using the projector from the field information.+(!) :: t -> FieldInfo (t -> s) -> s+t ! info = project info 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)++++instance ADT () where+  +  type Constraints () c = ()+  buildsA For _ = [ (ctor "()", pure ()) ]+  +instance ADT Bool where++  ctorIndex False = 0+  ctorIndex True  = 1++  type Constraints Bool c = ()+  buildsA For _ = +    [ (ctor "False", pure False)+    , (ctor "True",  pure True) ]++instance ADT (Either a b) where++  ctorIndex Left{}  = 0+  ctorIndex Right{} = 1++  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)))+    ]++instance ADT (Maybe a) where++  ctorIndex Nothing = 0+  ctorIndex Just{}  = 1++  type Constraints (Maybe a) c = c a+  buildsA For f = +    [ (ctor "Nothing", pure Nothing)+    , (ctor "Just", Just <$> f (FieldInfo fromJust))+    ]++instance ADT [a] where++  ctorIndex []    = 0+  ctorIndex (_:_) = 1++  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))]+
+ src/Generics/OneLiner/ADT1.hs view
@@ -0,0 +1,179 @@+-----------------------------------------------------------------------------+-- |+-- 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 @* -> *@. +-- 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:+--+-- @+-- data T a = A [a] | B a (T a)+-- @+--+-- @+-- instance `ADT1` T where+--   `ctorIndex` A{} = 0+--   `ctorIndex` B{} = 1+--   type `Constraints` T c = (c [], c T)+--   `buildsRecA` `For` par sub rec = +--     [ (`ctor` \"A\", A `<$>` sub (`component` (\\(A l) -> l))+--     , (`ctor` \"B\", B `<$>` par (`param` (\\(B a _) -> a)) `<*>` rec (`component` (\\(B _ t) -> t)))+--     ]+-- @+-----------------------------------------------------------------------------+{-# LANGUAGE +    RankNTypes+  , TypeFamilies+  , TypeOperators+  , ConstraintKinds+  , FlexibleInstances+  , DefaultSignatures+  , ScopedTypeVariables+  #-}+module Generics.OneLiner.ADT1 (++    -- * Re-exports+    module Generics.OneLiner.Info+  , Constraint+    -- | The kind of constraints+  +    -- * The @ADT1@ type class+  , ADT1(..)+  , For(..)+  , Extract(..)+  , (:~>)(..)+  +    -- * Helper functions+  , (!)+  , (!~)+  , at+  , param+  , component+  +  -- * Derived traversal schemes+  , builds+  , mbuilds+  +  ) where++import Generics.OneLiner.Info++import GHC.Prim (Constraint)+import Control.Applicative+import Data.Functor.Identity+import Data.Functor.Constant+import Data.Monoid++import Data.Maybe (fromJust)+++newtype f :~> g = Nat { getNat :: forall x. f x -> g x }+newtype Extract f = Extract { getExtract :: forall x. f x -> x }+++-- | 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++-- | Type class for algebraic data types of kind @* -> *@. Minimal implementation: `ctorIndex` and 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++  -- | 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+  buildsA :: (Constraints t c, Applicative f)+          => 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))]+          +  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))]+  buildsA for param sub = buildsRecA for param sub sub ++  buildsRecA :: (Constraints t c, Applicative f)+             => 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))+             -> [(CtorInfo, f (t b))]+  buildsRecA for param sub _ = buildsA for param sub++-- | `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)++-- | `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)++-- | 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)++param :: (forall a. t a -> a) -> FieldInfo (Extract t)+param f = FieldInfo (Extract f)++component :: (forall a. t a -> s a) -> FieldInfo (t :~> s)+component f = FieldInfo (Nat f)++infixl 9 !+(!) :: t a -> FieldInfo (Extract t) -> a+t ! info = getExtract (project info) t++infixl 9 !~+(!~) :: t a -> FieldInfo (t :~> s) -> s a+t !~ info = getNat (project info) t+++instance ADT1 Maybe where+  +  ctorIndex Nothing = 0+  ctorIndex Just{}  = 1+  +  type Constraints Maybe c = ()+  buildsA For f _ = +    [ (ctor "Nothing", pure Nothing)+    , (ctor "Just", Just <$> f (param fromJust))+    ]+  +instance ADT1 [] where+  +  ctorIndex [] = 0+  ctorIndex (_:_) = 1 +  +  type Constraints [] c = c []+  buildsRecA For p _ r = +    [ (ctor "[]", pure [])+    , (CtorInfo ":" False (Infix RightAssociative 5), (:) <$> p (param head) <*> r (component tail))+    ]
+ src/Generics/OneLiner/Functions.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.OneLiner.Functions+-- Copyright   :  (c) Sjoerd Visscher 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+-----------------------------------------------------------------------------+{-# LANGUAGE RankNTypes, ConstraintKinds, ScopedTypeVariables #-}+module Generics.OneLiner.Functions where++import Generics.OneLiner.ADT+import Control.Applicative+import Data.Monoid++import Text.Read+import Control.Monad+import Control.Monad.Trans.State+import qualified Control.Monad.Trans.Class as T++eqADT :: (ADT t, Constraints t Eq) => t -> t -> Bool+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) <> +  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)++maxBoundADT :: (ADT t, Constraints t Bounded) => t+maxBoundADT = snd $ 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++    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 +      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 +      then showString (selectorName info) . showString " = " . showsPrec d' (t ! info)+      else showsPrec d' (t ! info)++    conc sep = foldr1 (\g ss -> g . sep . ss)++readPrecADT :: forall t. (ADT t, Constraints t Read) => ReadPrec t+readPrecADT = parens (choice ctorReads)+  where+    ctorReads = ctorParse <$> buildsA (For :: For Read) fieldParse++    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) = +      let flds = evalStateT getFields (return ())+      in prec (if rec then 11 else 10) $ do+        Ident name' <- lexP+        guard (name == name')+        if rec then do+            Punc "{" <- lexP+            res <- flds+            Punc "}" <- lexP+            return res+          else+            flds++    -- StateT is used to parse an infix operator after the first field+    fieldParse :: Read s => FieldInfo (t -> s) -> StateT (ReadPrec ()) ReadPrec s+    fieldParse (SelectorInfo name _) = StateT $ \parseOp -> do+      Ident name' <- lexP+      guard (name == name')+      Punc "=" <- lexP+      res <- reset readPrec+      parseOp+      return (res, return ())  +    fieldParse _ = StateT $ \parseOp -> do+      res <- step readPrec+      parseOp+      return (res, return ())
+ src/Generics/OneLiner/Info.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.OneLiner.Info+-- Copyright   :  (c) Sjoerd Visscher 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+-----------------------------------------------------------------------------+module Generics.OneLiner.Info where++data CtorInfo = CtorInfo+  { ctorName  :: String+  , isRecord  :: Bool+  , fixity    :: Fixity+  }+  deriving (Eq, Show, Ord, Read)++ctor :: String -> CtorInfo+ctor name = CtorInfo name False Prefix++data Fixity = Prefix | Infix Associativity Int+  deriving (Eq, Show, Ord, Read)++data Associativity = LeftAssociative | RightAssociative | NotAssociative+  deriving (Eq, Show, Ord, Read)++data FieldInfo p +  = SelectorInfo+    { selectorName :: String+    , project      :: p+    }+  | FieldInfo+    { project      :: p +    }