{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.LSP.Protocol.Utils.Misc (
rdrop,
makeSingletonFromJSON,
makeRegHelper,
lspOptions,
lspOptionsUntagged,
prettyJSON,
ViaJSON (..),
genLenses,
) where
import Control.Lens.Internal.FieldTH
import Control.Lens.TH
import Control.Monad
import Control.Monad.State
import Data.Aeson
import Data.Aeson.Text as Aeson
import Data.Foldable qualified as F
import Data.Foldable.WithIndex qualified as F
import Data.Functor.WithIndex.Instances qualified ()
import Data.List hiding (group)
import Data.Maybe (mapMaybe)
import Language.Haskell.TH as TH
import Prettyprinter
rdrop :: Int -> [a] -> [a]
rdrop :: forall a. 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 -> [Name] -> Q [Dec]
makeSingletonFromJSON :: Name -> Name -> [Name] -> Q [Dec]
makeSingletonFromJSON Name
wrap Name
gadt [Name]
skip = 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
<$> ([Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (Con -> Maybe (Q [Dec])) -> [Con] -> [Q [Dec]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst Name
wrap [Name]
skip) [Con]
cons)
makeInst :: Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst :: Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst Name
_ [Name]
skip (GadtC [Name
sConstructor] [BangType]
_ Kind
_) | Name
sConstructor Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
skip = Maybe (Q [Dec])
forall a. Maybe a
Nothing
makeInst Name
wrap [Name]
_ (GadtC [Name
sConstructor] [BangType]
args Kind
t) = Q [Dec] -> Maybe (Q [Dec])
forall a. a -> Maybe a
Just (Q [Dec] -> Maybe (Q [Dec])) -> Q [Dec] -> Maybe (Q [Dec])
forall a b. (a -> b) -> a -> b
$ do
[Name]
ns <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
let wrappedPat :: Q Pat
wrappedPat = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
wrap [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
sConstructor ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)]
unwrappedE :: Q Exp
unwrappedE = Exp -> Q Exp
forall a. a -> Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 $(Kind -> Q Kind
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t) where
parseJSON =
parseJSON >=> \case
$Q Pat
wrappedPat -> pure $Q Exp
unwrappedE
_ -> mempty
|]
makeInst Name
wrap [Name]
skip (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst Name
wrap [Name]
skip Con
con
makeInst Name
_ [Name]
_ Con
_ = Q [Dec] -> Maybe (Q [Dec])
forall a. a -> Maybe a
Just (Q [Dec] -> Maybe (Q [Dec])) -> Q [Dec] -> Maybe (Q [Dec])
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. String -> Q a
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
"ClientToServer"
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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isMethodFromClient Kind
_ = String -> Q Bool
forall a. String -> Q a
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 -> Maybe Name) -> [Con] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (GadtC [Name
name] [BangType]
_ Kind
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name; Con
_ -> Maybe Name
forall a. Maybe a
Nothing) [Con]
cons
helperName :: Name
helperName = String -> Name
mkName String
"regHelper"
mkClause :: Name -> m Clause
mkClause Name
name = do
Name
x <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name [], Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]
(m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x))
[]
regOptTcon :: Q Kind
regOptTcon = Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
regOptTypeName
Dec
fun <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
helperName ((Name -> Q Clause) -> [Name] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Clause
forall {m :: * -> *}. Quote m => Name -> m Clause
mkClause [Name]
conNames)
Dec
typSig <-
Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
helperName (Q Kind -> Q Dec) -> Q Kind -> Q Dec
forall a b. (a -> b) -> a -> b
$
[t|
forall m x.
$(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
sMethodTypeName) m ->
(Show ($Q Kind
regOptTcon m) => ToJSON ($Q Kind
regOptTcon m) => FromJSON ($Q Kind
regOptTcon m) => x) ->
x
|]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
typSig, Dec
fun]
lspOptions :: Options
lspOptions :: Options
lspOptions = Options
defaultOptions{omitNothingFields = True, fieldLabelModifier = 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 = UntaggedValue}
prettyJSON :: Value -> Doc ann
prettyJSON :: forall ann. Value -> Doc ann
prettyJSON = \case
Array Array
vec ->
let docs :: [Doc ann]
docs = (Value -> Doc ann) -> [Value] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Array
vec)
separator :: Doc ann
separator = Doc ann
","
in Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
separator [Doc ann]
docs)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
Object Object
km ->
let docs :: [Doc ann]
docs = ((Key, Value) -> Doc ann) -> [(Key, Value)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Key
k, Value
v) -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Key -> String
forall a. Show a => a -> String
show Key
k) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON Value
v) (Object -> [(Key, Value)]
forall i (f :: * -> *) a. FoldableWithIndex i f => f a -> [(i, a)]
F.itoList Object
km)
separator :: Doc ann
separator = Doc ann
","
in Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann
"{" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
separator [Doc ann]
docs)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"}"
Value
v -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Value -> Text
forall a. ToJSON a => a -> Text
Aeson.encodeToLazyText Value
v
newtype ViaJSON a = ViaJSON a
instance ToJSON a => Pretty (ViaJSON a) where
pretty :: forall ann. ViaJSON a -> Doc ann
pretty (ViaJSON a
a) = Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON (Value -> Doc ann) -> Value -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
genLenses :: [TH.Name] -> TH.Q [TH.Dec]
genLenses :: [Name] -> Q [Dec]
genLenses [Name]
names = do
let
opticMaker :: TH.Name -> HasFieldClasses [TH.Dec]
opticMaker :: Name -> HasFieldClasses [Dec]
opticMaker Name
n = do
(TH.TyConI Dec
d) <- Q Info -> StateT (Set Name) Q Info
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> StateT (Set Name) Q Info)
-> Q Info -> StateT (Set Name) Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
TH.reify Name
n
LensRules -> Dec -> HasFieldClasses [Dec]
makeFieldOpticsForDec' LensRules
classUnderscoreNoPrefixFields Dec
d
[[Dec]]
decss <- (StateT (Set Name) Q [[Dec]] -> Set Name -> Q [[Dec]])
-> Set Name -> StateT (Set Name) Q [[Dec]] -> Q [[Dec]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Set Name) Q [[Dec]] -> Set Name -> Q [[Dec]]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Set Name
forall a. Monoid a => a
mempty (StateT (Set Name) Q [[Dec]] -> Q [[Dec]])
-> StateT (Set Name) Q [[Dec]] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (Name -> HasFieldClasses [Dec])
-> [Name] -> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Name -> HasFieldClasses [Dec]
opticMaker [Name]
names
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss