{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoStarIsType #-}
module Data.SerDoc.TH
( deriveSerializable
, deriveHasInfo
, deriveSerDoc
)
where
import Data.SerDoc.Info
import Data.SerDoc.Class
import Data.List
import Data.Proxy
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Data.Char
import Control.Monad
strippedFieldName :: Name -> Name -> String
strippedFieldName :: Name -> Name -> String
strippedFieldName Name
tyName Name
fieldName =
let tyStr :: String
tyStr = Name -> String
nameBase Name
tyName
fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
lcfirst :: String -> String
lcfirst [] = []
lcfirst (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
tyStrLC :: String
tyStrLC = String -> String
lcfirst String
tyStr
in
if String
tyStrLC String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fieldStr then
Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
tyStrLC) String
fieldStr
else
String
fieldStr
nameToTy :: Name -> Type
nameToTy :: Name -> Type
nameToTy Name
name = case Name -> String
nameBase Name
name of
String
"" -> String -> Type
forall a. HasCallStack => String -> a
error String
"Empty names are not allowed"
Char
c:String
_ | Char -> Bool
isLower Char
c -> Name -> Type
VarT Name
name
Char
c:String
_ | Char -> Bool
isUpper Char
c -> Name -> Type
ConT Name
name
String
_ -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"Unsupported name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
#if MIN_VERSION_template_haskell(2,17,0)
tyVarBndrName :: TyVarBndr a -> Name
tyVarBndrName :: forall a. TyVarBndr a -> Name
tyVarBndrName (PlainTV Name
name a
_) = Name
name
tyVarBndrName (KindedTV Name
name a
_ Type
_) = Name
name
#else
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV name ) = name
tyVarBndrName (KindedTV name _) = name
#endif
deriveHasInfo :: Name -> [Name] -> Name -> DecsQ
deriveHasInfo :: Name -> [Name] -> Name -> DecsQ
deriveHasInfo Name
codecName [Name]
codecArgs Name
typeName = do
TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
codecVars Maybe Type
_ [Con]
_ [DerivClause]
_) <- Name -> Q Info
reify Name
codecName
let remainingVars :: [TyVarBndr ()]
remainingVars = Int -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a. Int -> [a] -> [a]
drop ([Name] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Name]
codecArgs) [TyVarBndr ()]
codecVars
let codecTy :: Type
codecTy = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
codecName) ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
nameToTy ([Name]
codecArgs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarBndrName [TyVarBndr ()]
remainingVars))
Name -> Q Info
reify Name
typeName Q Info -> (Info -> DecsQ) -> DecsQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TyConI (DataD [] Name
tyName [TyVarBndr ()]
tyVars Maybe Type
Nothing [RecC Name
_ [VarBangType]
fields] []) -> do
let constraintFields :: [VarBangType]
constraintFields = (VarBangType -> Bool) -> [VarBangType] -> [VarBangType]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
_, Bang
_, Type
fieldTy) -> Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> (Type -> [Name]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Type
fieldTy) [VarBangType]
fields
Cxt
constraints <- [VarBangType] -> (VarBangType -> Q Type) -> Q Cxt
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VarBangType]
constraintFields ((VarBangType -> Q Type) -> Q Cxt)
-> (VarBangType -> Q Type) -> Q Cxt
forall a b. (a -> b) -> a -> b
$
\(Name
_, Bang
_, Type
fieldTy) ->
[t| HasInfo $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy) $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
fieldTy) |]
(Dec -> [Dec]) -> Q Dec -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> DecsQ) -> Q Dec -> DecsQ
forall a b. (a -> b) -> a -> b
$
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Cxt
constraints)
[t| HasInfo
$(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy)
$((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT Name
tyName) [ Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
bndr) | TyVarBndr ()
bndr <- [TyVarBndr ()]
tyVars ])
|]
[ Name -> [Q Clause] -> Q Dec
forall (m :: Type -> Type). Quote m => Name -> [m Clause] -> m Dec
funD
(String -> Name
mkName String
"info")
[ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"codec")
, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"_")
]
(Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [|
compoundField
$(Lit -> Q Exp
forall (m :: Type -> Type). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (Name -> String
nameBase Name
tyName)))
$([Q Exp] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
listE
[ [| ( $(Lit -> Q Exp
forall (m :: Type -> Type). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (Name -> Name -> String
strippedFieldName Name
tyName Name
fieldName)))
, info codec (Proxy :: Proxy $(Type -> Q Type
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Type
fieldTy))
)
|]
| (Name
fieldName, Bang
_, Type
fieldTy) <- [VarBangType]
fields
]
)
|]
)
[]
]
]
Info
x ->
String -> DecsQ
forall a. HasCallStack => String -> a
error (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"Unsupported data type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
x
deriveSerializable :: Name -> [Name] -> Name -> DecsQ
deriveSerializable :: Name -> [Name] -> Name -> DecsQ
deriveSerializable Name
codecName [Name]
codecArgs Name
typeName = do
TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
codecVars Maybe Type
_ [Con]
_ [DerivClause]
_) <- Name -> Q Info
reify Name
codecName
let remainingVars :: [TyVarBndr ()]
remainingVars = Int -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a. Int -> [a] -> [a]
drop ([Name] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Name]
codecArgs) [TyVarBndr ()]
codecVars
let codecTy :: Type
codecTy = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
codecName) ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
nameToTy ([Name]
codecArgs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarBndrName [TyVarBndr ()]
remainingVars))
Name -> Q Info
reify Name
typeName Q Info -> (Info -> DecsQ) -> DecsQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TyConI (DataD [] Name
tyName [TyVarBndr ()]
tyVars Maybe Type
Nothing [RecC Name
conName [VarBangType]
fields] []) -> do
let constraintFields :: [VarBangType]
constraintFields =
if [TyVarBndr ()] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
remainingVars then
(VarBangType -> Bool) -> [VarBangType] -> [VarBangType]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
_, Bang
_, Type
fieldTy) -> Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> (Type -> [Name]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Type
fieldTy) [VarBangType]
fields
else
[VarBangType]
fields
Cxt
constraints1 <-
if [TyVarBndr ()] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
remainingVars then
Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
else
[Q Type] -> Q Cxt
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence
[ [t| Monad (MonadEncode $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy)) |]
, [t| Monad (MonadDecode $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy)) |]
]
Cxt
constraints2 <- [VarBangType] -> (VarBangType -> Q Type) -> Q Cxt
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VarBangType]
constraintFields ((VarBangType -> Q Type) -> Q Cxt)
-> (VarBangType -> Q Type) -> Q Cxt
forall a b. (a -> b) -> a -> b
$
\(Name
_, Bang
_, Type
fieldTy) ->
[t| Serializable $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy) $(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
fieldTy) |]
let constraints :: Cxt
constraints = Cxt
constraints1 Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
constraints2
(Dec -> [Dec]) -> Q Dec -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> DecsQ) -> Q Dec -> DecsQ
forall a b. (a -> b) -> a -> b
$
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Cxt
constraints)
[t| Serializable
$(Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
codecTy)
$((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT Name
tyName) [ Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
bndr) | TyVarBndr ()
bndr <- [TyVarBndr ()]
tyVars ])
|]
[ Name -> [Q Clause] -> Q Dec
forall (m :: Type -> Type). Quote m => Name -> [m Clause] -> m Dec
funD
(String -> Name
mkName String
"encode")
[ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"p")
, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"item")
]
(Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
[| sequence_
$([Q Exp] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
listE
[ [| encode p ($(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fieldName) item) |]
| (Name
fieldName, Bang
_, Type
_) <- [VarBangType]
fields
])
|]
)
[]
]
, Name -> [Q Clause] -> Q Dec
forall (m :: Type -> Type). Quote m => Name -> [m Clause] -> m Dec
funD
(String -> Name
mkName String
"decode")
[ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"p")
]
(Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
[| $(Q Exp -> [Q Exp] -> Q Exp
foldApplicative
(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
conE Name
conName)
[ [| decode p |] | VarBangType
_ <- [VarBangType]
fields ]
)
|]
)
[]
]
]
Info
x ->
String -> DecsQ
forall a. HasCallStack => String -> a
error (String -> DecsQ) -> (Info -> String) -> Info -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> String
forall a. Show a => a -> String
show (Info -> DecsQ) -> Info -> DecsQ
forall a b. (a -> b) -> a -> b
$ Info
x
deriveSerDoc :: Name -> [Name] -> Name -> DecsQ
deriveSerDoc :: Name -> [Name] -> Name -> DecsQ
deriveSerDoc Name
codecName [Name]
codecArgs Name
typeName =
[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> DecsQ -> Q ([Dec] -> [Dec])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Name] -> Name -> DecsQ
deriveHasInfo Name
codecName [Name]
codecArgs Name
typeName
Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Name -> [Name] -> Name -> DecsQ
deriveSerializable Name
codecName [Name]
codecArgs Name
typeName
foldApplicative :: ExpQ -> [ExpQ] -> ExpQ
foldApplicative :: Q Exp -> [Q Exp] -> Q Exp
foldApplicative Q Exp
initial [] = [| pure $Q Exp
initial |]
foldApplicative Q Exp
initial [Q Exp
x] = [| $Q Exp
initial <$> $Q Exp
x |]
foldApplicative Q Exp
initial (Q Exp
x:[Q Exp]
xs) =
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Q Exp
b -> [| $Q Exp
a <*> $Q Exp
b |]) [| $Q Exp
initial <$> $Q Exp
x |] [Q Exp]
xs
#if MIN_VERSION_template_haskell(2,17,0)
tyVarName :: TyVarBndr a -> Name
tyVarName :: forall a. TyVarBndr a -> Name
tyVarName (PlainTV Name
n a
_) = Name
n
tyVarName (KindedTV Name
n a
_ Type
_) = Name
n
#else
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV n) = n
tyVarName (KindedTV n _) = n
#endif