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

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