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`