{-# 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`