diff --git a/Data/Record/Field.hs b/Data/Record/Field.hs new file mode 100644 --- /dev/null +++ b/Data/Record/Field.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +-- | Using records, especially nested records, in Haskell can sometimes be +-- a bit of a chore. Fortunately, there are several libraries in hackage +-- to make working with records easier. This library is my attempt to +-- build on top of these libraries to make working with records even +-- more pleasant! +-- +-- In most imperative languages, records are accessed using the infix +-- dot operator. Record fields can be read simply by suffixing a record +-- value with '.field' and they can be modified by simply assigning to +-- that location. Although this is not the only way to access records +-- (indeed, Haskell does not use it), many people (including myself) +-- like it. This library attempts to support this style for Haskell +-- records in the following manner: +-- +-- > record.field.subfield becomes record .# field # subfield +-- > record.field = value becomes record .# field =: value +-- +-- Of course, the infix assignment in Haskell is pure and doesn't +-- actually mutate anything. Rather, a modified version of the record is +-- returned. +-- +-- Below, a detailed and commented usage example is presented. +-- +-- > import Data.Record.Field +-- > import Data.Record.Label hiding ((=:)) +-- +-- Currently, @"fields"@ is built on top of @"fclabels"@, so we import +-- that package as well. We hide the @(=:)@ operator because that +-- operator is also used by @"fields"@ itself. +-- +-- First, let's define some example data types and derive lenses for +-- them using @"fclabels"@. +-- +-- > data Person = Person +-- > { _firstName :: String +-- > , _lastName :: String +-- > , _age :: Int +-- > , _superior :: Maybe Person +-- > } deriving Show +-- > +-- > data Book = Book +-- > { _title :: String +-- > , _author :: Person +-- > , _characters :: [Person] +-- > } deriving Show +-- > +-- > $(mkLabels [''Person, ''Book]) +-- +-- Now, let's define some example data. +-- +-- > howard = Person "Howard" "Lovecraft" 46 Nothing +-- > charles = Person "Charles" "Ward" 26 Nothing +-- > marinus = Person "Marinus" "Willett" 56 Nothing +-- > william = Person "William" "Dyer" 53 Nothing +-- > frank = Person "Frank" "Pabodie" 49 Nothing +-- > herbert = Person "Herbert" "West" 32 Nothing +-- > abdul = Person "Abdul" "Alhazred" 71 Nothing +-- > +-- > mountains = Book "At the Mountains of Madness" undefined [] +-- > caseOfCDW = Book "The Case of Charles Dexter Ward" undefined [] +-- > reanimator = Book "Herbert West -- The Re-animator" undefined [] +-- > necronomicon = Book "Necronomicon" undefined [] +-- > +-- > persons = [howard, charles, marinus, herbert, william, frank, abdul] +-- > books = [mountains, caseOfCDW, reanimator, necronomicon] +-- +-- Now, to look up a book's title, we can use the @('.#')@ operator, +-- which is the basis of all @"fields"@ functionality. @('.#')@ takes a +-- value of type @a@ and a @'Field'@ from @a@ to some other type (in +-- this case, 'String') and returns the value of that field. Since an +-- @"fclabels"@ lens is an instance of @'Field'@, we can just use the +-- lens directly. +-- +-- > necronomicon .# title +-- > -- :: String +-- +-- The @author@ field, however, was left undefined in the above +-- definition. We can set it using the @(=:)@ operator +-- +-- > necronomicon .# author =: abdul +-- > -- :: Book +-- +-- A notable detail is that the above expression parenthesizes as +-- @necronomicon .# (author =: abdul)@. The @(=:)@ operator takes a +-- @'Field'@ and a value for that @'Field'@ and returns a new @'Field'@ +-- that, when read, returns a modified version of the record. +-- +-- For the sake of the example, I will assume here that the subsequent +-- references to @necronomicon@ refer to this modified version (and +-- similarly for all other assignment examples below), even though +-- nothing is mutated in reality. +-- +-- The @('=~')@ operator is similar, except that instead of a value, it +-- takes a function that modifies the previous value. For example +-- +-- > howard .# age =~ succ +-- > -- :: Person +-- +-- To access fields in nested records, @'Field'@s can be composed using +-- the @(#)@ combinator. +-- +-- > necronomicon .# author # lastName +-- > -- :: String +-- +-- If we wish to access a field of several records at once, we can use +-- the @('<.#>')@ operator, which can be used to access fields of +-- a record inside a @'Functor'@. For example +-- +-- > persons <.#> age +-- > -- :: [Int] +-- +-- This also works for assignment. For example, let's fix the @author@ +-- fields of the rest of our books. +-- +-- > [mountains, caseOfCDW, reanimator ] <.#> author =: howard +-- > -- :: [Book] +-- +-- Because @('<.#>')@ works for any @'Functor'@, we could access values +-- of type @Maybe Book@, @a -> Book@ or @IO Book@ similarly. +-- +-- We frequently wish to access several fields of a record +-- simultaneously. @"fields"@ supports this using tuples. A tuple of +-- primitive @'Field'@s (currently, \"primitive @'Field'@\" means an +-- @"fclabels"@ lens) is itself a @'Field'@, provided that all the +-- @'Field'@s in the tuple have the same source type (ie. you can +-- combine @Book :-> String@ and @Book :-> Int@ but not @Book :-> +-- String@ and @Person :-> String@). For example, we could do +-- +-- > howard .# (firstName, lastName, age) +-- > -- :: (String, String, Int) +-- +-- @"fields"@ defines instances for tuples of up to 10 elements. In +-- addition, the 2-tuple instance is recursively defined so that a tuple +-- @(a, b)@ is a @'Field'@ if @a@ is a primitive @'Field'@ and @b@ is +-- /any/ valid field. This makes it possible to do +-- +-- > howard .# (firstName, (lastName, age)) =~ (reverse *** reverse *** negate) +-- > -- :: Person +-- +-- We can also compose a @'Field'@ with a pure function (for example, a +-- regular record field accessor function) using the @('#$')@ +-- combinator. However, since a function is one-way, the resulting +-- @'Field'@ cannot be used to set values, and trying to do so will +-- result in an @'error'@. +-- +-- > howard .# lastName #$ length +-- > -- :: Int +-- +-- If we wish to set fields of several records at once, but so that +-- we can also specify the value individually for each record, we can +-- use the @('*#')@ and @('=*')@ operators, which can be thought of as +-- \"zippy\" assignment. They can be used like this +-- +-- > [ mountains, caseOfCDW, reanimator ] *# characters =* +-- > [ [ william, frank ] +-- > , [ charles, marinus ] +-- > , [ herbert ] ] +-- > -- :: [Book] +-- +-- For more complex queries, @"fields"@ also provides the @('<#>')@ and +-- @('<##>')@ combinators. @('<#>')@ combines a @'Field'@ of type @a :-> +-- f b@ with a field of type @b :-> c@, producing a @'Field'@ of type @a +-- :-> f c@, where @f@ is any @'Applicative'@ functor. +-- +-- > mountains .# characters <#> (lastName, age) +-- > -- :: [(String, Int)] +-- +-- @('<##>')@ is similar, except that flattens two monadic @'Field'@s +-- together. I.e. the type signature is @a :-> m b -> b :-> m c -> a :-> +-- m c@. For example +-- +-- > frank .# superior <##> superior <##> superior +-- > -- :: Maybe Person +-- +-- Both @('<#>')@ and @('<##>')@ also support assignment normally, +-- although the exact semantics vary depending on the @'Applicative'@ or +-- @'Monad'@ in question. +-- +-- We might also like to sort or otherwise manipulate collections of +-- records easily. For this, @"fields"@ provides the @'onField'@ +-- combinator in the manner of @'Data.Function.on'@. For example, to sort +-- a list of books by their authors' last names, we can use +-- +-- > sortBy (compare `onField` author # lastName) books +-- > -- :: [Book] +-- +-- Using tuples, we can also easily define sub-orderings. For example, +-- if we wish to break ties based on the authors' first names and then +-- by ages, we can use +-- +-- > sortBy (compare `onField` author # (lastName, firstName, age)) books +-- > -- :: [Book] +-- +-- Since @'onField'@ accepts any @'Field'@, we can easily specify more +-- complex criteria. To sort a list of books by the sum of their +-- characters' ages (which is a bit silly), we could use +-- +-- > sortBy (compare `onField` (characters <#> age) #$ sum) books +-- > -- :: [Book] +-- +-- @"fields"@ also attempts to support convenient pattern matching by +-- means of the @'match'@ function and GHC's @ViewPatterns@ extension. +-- To pattern match on records, you could do something like this +-- +-- > case charles of +-- > (match lastName -> "Dexter") -> Left False +-- > (match lastName -> "Ward") -> Left True +-- > (match (age, superior) -> (a, Just s)) +-- > | a > 18 -> Right a +-- > | otherwise -> Right (s .# age) +-- > -- :: Either Bool Int +-- +-- Finally, a pair of combinators is provided to access record fields of +-- collection types. The @(#!)@ combinator has the type @a :-> c b -> +-- i -> a :-> Maybe b@, where @c@ is an instance of @'Indexable'@ and +-- @i@ is an index type suitable for @c@. For example, you can use an +-- @'Integral'@ value to index a @'String'@ and a value of type @k@ to +-- index a @Map k v@. The @(#!!)@ combinator is also provided. It +-- doesn't have @Maybe@ in the return type, so using a bad index will +-- usually result in an @'error'@. +-- +-- Currently, instances are provided for @[a]@, @'Data.Map'@, +-- @'Data.IntMap'@, @'Data.Array.IArray'@, @'Data.Set'@ and +-- @'Data.IntSet'@. +module Data.Record.Field + ( module Data.Record.Field.Basic + , module Data.Record.Field.Tuple + , module Data.Record.Field.Indexable + , module Data.Record.Field.Combinators + ) where + +import Data.Record.Field.Basic +import Data.Record.Field.Tuple +import Data.Record.Field.Indexable +import Data.Record.Field.Combinators + diff --git a/Data/Record/Field/Basic.hs b/Data/Record/Field/Basic.hs new file mode 100644 --- /dev/null +++ b/Data/Record/Field/Basic.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +-- | The @'Field'@ class and basic operations. + +module Data.Record.Field.Basic + ( -- * Record fields. + Field(..) + -- * Basic field operators. + , (.#) + , (=:) + , (=~) + -- * Pattern matching. + , match + ) where + +import Data.Record.Label hiding ((=:)) + +-- | Instances of this class can be combined with the functions and +-- operators in this package. +class Field a where + -- | The source type of the field. I.e. the record type. + type Src a :: * + -- | The destination type of the field. I.e. the type of the field + -- in question. + type Dst a :: * + -- | Return an @"fclabels"@ lens corresponding to this field. + field :: a -> (Src a :-> Dst a) + +instance Field (a :-> b) where + type Src (a :-> b) = a + type Dst (a :-> b) = b + field = id + +infixl 7 .# +-- | Return the value of the field in the given record. +(.#) :: (Field a) => Src a -> a -> Dst a +r .# f = getL (field f) r + +-- | Infix assignment lookalike. +-- +-- > r.#f =: v +-- +-- returns a modified version of @r@ so that the field corresponding to +-- @f@ are set to @v@. +infixl 8 =: +(=:) :: (Field a) => a -> Dst a -> Src a :-> Src a +a =: v = lens (setL (field a) v) const + +-- | Infix modification lookalike. +-- +-- > r.#f =~ g +-- +-- returns a modified version of @r@ so that the fields corresponding to +-- @f@ are modified with the function @g@. +infixl 8 =~ +(=~) :: (Field a) => a -> (Dst a -> Dst a) -> Src a :-> Src a +a =~ f = lens (modL (field a) f) const + +-- | Convenience function for use with the @ViewPatterns@ extension. +-- +-- > case r of +-- > (match int -> 5) -> "It's 5!" +-- > (match (int,str#$length) -> (i,l)) +-- > | i == l -> "They're equal!" +-- > | otherwise -> "Not equal." +-- > _ -> "Something else." +-- +match :: (Field a) => a -> Src a -> Dst a +match f = (.# f) + diff --git a/Data/Record/Field/Combinators.hs b/Data/Record/Field/Combinators.hs new file mode 100644 --- /dev/null +++ b/Data/Record/Field/Combinators.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Field combinators. +module Data.Record.Field.Combinators + ( -- * Basic combinators. + idL + , ( # ) + , (#$ ) + -- * Combinators for @'Functor'@s, @'Applicative'@s and + -- @'Monad'@s. + , (<.#>) + , (<#>) + , (<##>) + -- * Zippy assignment. + , (*#) + , (=*) + -- * Assignment and modification in a State monad. + , (<=:) + , (<=~) + -- * Utility combinator for comparisons etc. + , onField + ) where + +import Data.Record.Field.Basic +import Data.Record.Label hiding ((=:)) +import qualified Control.Category as C +import Control.Applicative +import Control.Monad +import "monads-fd" Control.Monad.State.Class + +cantSet :: String -> a +cantSet n = error $ n ++ ": cannot set values." + +-- | Identity lens. +idL :: a :-> a +idL = C.id + +-- | Field composition with arguments in OO-like order. +infixl 8 # +( # ) :: (Field a, Field b, Dst a ~ Src b) => + a -> b -> Src a :-> Dst b +a # b = (field b) C.. (field a) + +-- | Compose fields with ordinary functions. As functions are one-way, +-- the resulting field cannot be used to set values. +infixl 8 #$ +(#$) :: (Field a) => a -> (Dst a -> b) -> Src a :-> b +ab #$ f = lens getter (cantSet "(#$)") + where getter a = f . getL (field ab) $ a + +-- | Infix @'fmap'@ for fields. +-- +-- Examples: +-- +-- +-- > persons <.#> firstName +-- +-- > do (v1, v2) <- takeMVar mv <.#> (field1, field2) +-- > putStrLn . unlines $ [ "v1: " ++ show v1, "v2: " ++ show v2 ] +-- +infixl 7 <.#> +(<.#>) :: (Functor f, Field a) => f (Src a) -> a -> f (Dst a) +f <.#> a = fmap (.# a) f + +-- | @'Applicative'@ functor composition for fields. +-- +-- > book .# characters <#> lastName +-- +infixr 9 <#> +(<#>) :: (Applicative f, Field a, Field b, Dst a ~ f (Src b)) => + a -> b -> Src a :-> f (Dst b) +ab <#> bc = lens getter setter + where getter = (fmap $ getL (field bc)) . getL (field ab) + -- the flip is so effects get performed for b first. + setter fc = modL (field ab) $ + \fb -> flip (setL (field bc)) <$> fb <*> fc + +-- | Flattening monadic composition for fields. +-- +-- > person .# superior <##> superior <##> superior <##> superior +-- +infixr 9 <##> +(<##>) :: (Monad m, Field a, Field b, + Dst a ~ m (Src b), Dst b ~ m c) => + a -> b -> Src a :-> m c +ab <##> bc = lens getter setter + where getter = getL (field ab) >=> getL (field bc) + setter mc = modL (field ab) $ + \mb -> do b <- mb + return $ setL (field bc) mc b + +-- | Zippy field reference to be used with @('=*')@. +-- +-- > [ rec1, rec2 ] *# field =* [ value1, value2 ] +-- +infixl 7 *# +(*#) :: (Field b) => [Src b] -> [b] -> [Dst b] +rs *# as = zipWith (.#) rs as + +-- | Zippy infix assignment to be used with @('*#')@. +infixl 8 =* +(=*) :: (Field a) => a -> [Dst a] -> [Src a :-> Src a] +a =* vs = [ a =: v | v <- vs ] + +-- | Infix assignment for the State monad. +-- +-- > (field1, field2) <=: (value1, value2) +-- +infix 3 <=: +(<=:) :: (MonadState (Src a) m, Field a) => + a -> Dst a -> m () +a <=: v = modify (.# a =: v) + +-- | Infix modification for the State monad. +-- +-- > (field1, field2) <=~ (f, g) +-- +infix 3 <=~ +(<=~) :: (MonadState (Src a) m, Field a) => + a -> (Dst a -> Dst a) -> m () +a <=~ f = modify (.# a =~ f) + +-- | Utility combinator in the manner of @'Data.Function.on'@. +-- +-- > sortBy (compare `onField` (lastName,firstName)) persons +-- +infixl 0 `onField` +onField :: (Field a) => (Dst a -> Dst a -> t) -> a -> Src a -> Src a -> t +onField f a r1 r2 = f (r1.#a) (r2.#a) + diff --git a/Data/Record/Field/Indexable.hs b/Data/Record/Field/Indexable.hs new file mode 100644 --- /dev/null +++ b/Data/Record/Field/Indexable.hs @@ -0,0 +1,122 @@ +-- vim: encoding=latin1 +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +-- | Composition operators for collection fields. +module Data.Record.Field.Indexable + ( Indexable(..) + , (#!) + , (#!!) + ) where + +import Data.Record.Field.Basic +import Data.Record.Label +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Array.IArray as IArray +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +-- | Class of collection types that can be indexed into. +-- +-- TODO: This should probably be a single-parameter type class with two +-- associated types instead. +class Indexable a i where + type Element a :: * + indexGet :: i -> a -> Maybe (Element a) + indexSet :: i -> Maybe (Element a) -> a -> a + unsafeIndexGet :: i -> a -> Element a + unsafeIndexGet i a = maybe notFound id $ indexGet i a + where notFound = error "unsafeIndexGet: element not found" + +-- | Compose a field with an @'Indexable'@ collection safely. +-- +-- > r .# coll #! idx +-- +-- returns @Nothing@ if @idx@ was not found from the collection, and +-- @Just v@ if @v@ was found. +-- +-- > r .# coll #! idx =: Just v +-- +-- sets the value at @idx@ in the collection to be @v@. If the value +-- wasn't in the collection, it's inserted. The exact semantics of +-- insertion depend on the actual collection in question. +-- +-- > r .# coll #! idx =: Nothing +-- +-- removes the value at @idx@ from the collection, if possible. +-- +infixl 8 #! +(#!) :: (Field a, Indexable (Dst a) i) => + a -> i -> Src a :-> Maybe (Element (Dst a)) +f #! i = lens getter setter + where getter a = indexGet i (getL (field f) a) + setter v = modL (field f) (indexSet i v) + +-- | As @(#!)@, but reading a nonexistent value will likely result in a +-- bottom value being returned. Also, the resulting field cannot be used +-- to remove values. +infixl 8 #!! +(#!!) :: (Field a, Indexable (Dst a) i) => + a -> i -> Src a :-> Element (Dst a) +f #!! i = lens getter setter + where getter a = unsafeIndexGet i (getL (field f) a) + setter v = setL (field $ f #! i) (Just v) + +instance (Integral i) => Indexable [a] i where + type Element [a] = a + unsafeIndexGet i as = as !! fromIntegral i + indexGet i as = case drop (fromIntegral i) as of + [] -> Nothing + (a:_) -> Just a + indexSet i Nothing as = before ++ drop 1 after + where (before,after) = splitAt (fromIntegral i) as + indexSet i (Just v) as = before ++ (v : drop 1 after) + where (before,after) = splitAt (fromIntegral i) as + +instance (Ord k1, k1 ~ k2) => Indexable (Map.Map k1 a) k2 where + type Element (Map.Map k1 a) = a + unsafeIndexGet = flip (Map.!) + indexGet = Map.lookup + indexSet k v = Map.alter (const v) k + +instance Indexable (IntMap.IntMap a) Int where + type Element (IntMap.IntMap a) = a + unsafeIndexGet = flip (IntMap.!) + indexGet = IntMap.lookup + indexSet k v = IntMap.alter (const v) k + +instance (IArray.IArray a e, IArray.Ix i1, i1 ~ i2) => + Indexable (a i1 e) i2 where + type Element (a i1 e) = e + unsafeIndexGet = flip (IArray.!) + indexGet i a + | i >= min && i <= max = Just $ a IArray.! i + | otherwise = Nothing + where (min, max) = IArray.bounds a + + indexSet i Nothing a = a -- array elements can't be removed + indexSet i (Just v) a + | i >= min && i <= max = a IArray.// [(i,v)] + | otherwise = a + where (min, max) = IArray.bounds a + +instance (Ord a1, a1 ~ a2) => Indexable (Set.Set a1) a2 where + type Element (Set.Set a1) = a1 + -- unsafeIndexGet doesn't really make sense here. + indexGet a set | a `Set.member` set = Just a + | otherwise = Nothing + indexSet a Nothing set = Set.delete a set + indexSet a (Just _) set = Set.insert a set + +instance Indexable IntSet.IntSet Int where + type Element IntSet.IntSet = Int + -- unsafeIndexGet doesn't really make sense here. + indexGet a set | a `IntSet.member` set = Just a + | otherwise = Nothing + indexSet a Nothing set = IntSet.delete a set + indexSet a (Just _) set = IntSet.insert a set + diff --git a/Data/Record/Field/Tuple.hs b/Data/Record/Field/Tuple.hs new file mode 100644 --- /dev/null +++ b/Data/Record/Field/Tuple.hs @@ -0,0 +1,302 @@ +-- vim: encoding=latin1 +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +-- | Instances for tuples of fields up to a 10-tuple. This allows +-- accessing several fields simultaneously. +-- +-- > r.#(field1, field2, field3#field4) =: (value1, value2, value3) +-- +-- In addition, the pair instance is recursively defined, which allows +-- stuff like +-- +-- > import Control.Arrow ((***)) +-- > r.#(field1, (field2, field3)) =~ (f *** g *** h) +-- +module Data.Record.Field.Tuple + ( + ) where + +import Data.Record.Field.Basic +import Data.Record.Field.Combinators +import Data.Record.Label hiding ((=:)) +{- Commented out to remove the dependency to pretty. +import Text.PrettyPrint hiding (int) +import qualified Text.PrettyPrint as PP +-} + + +instance (Field f, r ~ Src f) => Field (r :-> a, f) where + type Src (r :-> a, f) = r + type Dst (r :-> a, f) = (a, Dst f) + field (l1, f) = lens get set + where get r = (getL l1 r, getL l2 r) + set (a, b) = setL l2 b . setL l1 a + l2 = field f + +{- Commented out to remove the dependency to pretty. +mkTupleFieldInstance :: Int -> String +mkTupleFieldInstance n = render inst + where inst = header $+$ nest 4 defs + header = text "instance Field" <+> typ <+> text "where" + + typ = tupleOf [ text "r :->" <+> v | v <- vs ] + vals = tupleOf vs + + defs = vcat [rec, val, field, accs] + + tupleOf = parens . commaSep + commaSep = sep . punctuate (text ",") + + rs = [ text "r" <> PP.int i | i <- [1..n] ] + vs = take n $ [ text [v] | v <- ['a'..'z'] ] ++ + [ text [v1,v2] | v1 <- ['a'..'z'] + , v2 <- ['a'..'z'] ] + + rec = text "type Src" <+> typ <+> text "= r" + val = text "type Dst" <+> typ <+> text "=" <+> vals + field = text "field" <+> tupleOf rs <+> text "= lens get set" + accs = nest 4 $ text "where" <+> vcat [getter, setter] + + getter = text "get r =" <+> tupleOf [ get r | r <- rs ] + setter = text "set" <+> vals <+> text "=" <+> + (sep . punctuate (text " .")) [ set r v | (r,v) <- zip rs vs ] + + get r = text "getL" <+> r <+> text "r" + set r v = text "setL" <+> r <+> v +-} + +instance Field (r :-> a, r :-> b, r :-> c) where + type Src (r :-> a, r :-> b, r :-> c) = r + type Dst (r :-> a, r :-> b, r :-> c) = (a, b, c) + field (r1, r2, r3) = lens get set + where get r = (getL r1 r, getL r2 r, getL r3 r) + set (a, b, c) = setL r1 a . setL r2 b . setL r3 c +instance Field (r :-> a, r :-> b, r :-> c, r :-> d) where + type Src (r :-> a, r :-> b, r :-> c, r :-> d) = r + type Dst (r :-> a, r :-> b, r :-> c, r :-> d) = (a, b, c, d) + field (r1, r2, r3, r4) = lens get set + where get r = (getL r1 r, getL r2 r, getL r3 r, getL r4 r) + set (a, b, c, d) = setL r1 a . setL r2 b . setL r3 c . setL r4 d +instance Field (r :-> a, r :-> b, r :-> c, r :-> d, r :-> e) where + type Src (r :-> a, r :-> b, r :-> c, r :-> d, r :-> e) = r + type Dst (r :-> a, r :-> b, r :-> c, r :-> d, r :-> e) = (a, + b, + c, + d, + e) + field (r1, r2, r3, r4, r5) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r) + set (a, b, c, d, e) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e +instance Field (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f) where + type Src (r :-> a, r :-> b, r :-> c, r :-> d, r :-> e, r :-> f) = r + type Dst (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f) = (a, b, c, d, e, f) + field (r1, r2, r3, r4, r5, r6) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r, + getL r6 r) + set (a, b, c, d, e, f) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e . + setL r6 f +instance Field (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g) where + type Src (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g) = r + type Dst (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g) = (a, b, c, d, e, f, g) + field (r1, r2, r3, r4, r5, r6, r7) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r, + getL r6 r, + getL r7 r) + set (a, b, c, d, e, f, g) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e . + setL r6 f . + setL r7 g +instance Field (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h) where + type Src (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h) = r + type Dst (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h) = (a, b, c, d, e, f, g, h) + field (r1, r2, r3, r4, r5, r6, r7, r8) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r, + getL r6 r, + getL r7 r, + getL r8 r) + set (a, b, c, d, e, f, g, h) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e . + setL r6 f . + setL r7 g . + setL r8 h +instance Field (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i) where + type Src (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i) = r + type Dst (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i) = (a, b, c, d, e, f, g, h, i) + field (r1, r2, r3, r4, r5, r6, r7, r8, r9) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r, + getL r6 r, + getL r7 r, + getL r8 r, + getL r9 r) + set (a, b, c, d, e, f, g, h, i) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e . + setL r6 f . + setL r7 g . + setL r8 h . + setL r9 i +instance Field (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i, + r :-> j) where + type Src (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i, + r :-> j) = r + type Dst (r :-> a, + r :-> b, + r :-> c, + r :-> d, + r :-> e, + r :-> f, + r :-> g, + r :-> h, + r :-> i, + r :-> j) = (a, b, c, d, e, f, g, h, i, j) + field (r1, r2, r3, r4, r5, r6, r7, r8, r9, r10) = lens get set + where get r = (getL r1 r, + getL r2 r, + getL r3 r, + getL r4 r, + getL r5 r, + getL r6 r, + getL r7 r, + getL r8 r, + getL r9 r, + getL r10 r) + set (a, b, c, d, e, f, g, h, i, j) = setL r1 a . + setL r2 b . + setL r3 c . + setL r4 d . + setL r5 e . + setL r6 f . + setL r7 g . + setL r8 h . + setL r9 i . + setL r10 j + diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Data.List +import Control.Applicative +import Control.Arrow ((***)) +import "monads-fd" Control.Monad.State + +import Data.Record.Field +import Data.Record.Label hiding ((=:)) + +data Person = Person + { _firstName :: String + , _lastName :: String + , _age :: Int + , _superior :: Maybe Person + } + +data Book = Book + { _title :: String + , _author :: Person + , _characters :: [Person] + } + +$(mkLabels [''Person, ''Book]) + +parens s = concat ["(", s, ")"] + +-- We could just derive Show, but let's try to eat our own dog food +-- here. +instance Show Person where + -- Arguably, RecordWildCards would be nicer here, but nothing + -- prevents you from using it along with this package. + show (match (firstName, lastName, age, superior) -> + (f, l, a, s)) = parens . unwords $ [ "Person" + , show f + , show l + , show a + , show s ] + +instance Show Book where + show b = parens . unwords $ "Book" : [ b .# f + | f <- [ title #$ show + , author #$ show + , characters #$ show ] ] + +howard = Person "Howard" "Lovecraft" 46 Nothing +charles = Person "Charles" "Ward" 26 Nothing +marinus = Person "Marinus" "Willett" 56 Nothing +william = Person "William" "Dyer" 53 Nothing +frank = Person "Frank" "Pabodie" 49 Nothing +herbert = Person "Herbert" "West" 32 Nothing +abdul = Person "Abdul" "Alhazred" 71 Nothing + +mountains = Book "At the Mountains of Madness" undefined [] +caseOfCDW = Book "The Case of Charles Dexter Ward" undefined [] +reanimator = Book "Herbert West -- The Re-animator" undefined [] +necronomicon = Book "Necronomicon" undefined [] + +persons = [howard, charles, marinus, herbert, william, frank, abdul] + +-- All the lets and primes are ugly, but it clearly shows that nothing +-- is being mutated. With the State monad, we could use (<=:) instead. +main = do print $ necronomicon .# title + let necronomicon' = necronomicon .# author =: abdul + print $ necronomicon' .# author # lastName + + sep + + let [mountains', caseOfCDW', reanimator' ] = + [mountains, caseOfCDW, reanimator ] <.#> author =: howard + + [ mountains'', caseOfCDW'', reanimator'' ] = + [ mountains', caseOfCDW', reanimator' ] *# characters =* + [ [ william, frank ] + , [ charles, marinus ] + , [ herbert ] ] + let books = [ mountains'', caseOfCDW'' + , reanimator'', necronomicon'] + print books + + sep + + print $ howard .# (firstName, lastName, age) + print $ howard .# (firstName, (lastName, age )) =~ + (reverse *** reverse *** negate) + + sep + + print $ books <.#> characters <#> (lastName, firstName ) + print $ sortBy (compare `onField` author # lastName) books + print $ sortBy (compare `onField` (characters <#> age) #$ sum) books + + sep + + print $ case charles of + (match lastName -> "Dexter") -> Left False + (match lastName -> "Ward") -> Left True + (match (age, superior) -> (a, Just s)) + | a > 18 -> Right a + | otherwise -> Right (s .# age) + + sep + + print $ howard .# lastName #! 0 + print $ howard .# lastName #! 0 =: Nothing + print $ howard .# lastName #! 0 =: Just 'X' + + sep + + let frank' = frank .# superior =: Just william + -- :: Maybe Person + print $ frank' .# superior + -- :: Maybe (Maybe Person) + print $ frank' .# superior <#> superior + -- :: Maybe (Maybe (Maybe Person)) + print $ frank' .# superior <#> superior <#> superior + -- :: Maybe Person + print $ frank' .# superior <##> superior <##> superior <##> superior + where sep = putStrLn "" + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Jussi Knuuttila + +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 Jussi Knuuttila nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fields.cabal b/fields.cabal new file mode 100644 --- /dev/null +++ b/fields.cabal @@ -0,0 +1,161 @@ +-- fields.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: fields + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1.0 + +-- A short (one-line) description of the package. +Synopsis: First-class record field combinators with infix + record field syntax. + +-- A longer description of the package. +Description: Using records, especially nested records, in + Haskell can sometimes be a bit of a chore. + Fortunately, there are several libraries in hackage + that make working with records easier. This library + is my attempt to build on top of these libraries to + make working with records even more pleasant! + . + In most imperative languages, records are accessed + using the infix dot operator. Record fields can be + read simply by suffixing a record value with + '.field' and they can be modified by simply + assigning to that location. Although this is not + the only way to access records (indeed, Haskell + does not use it), many people (including myself) + like it. This library attempts to support this + style for Haskell records in the following manner: + . + > record.field.subfield becomes record .# field # subfield + > record.field = value becomes record .# field =: value + . + Of course, the infix assignment in Haskell is pure + and doesn't actually mutate anything. Rather, a + modified version of the record is returned. + . + In addition, the following features are supported: + . + * Accessing several fields simultaneously using + tuples. + Example: @record .# (field1, field2, field3)@ + . + * Accessing records inside a @'Functor'@. + Example: @recordInFunctor \<.#\> field@ + . + * Composing fields with @'Applicative'@ functors + and @'Monad'@s. + Example: @record .\# applicativeField \<\#\> subfield@ + . + * Pattern matching using @ViewPatterns@. + Example: @case record of (match field -> 1) -> ...@ + . + * Easy comparisons etc. using @'onField'@. + Example: @sortBy (compare \`onField\` + field#subfield) records@ + . + For a detailed description of usage, see + "Data.Record.Field". + . + This library is a work-in-progress. Some + limitations, deficiencies, points of interest and + possible future improvements include: + . + * Currently, a @'Field'@ instance is only provided + for @"fclabels"@ lenses, since that is what I + have personally used. However, there should be + nothing in principle that would prevent adding + instances for @"data-accessor"@ and @"lenses"@. + However, doing this would make this package + depend on several record libraries at once, + which might not be the best approach. Perhaps + this package should be split into several + packages? + . + * Similarly, the @'field'@ method currently + returns an @"fclabels"@ lens. To fully decouple + this package from @"fclabels"@, the @'field'@ + method probably has to be split into @getField@, + @setField@ and @modField@ or something similar. + . + * For monad transformers, @"transformers"@ and + @"monads-fd"@ are used, since those are what + @"fclabels"@ uses. This might be a problem for a + program that uses @"mtl"@ instead. + . + * To avoid lots of parentheses, @"fields"@ uses + high-precedence operators at three operator + precedence levels. The goal was to make field + accesses directly usable in arithmetic + expressions (e.g. @r1\.\#int + r2\.\#int@). + Unfortunately, since Haskell has a finite number + of precedence levels, this goal was not properly + met, since @('*')@ and all higher-precedence + arithmetic operators have conflicting precedence + levels. + . + * Performance has not been analyzed at all. To my + knowledge, GHC doesn't do type class + specialization or method inlining by default, so + needlessly generic code might be generated, even + if all types are statically known. I'm hoping + that this can be addressed using @SPECIALIZE@ + and @INLINE@ pragmas if it turns out to be an + issue. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Jussi Knuuttila + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: jussi.knuuttila@tkk.fi + +Homepage: http://github.com/AstraFIN/fields + +-- 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: Example.hs + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.8.0.2 + + +Library + -- Modules exported by the library. + Exposed-modules: Data.Record.Field + , Data.Record.Field.Basic + , Data.Record.Field.Combinators + , Data.Record.Field.Tuple + , Data.Record.Field.Indexable + + -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5 + , fclabels >= 0.9.1 + , containers >= 0.3.0.0 + , array >= 0.3.0.0 + , transformers >= 0.2.0.0 + , monads-fd >= 0.1.0.1 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: +