{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE
CPP, DeriveDataTypeable, DeriveLift, PatternSynonyms, StandaloneDeriving,
TemplateHaskell
#-}
module Extensible
(
NameAffix (.., NamePrefix, NameSuffix), applyAffix,
newName, varT,
extensible, extensibleWith, Config (..), defaultConfig, WarningType (..))
where
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax
import Generics.SYB (Data, everywhere, mkT)
import GHC.Generics (Generic)
import Control.Monad
import Data.Functor.Identity
import Data.Void
import qualified Data.Kind as K
deriving instance Lift Name
deriving instance Lift OccName
deriving instance Lift NameFlavour
deriving instance Lift ModName
deriving instance Lift NameSpace
deriving instance Lift PkgName
data NameAffix =
NameAffix {naPrefix, naSuffix :: String}
deriving (Eq, Show, Lift)
pattern NamePrefix, NameSuffix :: String -> NameAffix
pattern NamePrefix pre = NameAffix {naPrefix = pre, naSuffix = ""}
pattern NameSuffix suf = NameAffix {naPrefix = "", naSuffix = suf}
instance Semigroup NameAffix where
NameAffix pre1 suf1 <> NameAffix pre2 suf2 =
NameAffix (pre1 <> pre2) (suf2 <> suf1)
instance Monoid NameAffix where mempty = NameAffix "" ""
onNameBaseF :: Functor f => (String -> f String) -> Name -> f Name
onNameBaseF f name = addModName <$> f (nameBase name) where
addModName b = mkName $ case nameModule name of
Nothing -> b
Just m -> m ++ "." ++ b
onNameBase :: (String -> String) -> Name -> Name
onNameBase f = runIdentity . onNameBaseF (Identity . f)
applyAffix :: NameAffix -> Name -> Name
applyAffix (NameAffix pre suf) = onNameBase (\b -> pre ++ b ++ suf)
qualifyWith :: String -> Name -> Name
qualifyWith m n = case nameModule n of
Nothing -> mkName (m ++ "." ++ nameBase n)
Just _ -> n
data WarningType = Ignore | Warn | Error deriving (Eq, Show, Lift)
data Config = Config {
datatypeName :: NameAffix,
constructorName :: NameAffix,
bundleName :: NameAffix,
annotationName :: NameAffix,
annotationLabel :: NameAffix,
extensionName :: NameAffix,
extensionLabel :: NameAffix,
extRecordName :: NameAffix,
extRecTypeName :: NameAffix,
extRecNameName :: NameAffix,
defExtRecName :: NameAffix,
extFunName :: NameAffix,
newtypeWarn :: WarningType
} deriving (Eq, Show, Lift)
defaultConfig :: Config
defaultConfig = Config {
datatypeName = NameSuffix "'",
constructorName = NameSuffix "'",
bundleName = NameSuffix "All",
annotationName = NamePrefix "X",
annotationLabel = NamePrefix "ann",
extensionName = NameSuffix "X",
extensionLabel = NamePrefix "ext",
extRecordName = NamePrefix "Ext",
extRecTypeName = NamePrefix "type",
extRecNameName = NamePrefix "name",
defExtRecName = NamePrefix "default",
extFunName = NamePrefix "extend",
newtypeWarn = Warn
}
data SimpleCon = SimpleCon {
scName :: Name,
scFields :: SimpleFields
} deriving (Eq, Show, Data)
data SimpleFields = NormalFields [BangType] | RecFields [VarBangType]
deriving (Eq, Show, Data)
data SimpleDec =
SimpleData {
sdName :: Name,
sdVars :: [TyVarBndr],
sdCons :: [SimpleCon],
sdDerivs :: [SimpleDeriv]
}
| SimpleType {
sdName :: Name,
sdVars :: [TyVarBndr],
sdSynRhs :: Type
}
deriving (Eq, Show, Data)
data SimpleStrategy = SBlank | SStock | SAnyclass deriving (Eq, Show, Data)
data SimpleDeriv =
SimpleDeriv {
sdStrat :: SimpleStrategy,
dsContext :: Cxt
} deriving (Eq, Show, Data)
simpleDec :: WarningType -> Dec -> Q SimpleDec
simpleDec _w (DataD ctx name tvs kind cons derivs)
| not $ null ctx = fail "data contexts unsupported"
| Just _ <- kind = fail "kind signatures unsupported"
| otherwise =
SimpleData name tvs
<$> traverse simpleCon cons
<*> traverse simpleDeriv derivs
simpleDec Error (NewtypeD _ name _ _ _ _) =
fail $
"newtype " ++ nameBase name ++ " found\n" ++
"please replace it with a datatype"
simpleDec Warn n@(NewtypeD _ name _ _ _ _) = do
reportWarning $
"replacing newtype " ++ nameBase name ++ " with data\n" ++
"(due to adding another field and a second constructor)\n" ++
"you may want to replace the newtype with a (strict) datatype"
simpleDec Ignore n
simpleDec Ignore (NewtypeD ctx name tvs kind con derivs) =
simpleDec Ignore $ DataD ctx name tvs kind [makeStrict con] derivs
where
makeStrict = everywhere $ mkT $ const $ Bang NoSourceUnpackedness SourceStrict
simpleDec _w (TySynD n tvs rhs) = pure $ SimpleType n tvs rhs
simpleDec _w d =
fail $
"only datatype declarations are supported inside extensible; found\n" ++
pprint d
simpleCon :: Con -> Q SimpleCon
simpleCon (NormalC name fields) = pure $ SimpleCon name $ NormalFields fields
simpleCon (RecC name fields) = pure $ SimpleCon name $ RecFields fields
simpleCon _ = fail "only simple constructors supported for now"
simpleDeriv :: DerivClause -> Q SimpleDeriv
simpleDeriv (DerivClause strat prds) =
SimpleDeriv <$> simpleStrat strat <*> pure prds
where
simpleStrat Nothing = pure SBlank
simpleStrat (Just StockStrategy) = pure SStock
simpleStrat (Just AnyclassStrategy) = pure SAnyclass
simpleStrat (Just NewtypeStrategy) = fail "newtype deriving unsupported"
simpleStrat (Just (ViaStrategy _)) = fail "deriving via unsupported"
extensible :: DecsQ -> DecsQ
extensible = extensibleWith defaultConfig
extensibleWith :: Config -> DecsQ -> DecsQ
extensibleWith conf ds = do
ds' <- traverse (simpleDec (newtypeWarn conf)) =<< ds
home <- loc_module <$> location
makeExtensible conf home ds'
tyvarName :: TyVarBndr -> Name
tyvarName (PlainTV x) = x
tyvarName (KindedTV x _) = x
tvbToTypeExp :: TyVarBndr -> ExpQ
tvbToTypeExp tv = [|varT $(lift $ tyvarName tv)|]
isRecordFields :: SimpleFields -> Bool
isRecordFields (NormalFields {}) = False
isRecordFields (RecFields {}) = True
isRecordCon :: SimpleCon -> Bool
isRecordCon = isRecordFields . scFields
extIsRecord :: [SimpleCon] -> Bool
extIsRecord = all isRecordCon
makeExtensible :: Config
-> String
-> [SimpleDec] -> DecsQ
makeExtensible conf home decs =
let nameMap = [(name, applyAffix (datatypeName conf) name)
| d <- decs, let name = sdName d]
in concat <$> mapM (makeExtensible1 conf home nameMap) decs
makeExtensible1 :: Config
-> String
-> [(Name, Name)]
-> SimpleDec -> DecsQ
makeExtensible1 conf home nameMap (SimpleData name tvs cs derivs) = do
let Just name' = lookup name nameMap
ext <- newName "ext"
let tvs' = PlainTV ext : tvs
cs' <- traverse (extendCon conf nameMap ext tvs) cs
let cx = extensionCon conf (extIsRecord cs) name ext tvs
efs <- traverse (extendFam conf tvs) cs
efx <- extensionFam conf name tvs
bnd <- constraintBundle conf name ext tvs cs
insts <- fmap concat $
traverse (makeInstances conf name' (map fst nameMap) ext tvs) derivs
(rname, fcnames, fname, rec) <- extRecord conf name cs
(_dname, defRec) <- extRecDefault conf rname fcnames fname
(_ename, extFun) <- makeExtender conf home name rname tvs cs
pure $
DataD [] name' tvs' Nothing (cs' ++ [cx]) [] :
efs ++ [efx, bnd] ++ insts ++ [rec] ++ defRec ++ extFun
makeExtensible1 _conf _home nameMap (SimpleType name tvs rhs) = do
let Just name' = lookup name nameMap
ext <- newName "ext"
pure [TySynD name' (PlainTV ext : tvs) $ extendRecursions nameMap ext rhs]
nonstrict :: BangQ
nonstrict = bang noSourceUnpackedness noSourceStrictness
strict :: Bang
strict = Bang NoSourceUnpackedness SourceStrict
appExtTvs :: TH.Type -> Name -> [TyVarBndr] -> TH.Type
appExtTvs t ext tvs = foldl AppT t $ fmap VarT $ ext : fmap tyvarName tvs
extendCon :: Config
-> [(Name, Name)]
-> Name
-> [TyVarBndr]
-> SimpleCon -> ConQ
extendCon conf nameMap ext tvs (SimpleCon name fields) = do
let name' = applyAffix (constructorName conf) name
xname = applyAffix (annotationName conf) name
fields' = extendRecursions nameMap ext fields
extField = appExtTvs (ConT xname) ext tvs
case fields' of
NormalFields fs -> pure $ NormalC name' $ fs ++ [(strict, extField)]
RecFields fs ->
let extLabel = applyAffix (annotationLabel conf) name in
pure $ RecC name' $ fs ++ [(extLabel, strict, extField)]
extendRecursions :: Data a
=> [(Name, Name)]
-> Name
-> a -> a
extendRecursions nameMap ext = everywhere $ mkT go where
go (ConT k) | Just new <- lookup k nameMap = ConT new `AppT` VarT ext
go t = t
extensionCon :: Config
-> Bool
-> Name
-> Name
-> [TyVarBndr]
-> Con
extensionCon conf record name ext tvs =
let namex = applyAffix (extensionName conf) name
label = applyAffix (extensionLabel conf) name
typ = appExtTvs (ConT namex) ext tvs
in
if record then
RecC namex [(label, strict, typ)]
else
NormalC namex [(strict, typ)]
extendFam :: Config -> [TyVarBndr] -> SimpleCon -> DecQ
extendFam conf tvs (SimpleCon name _) =
extendFam' (applyAffix (annotationName conf) name) tvs
extensionFam :: Config -> Name -> [TyVarBndr] -> DecQ
extensionFam conf name tvs =
extendFam' (applyAffix (extensionName conf) name) tvs
constraintBundle :: Config
-> Name
-> Name
-> [TyVarBndr] -> [SimpleCon] -> DecQ
constraintBundle conf name ext tvs cs = do
c <- newName "c"
ckind <- [t|K.Type -> K.Constraint|]
let cnames = map scName cs
bname = applyAffix (bundleName conf) name
tvs' = kindedTV c ckind : plainTV ext : tvs
con1 n = varT c `appT`
foldl appT (conT n) (varT ext : map (varT . tyvarName) tvs)
tupled ts = foldl appT (tupleT (length ts)) ts
tySynD bname tvs' $ tupled $ map con1 $
map (applyAffix $ annotationName conf) cnames ++
[applyAffix (extensionName conf) name]
makeInstances :: Config
-> Name
-> [Name]
-> Name
-> [TyVarBndr]
-> SimpleDeriv
-> DecsQ
makeInstances conf name names ext tvs (SimpleDeriv strat prds) =
pure $ map make1 prds
where
make1 prd = StandaloneDerivD strat' ctx (prd `AppT` ty) where
ty = appExtTvs (ConT name) ext tvs
ctx | prd == ConT ''Generic = []
| otherwise = (map tvPred tvs ++ map allPred names)
tvPred = AppT prd . VarT . tyvarName
allPred name' = appExtTvs (ConT bname `AppT` prd) ext tvs
where bname = applyAffix (bundleName conf) name'
strat' = case strat of
SBlank -> Nothing
SStock -> Just StockStrategy
SAnyclass -> Just AnyclassStrategy
extendFam' :: Name -> [TyVarBndr] -> DecQ
extendFam' name tvs = do
ext <- newName "ext"
pure $ OpenTypeFamilyD $ TypeFamilyHead name (PlainTV ext : tvs) NoSig Nothing
extRecord :: Config -> Name -> [SimpleCon]
-> Q (Name, [(Name, Name, String)], Name, Dec)
extRecord conf cname cs = do
let rname = applyAffix (extRecordName conf) cname
conann c | isRecordCon c = [t| Maybe [(String, TypeQ)] |]
| otherwise = [t| Maybe [ TypeQ ] |]
extList | extIsRecord cs = [t| [(String, [(String, TypeQ)])] |]
| otherwise = [t| [(String, [ TypeQ ])] |]
tfields <- traverse (\c -> extRecTypeField conf (conann c) (scName c)) cs
nfields <- traverse (extRecNameField conf . scName) cs
extField <- extRecTypeField conf extList $
applyAffix (extensionName conf) cname
pure (rname,
zip3 (map fieldName tfields)
(map fieldName nfields)
(map (nameBase . scName) cs),
fieldName extField,
DataD [] rname [] Nothing
[RecC rname (tfields ++ nfields ++ [extField])] [])
where
fieldName (n, _, _) = n
extRecTypeField :: Config -> TypeQ -> Name -> VarBangTypeQ
extRecTypeField conf ty name =
varBangType (applyAffix (extRecTypeName conf) name) $ bangType nonstrict ty
extRecNameField :: Config -> Name -> VarBangTypeQ
extRecNameField conf name = do
varBangType (applyAffix (extRecNameName conf) name) $
bangType nonstrict [t|String|]
extRecDefault :: Config
-> Name
-> [(Name, Name, String)]
-> Name
-> Q (Name, [Dec])
extRecDefault conf rname fcnames fname = do
let mkField (t, n, c) = [fieldExp t [|Just []|], fieldExp n (stringE c)]
fields = concatMap mkField fcnames
xfield = fieldExp fname [| [] |]
dname = applyAffix (defExtRecName conf) rname
defn <- valD (varP dname) (normalB (recConE rname (fields ++ [xfield]))) []
pure (dname, [SigD dname (ConT rname), defn])
makeExtender :: Config
-> String
-> Name
-> Name
-> [TyVarBndr] -> [SimpleCon] -> Q (Name, [Dec])
makeExtender conf home name' rname' tvs cs = do
let name = qualifyWith home name'
rname = qualifyWith home rname'
ename = applyAffix (extFunName conf) name'
rtype = go tvs where
go [] = conT rname
go (_:xs) = [t|TypeQ -> $(go xs)|]
sig <- sigD ename [t|String -> [Name] -> TypeQ -> $rtype -> DecsQ|]
syn <- newName "syn"
vars <- newName "vars"
tag <- newName "tag"
exts <- newName "exts"
exts' <- newName "exts'"
let defn =
[|sequence $ concat $(listE $
map (decsForCon conf home exts' tag tvs) cs ++
[decsForExt conf home exts' tag (extIsRecord cs) tvs name,
makeTySyn conf home name syn vars tag,
completePrag conf exts' cs name])|]
let args = map (\tv -> [|varT $(lift $ tyvarName tv)|]) tvs
val <- funD ename
[clause (map varP [syn, vars, tag, exts]) (normalB defn)
[valD (varP exts') (normalB (appsE (varE exts : args))) []]]
pure (ename, [sig, val])
makeTySyn :: Config
-> String
-> Name
-> Name
-> Name
-> Name
-> ExpQ
makeTySyn conf home name syn vars tag =
let tyname = qualifyWith home $ applyAffix (datatypeName conf) name in
[|[tySynD (mkName $(varE syn))
(map plainTV $(varE vars))
(appT (conT tyname) $(varE tag))]|]
decsForCon :: Config
-> String
-> Name
-> Name
-> [TyVarBndr] -> SimpleCon -> ExpQ
decsForCon conf home extsName tagName tvs (SimpleCon name fields) = do
args <- case fields of
NormalFields fs -> replicateM (length fs) (newName "x")
RecFields fs -> mapM (\(n, _, _) -> newName $ nameBase n) fs
let tyfam = qualifyWith home $ applyAffix (annotationName conf) name
name' = qualifyWith home $ applyAffix (constructorName conf) name
typeC = varE $ qualifyWith home $ applyAffix (extRecTypeName conf) name
nameC = varE $ qualifyWith home $ applyAffix (extRecNameName conf) name
exts = varE extsName
tag = varE tagName
isRec = isRecordFields fields
tvs' = listE $ map tvbToTypeExp tvs
[|let
#if MIN_VERSION_template_haskell(2,15,0)
mkTf rhs = tySynInstD $
tySynEqn Nothing
(foldl appT (conT tyfam) $ $tag : $tvs')
rhs
#else
mkTf rhs = tySynInstD tyfam $ tySynEqn ($tag : $tvs') rhs
#endif
annType = $typeC $exts; patName = mkName $ $nameC $exts
mkPatSyn args' rhs = patSynD patName lhs implBidir rhs where
lhs = $(if isRec then [|recordPatSyn|] else [|prefixPatSyn|]) args'
in
case annType of
Just as ->
let ty = tupT $(if isRec then [|map snd as|] else [|as|])
anns =
$(if isRec then
[|map (mkName . fst) as|]
else
[|makeVars "ann" $ length as|])
in
[mkTf ty,
mkPatSyn (args ++ anns)
(conP name' (map varP args ++ [tupP (map varP anns)]))]
Nothing ->
[mkTf (conT $(lift ''Void))]
|]
decsForExt :: Config
-> String
-> Name
-> Name
-> Bool
-> [TyVarBndr] -> Name -> ExpQ
decsForExt conf home extsName tagName isRec tvs name = do
let cname' = applyAffix (extensionName conf) name
cname = qualifyWith home cname'
typeC = varE $ applyAffix (extRecTypeName conf) cname'
tyfam = applyAffix (extensionName conf) name
exts = varE extsName; tag = varE tagName
getTy = if isRec then [|map snd|] else [|id|]
tvs' = listE $ map tvbToTypeExp tvs
[|let typs = $typeC $exts
tySynRhs = case typs of
[] -> conT $(lift ''Void)
ts -> foldr1 mkEither $ map (tupT . $getTy . snd) ts
where mkEither t u = conT $(lift ''Either) `appT` t `appT` u
#if MIN_VERSION_template_haskell(2,15,0)
tySyn = tySynInstD $ tySynEqn Nothing
(foldl appT (conT tyfam) ($tag : $tvs'))
tySynRhs
#else
tySyn = tySynInstD tyfam $
tySynEqn ($tag : $tvs') tySynRhs
#endif
mkPatSyn mkRhs (patName, flds) =
let lbls =
$(if isRec then
[|map (mkName . fst) flds|]
else
[|makeVars "x" $ length flds|])
lhs = $(if isRec then [|recordPatSyn|] else [|prefixPatSyn|])
in
patSynD (mkName patName) (lhs lbls) implBidir
(conP cname [mkRhs (tupP $ map varP lbls)])
in
tySyn : zipWith mkPatSyn (makeEithers (length typs)) typs|]
makeVars :: String -> Int -> [Name]
makeVars pfx n = map (mkName . (pfx ++) . show) $ take n [1 :: Int ..]
completePrag :: Config
-> Name
-> [SimpleCon]
-> Name
-> ExpQ
completePrag conf extsName cs name =
let exts = varE extsName
mkCie cie (SimpleCon cname _) =
let nameC = varE $ applyAffix (extRecNameName conf) cname
typeC = varE $ applyAffix (extRecTypeName conf) cname
in
[|$cie (mkName ($nameC $exts)) ($typeC $exts)|]
typeE = varE $ applyAffix (extRecTypeName <> extensionName $ conf) name
in
[|let conIfEnabled _ Nothing = []
conIfEnabled n (Just _) = [n]
allExts = map $ mkName . fst
in
[pragCompleteD
(concat $(listE $ map (mkCie [|conIfEnabled|]) cs) ++
allExts ($typeE $exts))
Nothing]
|]
makeEithers :: Int -> [PatQ -> PatQ]
makeEithers = addEithers' id where
addEithers' _ 0 = []
addEithers' f 1 = [f]
addEithers' f n =
(\p -> f [p|Left $p|]) :
addEithers' (\p -> [p|Right $(f p)|]) (n - 1)
tupT :: [TypeQ] -> TypeQ
tupT [t] = t
tupT ts = foldl appT (tupleT (length ts)) ts