{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module Language.LSP.Types.Utils
( rdrop
, makeSingletonFromJSON
, makeRegHelper
, makeExtendingDatatype
, lspOptions
, lspOptionsUntagged
) where
import Control.Monad
import Data.Aeson
import Data.List
import Language.Haskell.TH
rdrop :: Int -> [a] -> [a]
rdrop :: Int -> [a] -> [a]
rdrop Int
cnt = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
cnt ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
makeSingletonFromJSON :: Name -> Name -> Q [Dec]
makeSingletonFromJSON :: Name -> Name -> Q [Dec]
makeSingletonFromJSON Name
wrap Name
gadt = do
TyConI (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) <- Name -> Q Info
reify Name
gadt
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q [Dec]) -> [Con] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Con -> Q [Dec]
makeInst Name
wrap) [Con]
cons
makeInst :: Name -> Con -> Q [Dec]
makeInst :: Name -> Con -> Q [Dec]
makeInst Name
wrap (GadtC [Name
sConstructor] [BangType]
args Kind
t) = do
[Name]
ns <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args) (String -> Q Name
newName String
"x")
let wrappedPat :: PatQ
wrappedPat = Name -> [PatQ] -> PatQ
conP Name
wrap [Name -> [PatQ] -> PatQ
conP Name
sConstructor ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ns)]
unwrappedE :: Q Exp
unwrappedE = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
sConstructor) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
ns)
[d| instance FromJSON $(pure t) where
parseJSON = parseJSON >=> \case
$wrappedPat -> pure $unwrappedE
_ -> mempty
|]
makeInst Name
wrap (ForallC [TyVarBndr]
_ Cxt
_ Con
con) = Name -> Con -> Q [Dec]
makeInst Name
wrap Con
con
makeInst Name
_ Con
_ = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeInst only defined for GADT constructors"
makeRegHelper :: Name -> DecsQ
makeRegHelper :: Name -> Q [Dec]
makeRegHelper Name
regOptTypeName = do
Just Name
sMethodTypeName <- String -> Q (Maybe Name)
lookupTypeName String
"SMethod"
Just Name
fromClientName <- String -> Q (Maybe Name)
lookupValueName String
"FromClient"
TyConI (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con]
allCons [DerivClause]
_) <- Name -> Q Info
reify Name
sMethodTypeName
let isConsFromClient :: Con -> Q Bool
isConsFromClient (GadtC [Name]
_ [BangType]
_ (AppT Kind
_ Kind
method)) = Kind -> Q Bool
isMethodFromClient Kind
method
isConsFromClient Con
_ = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isMethodFromClient :: Type -> Q Bool
isMethodFromClient :: Kind -> Q Bool
isMethodFromClient (PromotedT Name
method) = do
DataConI Name
_ Kind
typ Name
_ <- Name -> Q Info
reify Name
method
case Kind
typ of
AppT (AppT Kind
_ (PromotedT Name
n)) Kind
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fromClientName
Kind
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isMethodFromClient Kind
_ = String -> Q Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Didn't expect this type of Method!"
[Con]
cons <- (Con -> Q Bool) -> [Con] -> Q [Con]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Con -> Q Bool
isConsFromClient [Con]
allCons
let conNames :: [Name]
conNames = (Con -> Name) -> [Con] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(GadtC [Name
name] [BangType]
_ Kind
_) -> Name
name) [Con]
cons
helperName :: Name
helperName = String -> Name
mkName String
"regHelper"
mkClause :: Name -> Q Clause
mkClause Name
name = do
Name
x <- String -> Q Name
newName String
"x"
[PatQ] -> BodyQ -> [DecQ] -> Q Clause
clause [ Name -> [PatQ] -> PatQ
conP Name
name [], Name -> PatQ
varP Name
x ]
(Q Exp -> BodyQ
normalB (Name -> Q Exp
varE Name
x))
[]
regOptTcon :: TypeQ
regOptTcon = Name -> TypeQ
conT Name
regOptTypeName
Dec
fun <- Name -> [Q Clause] -> DecQ
funD Name
helperName ((Name -> Q Clause) -> [Name] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Clause
mkClause [Name]
conNames)
Dec
typSig <- Name -> TypeQ -> DecQ
sigD Name
helperName (TypeQ -> DecQ) -> TypeQ -> DecQ
forall a b. (a -> b) -> a -> b
$
[t| forall m x. $(conT sMethodTypeName) m
-> (Show ($regOptTcon m) => ToJSON ($regOptTcon m) => FromJSON ($regOptTcon m) => x)
-> x |]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
typSig, Dec
fun]
makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> DecsQ
makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> Q [Dec]
makeExtendingDatatype String
datatypeNameStr [Name]
extends [(String, TypeQ)]
fields = do
[VarBangType]
extendFields <- ([[VarBangType]] -> [VarBangType])
-> Q [[VarBangType]] -> Q [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[VarBangType]] -> [VarBangType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[VarBangType]] -> Q [VarBangType])
-> Q [[VarBangType]] -> Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ [Name] -> (Name -> Q [VarBangType]) -> Q [[VarBangType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
extends ((Name -> Q [VarBangType]) -> Q [[VarBangType]])
-> (Name -> Q [VarBangType]) -> Q [[VarBangType]]
forall a b. (a -> b) -> a -> b
$ \Name
e -> do
TyConI (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [RecC Name
_ [VarBangType]
eFields] [DerivClause]
_) <- Name -> Q Info
reify Name
e
[VarBangType] -> Q [VarBangType]
forall (m :: * -> *) a. Monad m => a -> m a
return [VarBangType]
eFields
let datatypeName :: Name
datatypeName = String -> Name
mkName String
datatypeNameStr
insts :: [TypeQ]
insts = [[t| Read |], [t| Show |], [t| Eq |]]
constructor :: ConQ
constructor = Name -> [VarBangTypeQ] -> ConQ
recC Name
datatypeName [VarBangTypeQ]
combinedFields
userFields :: [VarBangTypeQ]
userFields = (((String, TypeQ) -> VarBangTypeQ)
-> [(String, TypeQ)] -> [VarBangTypeQ])
-> [(String, TypeQ)]
-> ((String, TypeQ) -> VarBangTypeQ)
-> [VarBangTypeQ]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, TypeQ) -> VarBangTypeQ)
-> [(String, TypeQ)] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map [(String, TypeQ)]
fields (((String, TypeQ) -> VarBangTypeQ) -> [VarBangTypeQ])
-> ((String, TypeQ) -> VarBangTypeQ) -> [VarBangTypeQ]
forall a b. (a -> b) -> a -> b
$ \(String
s, TypeQ
typ) -> do
Name -> BangTypeQ -> VarBangTypeQ
varBangType (String -> Name
mkName String
s) (BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) TypeQ
typ)
combinedFields :: [VarBangTypeQ]
combinedFields = ((VarBangType -> VarBangTypeQ) -> [VarBangType] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> VarBangTypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [VarBangType]
extendFields) [VarBangTypeQ] -> [VarBangTypeQ] -> [VarBangTypeQ]
forall a. Semigroup a => a -> a -> a
<> [VarBangTypeQ]
userFields
derivs :: [DerivClauseQ]
derivs = [Maybe DerivStrategy -> [TypeQ] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [TypeQ]
insts]
(\Dec
a -> [Dec
a]) (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([TypeQ] -> CxtQ
cxt []) Name
datatypeName [] Maybe Kind
forall a. Maybe a
Nothing [ConQ
constructor] [DerivClauseQ]
derivs
lspOptions :: Options
lspOptions :: Options
lspOptions = Options
defaultOptions { omitNothingFields :: Bool
omitNothingFields = Bool
True, fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
modifier }
where
modifier :: String -> String
modifier :: String -> String
modifier String
"_xdata" = String
"data"
modifier String
"_xtype" = String
"type"
modifier String
xs = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
xs
lspOptionsUntagged :: Options
lspOptionsUntagged :: Options
lspOptionsUntagged = Options
lspOptions { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue }