named-records 0.2.3 → 0.3

raw patch · 2 files changed

+184/−77 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• named-records.cabal +4/−2
• src/Data/NamedRecord.hs +180/−75

@@ -1,5 +1,5 @@ Name:           named-records-Version:        0.2.3+Version:        0.3 Synopsis:       Flexible records with named fields. Description:    Flexible records with named fields.                 .@@ -15,6 +15,8 @@                 [@v0.2.3@] Cabal package tidied up and basic                     documentation added (also fixed a bug regarding                     definition of default values).+                .+                [@v0.3@] Records can now extend other records.                  License:        MIT License-File:   LICENSE@@ -33,7 +35,7 @@ Source-Repository head     type: darcs     location: hub.darcs.net:names-    tag: v0.2.3+    tag: v0.3   Library

@@ -107,6 +107,44 @@ >                            := [e| \x -> answer x |] >     `has` "config" := ''Config := [e| newConfig |] +It is furthermore possible to extend existing records+(but due to stage restrictions in GHCs implementation of+Template Haskell, two records of which one extends the other+can not be contained in the same module):++> module Sample2 where+> +> import qualified Data.Name+> import Data.NamedRecord+> import Data.Word+> +> record "Account"+>     `has` "id"        := ''Word64+> +>     `has` "loginName" := ''String+>     `has` "password"  := ''String+> +> record "Person"+>     `has` "id"        := ''Word64+> +>     `has` "firstName" := ''String+>     `has` "lastName"  := ''String++> module Sample where+> +> import qualified Data.Name+> import Data.NamedRecord+> import Data.Word+> +> import Sample2+> +> record "User"+>     `extends` __Person+>     `extends` __Account+> +>     `has` "id"           := ''Word64+>     `has` "emailAddress" := ''String+ -} module Data.NamedRecord (     Property (get, set),@@ -121,28 +159,33 @@     -- See the examples.     record, +    extends,+     -- | Declares a field of a record. Use as infix operators.     -- See the examples.     has, -    RecordTemplate (..),-     -- ** Names     -- For convenience, this module re-exports name TH name functions.     name, nameT, nameV ) where ++import Control.Monad+import Data.Data+import Data.Function (on) import Data.List import qualified Data.Name import Data.Name (name, nameT, nameV)+import Data.Typeable import Language.Haskell.TH+import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (Lift (..))  - data a := b = a := b deriving Show -infixl 3 :=+infixr 3 :=   data a :+ b = a :+ b deriving Show@@ -151,7 +194,6 @@   class Property o n v | o n -> v where-         get :: o -> n -> v     set :: o -> n := v -> o @@ -166,128 +208,152 @@   instance Property (n := v) n v where-     get (_ := v) _ = v     set _ v = v - instance Property ((n := v) :+ b) n v where-     get (a :+ b) n = get a n     set (a :+ b) p = (set a p) :+ b - instance Property b n v => Property (a :+ b) n v where-     get (a :+ b) n = get b n     set (a :+ b) p = a :+ (set b p)  +class ToExp a where+    toExp' :: a -> Q Exp -data Record = Record String+instance ToExp (Q Exp) where+    toExp' = id -record :: String -> Record-record = Record+instance Lift a => ToExp a where+    toExp' = lift  -class ToType a where toType :: a -> Q Type+class Field a where+    toExp :: a -> Maybe (Q Exp)+    toType :: a -> Q Type -instance ToType (Q Type) where toType = id-instance ToType Name where toType = return . ConT+    toExp _ = Nothing +instance ToExp e => Field (Q Type := e) where+    toExp (_ := e) = Just $ toExp' e+    toType (v := _) = v -class ToExp a where toExp :: a -> Q Exp+instance ToExp e => Field (Name := e) where+    toExp (_ := e) = Just $ toExp' e+    toType (v := _) = return $ ConT v -instance ToExp (Q Exp) where toExp = id-instance Lift a => ToExp a where toExp = lift+instance Field Name where+    toType = return . ConT +instance Field (Q Type) where+    toType = id +instance (Data a, Typeable a) => Field a where+    toExp = Just . dataToExpQ (const Nothing)+    toType e = qType typeName+      where+        typeName = show (typeOf e)++        qType typeName = case typeName of++            -- This is a dirty hack. It would be much better+            -- to resolve all type synonyms to their real types.+            -- This would have to be done in (~>)+            "[Char]" -> return $ ConT ''String++            ('[':xs) -> do+                t <- qType (init xs)+                return $ AppT ListT t++            ('M':'a':'y':'b':'e':' ':xs) -> do+                t <- qType xs+                m <- [t| Maybe |]+                return $ AppT m t++            name -> lookupTypeName name >>= typeFor++        typeFor (Just n) = return $ ConT n+        typeFor Nothing = fail $ "The type \"" ++ typeName+            ++ "\" can not be handled by Data.NamedRecord TH sugar"+            ++ " (you might to import the module where it's from)."++ class RecordTemplate a b c | a b -> c where     (~>) :: a -> b -> c --instance (ToType v, ToType w) => RecordTemplate+instance (Field v, Field w) => RecordTemplate         (String := v)         (String := w)         [(String, Q Type, Maybe (Q Exp))] where-    (n := v) ~> (m := w) = [(n, toType v, Nothing),-                            (m, toType w, Nothing)]+    (n := v) ~> (m := w) = [(n, toType v, toExp v),+                            (m, toType w, toExp w)] -instance (ToType v, ToType w, ToExp e) => RecordTemplate+instance Field v => RecordTemplate         (String := v)-        (String := w := e)+        [(String, Q Type, Maybe (Q Exp))]         [(String, Q Type, Maybe (Q Exp))] where-    (n := v) ~> (m := w := e) = [(n, toType v, Nothing),-                                 (m, toType w, Just $ toExp e)]+    (n := v) ~> xs = (n, toType v, toExp v) : xs -instance (ToType v, ToType w, ToExp d) => RecordTemplate-        (String := v := d)-        (String := w)-        [(String, Q Type, Maybe (Q Exp))] where-    (n := v := d) ~> (m := w) = [(n, toType v, Just $ toExp d),-                                 (m, toType w, Nothing)]+instance Field v => RecordTemplate Record (String := v) (Q [Dec]) where+    r ~> (n := v) = r ~> [(n, toType v, toExp v)] -instance (ToType v, ToType w, ToExp d, ToExp e) => RecordTemplate-        (String := v := d)-        (String := w := e)-        [(String, Q Type, Maybe (Q Exp))] where-    (n := v := d) ~> (m := w := e) = [(n, toType v, Just $ toExp d),-                                      (m, toType w, Just $ toExp e)]+instance RecordTemplate+        Record [(String, Q Type, Maybe (Q Exp))] (Q [Dec]) where -instance ToType v => RecordTemplate-        (String := v)-        [(String, Q Type, Maybe (Q Exp))]-        [(String, Q Type, Maybe (Q Exp))] where-    (n := v) ~> xs = (n, toType v, Nothing) : xs+    Record name xs ~> fs = do+        let typeD typ = TySynD (mkName name) [] typ -instance (ToType v, ToExp d) => RecordTemplate-        (String := v := d)-        [(String, Q Type, Maybe (Q Exp))]-        [(String, Q Type, Maybe (Q Exp))] where-    (n := v := d) ~> xs = (n, toType v, Just $ toExp d) : xs+            noValue = VarE 'value +            normalize (n, v, d) = do+                v' <- v+                d' <- maybe (return noValue) id d+                return (n, (v', d')) -instance ToType v => RecordTemplate Record (String := v) (Q [Dec]) where-    r ~> (n := v) = r ~> [(n, toType v, Nothing :: Maybe (Q Exp))]+        nFields <- mapM normalize fs+                    >>= return . sortBy (compare `on` fst) -instance (ToType v, ToExp d) =>-        RecordTemplate Record (String := v := d) (Q [Dec]) where-    r ~> (n := v := d) = r ~> [(n, toType v, Just $ toExp d)]+        let fs' = sortBy (compare `on` fst) (concat (nFields : xs)) +            unify sss@(s:ss) =+                if all id (zipWith ((==) `on` (fst . snd)) ss sss)+                    then return $ select sss+                    else fail $ "Types for the named field \""+                        ++ fst s ++ "\" could not be unified."+                        ++ "\n    The conflicting types are: \n"+                        ++ unlines (map (show . fst . snd) sss) -instance RecordTemplate-        Record [(String, Q Type, Maybe (Q Exp))] (Q [Dec]) where+            select (x:[]) = x+            select (x@(_, (_, d)) : xs)+                | d == noValue = select xs+                | otherwise    = x -    Record name ~> fs = do-        let typeD typ = TySynD (mkName name) [] typ+            mkDef (n, (v, d)) = do+                name <- nameT n+                return (AppT (AppT (ConT ''(:=)) name) v, d) -            func (name, valType, defaultVal) = do-                nameType <- nameT name-                valueType <- valType-                defaultValue <- maybe (return $ VarE 'value) id defaultVal-                return $ ( AppT (AppT (ConT ''(:=)) nameType) valueType-                         , defaultValue )+        nFields <- mapM unify (groupBy ((==) `on` fst) fs')+        fields  <- mapM mkDef nFields+        rExp    <- dataToExpQ (const Nothing) nFields -        fields <- mapM func-            $ sortBy (\(x, _, _) (y, _, _) -> compare x y) fs+        let reflD = ValD (VarP (mkName ("__" ++ name))) (NormalB rExp) [] -        let syn = foldr (\(x, _) xs -> AppT (AppT (ConT ''(:+)) x) xs)+            syn = foldr (\(x, _) xs -> AppT (AppT (ConT ''(:+)) x) xs)                         (fst $ last fields) (init fields)              cName = mkName ("new" ++ name)--            sigD = SigD cName (ConT (mkName name))-+            sigD  = SigD cName (ConT (mkName name))             funcD = ValD (VarP cName) (NormalB funcB) []             funcB = foldr join (field $ last fields) (init fields)               where                 join x xs = InfixE (Just $ field x) (ConE '(:+)) (Just xs)--            field (_, x) = InfixE (Just (VarE '_type))-                             (ConE '(:=))-                             (Just x)+                field (_, x) = InfixE (Just (VarE '_type))+                                      (ConE '(:=))+                                      (Just x) -        return [typeD syn, sigD, funcD]+        return [typeD syn, sigD, funcD, reflD]   _type = error $ "NamedRecord field type unwrapped!"@@ -301,5 +367,44 @@  infixr 1 ~> infixr 1 `has`+++class RecordExtends a where+    (<:) :: Record -> a -> Record++instance RecordExtends [(String, (Type, Exp))] where+    Record name xs <: x = Record name (x:xs)++extends :: RecordExtends a => Record -> a -> Record+extends = (<:)++infixl 2 <:+infixl 2 `extends`+++data Record = Record String [[(String, (Type, Exp))]]++record :: String -> Record+record name = Record name []+++-- Playground below++fieldNames :: FieldNames a => a -> [String]+fieldNames = _fieldNames []+++class FieldNames a where+    _fieldNames :: [String] -> a -> [String]++instance (Show n, FieldNames r) =>+        FieldNames (n := ns :+ r) where++    _fieldNames xs (n := _ :+ r) = _fieldNames (show n : xs) r++instance (Show n) => FieldNames (n := ns) where++    _fieldNames xs (n := _) = show n : xs+