diff --git a/named-records.cabal b/named-records.cabal --- a/named-records.cabal +++ b/named-records.cabal @@ -1,11 +1,88 @@ Name: named-records -Version: 0.2.1 +Version: 0.2.2 Synopsis: Flexible records with named fields. Description: Flexible records with named fields. . [@v0.2@] Default values with @record@. . [@v0.2.1@] Requires @names-0.2.1@. + . + [@v0.2.2@] TH @record@ definitions allow for + more types to be used in the definition. + . + Named records allow you to define und use records + with labeled fields. These records are first class + objects. Record fields are labeled by names, which + can basically be any type. However, the names package + provides global name types and some syntactic sugar + to use them. + . + Here is a complete walk-through, with Template Haskell + syntactic sugar. + . + This is how a typical example preamble looks like: + . + > {-# LANGUAGE Haskell2010, TemplateHaskell #-} + > + > import qualified Data.Name + > import Data.NamedRecord + . + In order to use names you need to declare them first + (see the @names@ package for further details): + . + > name "firstName" + > name "lastName" + . + These are two records @Person@ and @User@: + . + > record "Person" + > `has` "firstName" := ''String + > `has` "lastName" := ''String + > + > record "User" + > `has` "firstName" := ''String + > `has` "lastName" := ''String + > `has` "loginName" := ''String + . + Note that these declarations create constructor + functions @newPerson@ and @newUser@, as well as + type synonyms @Person@ and @User@ (use @-ddump-slices@ + to see what has been generated). + . + Here are two instances of these recors: + . + > julian = newPerson + > `set` firstName := "Julian" + > `set` lastName := "Fleischer" + > + > alexander = newUser + > `set` firstName := "Alexander" + > `set` lastName := "Carnicero" + > `set` loginName := "alexander.carnicero" + . + We can now create a @displayName@ function like + the following: + . + > displayName obj = + > (obj `get` firstName) ++ " " ++ + > (obj `get` lastName) + . + Note that this function will accept any record + that has a @firstName@ and a @lastName@ field of + type @String@. + . + >>> displayName julian + Julian Fleischer + . + >>> displayName alexander + Alexander Carnicero + . + As mentioned above, records are first class citizens. + That means you can create them anywhere: + . + >>> displayName (firstName := "John" :+ lastName := "Doe") + John Doe + License: MIT License-File: LICENSE Author: Julian Fleischer @@ -16,11 +93,10 @@ Stability: experimental Library - Exposed-Modules: Data.NamedRecord, - Data.NamedRecord.TH + Exposed-Modules: Data.NamedRecord Build-Depends: base >= 4 && < 5, - names == 0.2.1, + names == 0.2.2, template-haskell >= 2.7 Hs-Source-Dirs: src diff --git a/src/Data/NamedRecord.hs b/src/Data/NamedRecord.hs --- a/src/Data/NamedRecord.hs +++ b/src/Data/NamedRecord.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Haskell2010 + , TemplateHaskell , MultiParamTypeClasses , FunctionalDependencies , TypeOperators @@ -7,14 +8,39 @@ , OverlappingInstances #-} -module Data.NamedRecord where +module Data.NamedRecord ( + Property (get, set), + add, + (:=) (..), + (:+) (..), + record, + has, + + RecordTemplate (..), + + module Data.Name +) where + +import Data.List +import qualified Data.Name +import Data.Name (name, nameT, nameV) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift (..)) + + + data a := b = a := b deriving Show infixl 3 := +data a :+ b = a :+ b deriving Show + +infixr 2 :+ + + class Property o n v | o n -> v where get :: o -> n -> v @@ -48,8 +74,123 @@ set (a :+ b) p = a :+ (set b p) -data a :+ b = a :+ b deriving Show -infixr 2 :+ +data Record = Record String + +record :: String -> Record +record = Record + + +class ToType a where toType :: a -> Q Type + +instance ToType (Q Type) where toType = id +instance ToType Name where toType = return . ConT + + +class ToExp a where toExp :: a -> Q Exp + +instance ToExp (Q Exp) where toExp = id +instance Lift a => ToExp a where toExp = lift + + +class RecordTemplate a b c | a b -> c where + (~>) :: a -> b -> c + + +instance (ToType v, ToType 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)] + +instance (ToType v, ToType w, ToExp e) => RecordTemplate + (String := v) + (String := w := e) + [(String, Q Type, Maybe (Q Exp))] where + (n := v) ~> (m := w := e) = [(n, toType v, Nothing), + (n, toType w, Just $ toExp e)] + +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), + (n, toType w, Nothing)] + +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), + (n, toType w, Just $ toExp e)] + +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 + +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 + + +instance ToType v => RecordTemplate Record (String := v) (Q [Dec]) where + r ~> (n := v) = r ~> [(n, toType v, Nothing :: Maybe (Q Exp))] + +instance (ToType v, ToExp d) => + RecordTemplate Record (String := v := d) (Q [Dec]) where + r ~> (n := v := d) = r ~> [(n, toType v, Just $ toExp d)] + + +instance RecordTemplate + Record [(String, Q Type, Maybe (Q Exp))] (Q [Dec]) where + + Record name ~> fs = do + let typeD typ = TySynD (mkName name) [] typ + + func (name, valType, defaultVal) = do + nameType <- nameT name + valueType <- valType + defaultValue <- maybe (return $ VarE 'value) id defaultVal + return $ ( AppT (AppT (ConT ''(:=)) nameType) valueType + , defaultValue ) + + fields <- mapM func + $ sortBy (\(x, _, _) (y, _, _) -> compare x y) fs + + let syn = foldr (\(x, _) xs -> AppT (AppT (ConT ''(:+)) x) xs) + (fst $ last fields) (init fields) + + cName = mkName ("new" ++ 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) + + return [typeD syn, sigD, funcD] + + +_type = error $ "NamedRecord field type unwrapped!" + ++ " You should never see this." + ++ " Srsly, what did you do?" + +value = error "Data.NameRecord.undefined: No value set." + +has :: RecordTemplate a b c => a -> b -> c +has = (~>) + +infixr 1 ~> +infixr 1 `has` diff --git a/src/Data/NamedRecord/TH.hs b/src/Data/NamedRecord/TH.hs deleted file mode 100644 --- a/src/Data/NamedRecord/TH.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE Haskell2010 - , MultiParamTypeClasses - , FunctionalDependencies - , TypeOperators - , FlexibleInstances - , TemplateHaskell - #-} - -module Data.NamedRecord.TH where - - -import Data.List -import Data.NamedRecord -import Data.Name.TH -import Language.Haskell.TH - - -data Record = Record String - -record :: String -> Record -record = Record - - -class RecordTemplate a b c | a b -> c where - - (~>) :: a -> b -> c - - -instance RecordTemplate - (String := Name) - (String := Name) - [(String := Name, Maybe (Q Exp))] where - - a ~> b = [(a, Nothing), (b, Nothing)] - - -instance RecordTemplate - (String := Name := Q Exp) - (String := Name) - [(String := Name, Maybe (Q Exp))] where - - (p := d) ~> b = [(p, Just d), (b, Nothing)] - - -instance RecordTemplate - (String := Name) - (String := Name := Q Exp) - [(String := Name, Maybe (Q Exp))] where - - a ~> (p := d) = [(a, Nothing), (p, Just d)] - - -instance RecordTemplate - (String := Name := Q Exp) - (String := Name := Q Exp) - [(String := Name, Maybe (Q Exp))] where - - (a := m) ~> (b := n) = [(a, Just m), (b, Just n)] - - -instance RecordTemplate - (String := Name) - [(String := Name, Maybe (Q Exp))] - [(String := Name, Maybe (Q Exp))] where - - p ~> xs = (p, Nothing) : xs - - -instance RecordTemplate - (String := Name := Q Exp) - [(String := Name, Maybe (Q Exp))] - [(String := Name, Maybe (Q Exp))] where - - (p := d) ~> xs = (p, Just d) : xs - - -instance RecordTemplate - Record - (String := Name) - (Q [Dec]) where - - r ~> p = r ~> [(p, Nothing :: Maybe (Q Exp))] - - -instance RecordTemplate - Record - (String := Name := Q Exp) - (Q [Dec]) where - - r ~> (p := d) = r ~> [(p, Just d)] - - -instance RecordTemplate - Record - [(String := Name, Maybe (Q Exp))] - (Q [Dec]) where - - Record name ~> fs = do - let typeD typ = TySynD (mkName name) [] typ - - func (name := valueType, defaultVal) = do - nameType <- nameT name - defaultValue <- maybe (return $ VarE 'value) id defaultVal - return $ ( AppT (AppT (ConT ''(:=)) nameType) - (ConT valueType) - , defaultValue ) - - fields <- mapM func - $ sortBy (\(x := _, _) (y := _, _) -> compare x y) fs - - let syn = foldr (\(x, _) xs -> AppT (AppT (ConT ''(:+)) x) xs) - (fst $ last fields) (init fields) - - cName = mkName ("new" ++ 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) - - return [typeD syn, sigD, funcD] - - -_type = error $ "NamedRecord field type unwrapped!" - ++ " You should never see this." - ++ " Srsly, what did you do?" - -value = error "Data.NameRecord.undefined: No value set." - -has :: RecordTemplate a b c => a -> b -> c -has = (~>) - -infixr 1 ~> -infixr 1 `has` - -