{-# 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] where

    a ~> b = [a, b]


instance RecordTemplate
    (String := Name) [String := Name] [String := Name] where

    (~>) = (:)


instance RecordTemplate Record (String := Name) (Q [Dec]) where

    record ~> field = record ~> [field]


instance RecordTemplate Record [String := Name] (Q [Dec]) where

    Record name ~> fs = do
        let typeD typ = TySynD (mkName name) [] typ

            func (name := valueType) = do
                nameType <- nameT name
                return $ AppT (AppT (ConT ''(:=)) nameType)
                              (ConT valueType)

        fields <- mapM func
            $ sortBy (\(x := _) (y := _) -> compare x y) fs

        let def = foldr (\x xs -> AppT (AppT (ConT ''(:+)) x) xs)
                        (last fields) (init fields)

            cName = mkName ("new" ++ name)

            sigD = SigD cName (ConT (mkName name))

            funcD = ValD (VarP cName) (NormalB funcB) []
            funcB = foldr join field (init fields)
              where
                join x xs = InfixE (Just field) (ConE '(:+)) (Just xs)

            field = InfixE (Just (VarE '_type))
                           (ConE '(:=))
                           (Just (VarE '_value))

        return [typeD def, 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`