{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module RecordWrangler
(
wrangle
, WrangleOpts
, defWrangleOpts
, fieldLabelModifier
, constructorModifier
, typeNameModifier
, addFields
, field
, NewField
, Proxy(..)
) where
import GHC.TypeLits
import Data.Traversable
import Data.Typeable
import Language.Haskell.TH
data WrangleOpts = WrangleOpts
{ fieldLabelModifier :: String -> String
, typeNameModifier :: String -> String
, constructorModifier :: String -> String
, addFields :: [NewField]
}
data NewField where
NewField :: String -> Bang -> Q Type -> NewField
field :: IsType typ => String -> typ -> NewField
field name typ = NewField name (Bang NoSourceUnpackedness NoSourceStrictness) (toType typ)
class IsType typ where
toType :: typ -> Q Type
instance IsType (Q Type) where
toType = id
instance IsType Name where
toType nm = do
info <- reify nm
case info of
TyConI dec -> case dec of
DataD _cxt name _tyVars _mkind _cons _derivs ->
pure (ConT name)
NewtypeD _cxt name _tyVars _mkind _con _derivs ->
pure (ConT name)
TySynD name _tyVars _typ ->
pure (ConT name)
_ -> fail
$ "Expected a data, newtype, or type synonym. You gave me: "
<> show dec
PrimTyConI name _arity _unlifted ->
pure (ConT name)
FamilyI _dec _instances ->
fail
$ "I don't know how to handle FamilyI yet."
_ ->
fail
$ "Expected a name referring to a Type, but you gave me "
<> "'" <> show nm <> "' which refers to this: "
<> show info
instance {-# OVERLAPPABLE #-}
( TypeError
( 'Text "The argument to 'field' must either be a QuasiQuoted type or a Name referrinng to a type. You gave me an: "
':$$: 'ShowType x)
) => IsType x
where
toType = undefined
defWrangleOpts :: WrangleOpts
defWrangleOpts = WrangleOpts
{ fieldLabelModifier = (++ "'")
, typeNameModifier = (++ "'")
, constructorModifier = (++ "'")
, addFields = []
}
wrangle :: Name -> WrangleOpts -> DecsQ
wrangle tyName WrangleOpts {..} = do
TyConI theDec <- reify tyName
(name, tyvars, constrs) <-
case theDec of
DataD _ctx name tyVarBinders _mkind constructors _derivs ->
pure (name, tyVarBinders, constructors)
NewtypeD _ctx name tyVarBinders _mkind constructor _derivs ->
pure (name, tyVarBinders, [constructor])
_ ->
fail
$ "Expected a data or newtype declaration, but the given name \""
<> show tyName
<> "\" is neither of these things."
let modifyName f = mkName . f . nameBase
newRecName = modifyName typeNameModifier name
recConstrs <- for constrs $ \constr -> case constr of
RecC recName fields ->
pure (recName, fields)
_ ->
fail
$ "Expected a record constructor, but got: "
<> show constr
newFields <-
for addFields $ \(NewField fieldName bang' qtyp) -> do
typ <- qtyp
pure (mkName fieldName, bang', typ)
let newConstrs = flip map recConstrs $ \(recName, fields) ->
( modifyName constructorModifier recName
, (++ newFields) . flip map fields $ \(fieldName, bang', typ) ->
(modifyName fieldLabelModifier fieldName, bang', typ)
)
newTypes = map (\(_, _, t) -> t) newFields
let mkPatternFrom (recName, _) vars =
ConP recName $ map VarP vars
mkVariableNames (_, fields) =
for fields $ \_ -> newName "x"
mkBodyFrom (recName, _) vars =
NormalB $ foldl AppE (ConE recName) (map VarE vars)
convClauses <-
for (zip recConstrs newConstrs) $ \(constr, newConstr) -> do
vars <- mkVariableNames constr
pure $ Clause [mkPatternFrom constr vars] (mkBodyFrom newConstr vars) []
let convertName =
"wrangle" <> nameBase tyName <> "To" <> nameBase newRecName
convert =
FunD (mkName convertName) convClauses
let sig = functionType (newTypes ++ [ConT tyName, ConT newRecName])
functionType xs = case reverse xs of
typ:typs ->
foldr (\x acc -> AppT (AppT ArrowT x) acc) typ typs
[] ->
error "Error in RecordWrangler: needed a nonempty list of types"
pure
[ DataD [] newRecName tyvars Nothing (map (uncurry RecC) newConstrs) []
, SigD (mkName convertName) sig
, convert
]