NamedRecord.hs

{-# LANGUAGE Haskell2010
    , TemplateHaskell
    , MultiParamTypeClasses
    , FunctionalDependencies
    , TypeOperators
    , FlexibleInstances
    , UndecidableInstances
    , OverlappingInstances
 #-}

{- | Flexible records with named fields.

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:

> 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-splices@
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

It is also possible to declare default values:

> name "serverName"
> name "port"
> 
> record "ServerConfig"
>     `has` "serverName" := ''String := "localhost"
>     `has` "port"       := ''Int := (4711 :: Int)

>>> newServerConfig
serverName := "localhost" :+ port := 4711

>>> newServerConfig `set` serverName := "example.org"
serverName := "example.org" :+ port := 4711

>>> newServerConfig `get` port
4711

Complex expressions and types need to be quoted using
@[e| expr |]@ and @[t| type |]@ like so:

> record "Server"
>     `has` "requestHandler" := [t| Request -> Response |]
>                            := [e| \x -> answer x |]
>     `has` "config" := ''Config := [e| newConfig |]

-}
module Data.NamedRecord (
    Property (get, set),
    add,

    (:=) (..),
    (:+) (..),

    -- * Template Haskell Syntactic Sugar

    -- | Declares a record (looks like a new keyword @record@).
    -- See the examples.
    record,

    -- | 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 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
    set :: o -> n := v -> o

infixl 1 `set`
infixl 1 `get`


add :: b -> a -> a :+ b
add = flip (:+)

infixl 1 `add`


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)



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),
                                 (m, 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),
                                 (m, 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),
                                      (m, 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`