{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.LSP.Protocol.Utils.Misc (
  rdrop,
  makeSingletonFromJSON,
  makeRegHelper,
  lspOptions,
  lspOptionsUntagged,
  prettyJSON,
  ViaJSON (..),
) where

import Control.Monad
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
import Prettyprinter

-- ---------------------------------------------------------------------

rdrop :: Int -> [a] -> [a]
rdrop :: forall a. Int -> [a] -> [a]
rdrop Int
cnt = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
cnt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

{- | Given a wrapper and a singleton GADT, construct FromJSON
 instances for each constructor return type by invoking the
 FromJSON instance for the wrapper and unwrapping
-}
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
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst Name
wrap [Name]
skip) [Con]
cons)

{-
instance FromJSON (SMethod $method) where
  parseJSON = parseJSON >=> \case
      SomeMethod $singleton-method -> pure $singleton-method
      _ -> mempty
-}
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
skip = forall a. Maybe a
Nothing
makeInst Name
wrap [Name]
_ (GadtC [Name
sConstructor] [BangType]
args Kind
t) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
  [Name]
ns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
  let wrappedPat :: Q Pat
wrappedPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
wrap [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
sConstructor (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)]
      unwrappedE :: Q Exp
unwrappedE = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> 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) (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 [Name]
skip (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Name -> [Name] -> Con -> Maybe (Q [Dec])
makeInst Name
wrap [Name]
skip Con
con -- Cancel and Custom requests
makeInst Name
_ [Name]
_ Con
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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
_ = 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
n forall a. Eq a => a -> a -> Bool
== Name
fromClientName
          Kind
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      isMethodFromClient Kind
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Didn't expect this type of Method!"

  [Con]
cons <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Con -> Q Bool
isConsFromClient [Con]
allCons

  let conNames :: [Name]
conNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (GadtC [Name
name] [BangType]
_ Kind
_) -> forall a. a -> Maybe a
Just Name
name; Con
_ -> 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
          [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x))
          []
      regOptTcon :: Q Kind
regOptTcon = forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
regOptTypeName
  Dec
fun <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
helperName (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. Quote m => Name -> m Clause
mkClause [Name]
conNames)

  Dec
typSig <-
    forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
helperName 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
        |]
  forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
typSig, Dec
fun]

{- | Standard options for use when generating JSON instances
 NOTE: This needs to be in a separate file because of the TH stage restriction
-}
lspOptions :: Options
lspOptions :: Options
lspOptions = Options
defaultOptions{omitNothingFields :: Bool
omitNothingFields = Bool
True, fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
modifier}
 where
  modifier :: String -> String
  -- For fields called data and type in the spec, we call them xdata and xtype
  -- in haskell-lsp-types to avoid it clashing with the Haskell keywords. This
  -- fixes up the json derivation
  modifier :: String -> String
modifier String
"_xdata" = String
"data"
  modifier String
"_xtype" = String
"type"
  modifier String
xs = forall a. Int -> [a] -> [a]
drop Int
1 String
xs

-- | Standard options for use when generating JSON instances for an untagged union
lspOptionsUntagged :: Options
lspOptionsUntagged :: Options
lspOptionsUntagged = Options
lspOptions{sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue}

prettyJSON :: Value -> Doc ann
prettyJSON :: forall ann. Value -> Doc ann
prettyJSON = \case
  Array Array
vec ->
    let docs :: [Doc ann]
docs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ann. Value -> Doc ann
prettyJSON (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Array
vec)
        separator :: Doc ann
separator = Doc ann
","
     in forall ann. Doc ann -> Doc ann
group forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann
"[" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
separator [Doc ann]
docs)) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
  Object Object
km ->
    let docs :: [Doc ann]
docs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Key
k, Value
v) -> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show Key
k) forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Value -> Doc ann
prettyJSON Value
v) (forall i (f :: * -> *) a. FoldableWithIndex i f => f a -> [(i, a)]
F.itoList Object
km)
        separator :: Doc ann
separator = Doc ann
","
     in forall ann. Doc ann -> Doc ann
group forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann
"{" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
separator [Doc ann]
docs)) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> Doc ann
"}"
  -- for atomic objects, piggyback off aeson's encoding
  Value
v -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ 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) = forall ann. Value -> Doc ann
prettyJSON forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON a
a