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`