{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TypeOperators              #-}

-- | Common types that aren't in the specification
module Language.LSP.Protocol.Types.Common (
    type (|?) (..)
  , toEither
  , _L
  , _R
  , Int32
  , UInt
  , Null (..)
  , absorbNull
  , nullToMaybe
  , maybeToNull
  , (.=?)
) where

import           Control.DeepSeq
import           Control.Lens
import           Data.Aeson          hiding (Null)
import qualified Data.Aeson          as J
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap   as KM
#else
import qualified Data.HashMap.Strict   as KM
#endif
import           Data.Hashable
import           Data.Set            as Set
import           Data.String         (fromString)
import           Data.Int            (Int32)
import           Data.Mod.Word
import           GHC.Generics        hiding (UInt)
import           GHC.TypeNats        hiding (Mod)
import           Text.Read           (Read (readPrec))

-- | The "uinteger" type in the LSP spec.
--
-- Unusually, this is a **31**-bit unsigned integer, not a 32-bit one.
newtype UInt = UInt (Mod (2^31))
  deriving newtype (Integer -> UInt
UInt -> UInt
UInt -> UInt -> UInt
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> UInt
$cfromInteger :: Integer -> UInt
signum :: UInt -> UInt
$csignum :: UInt -> UInt
abs :: UInt -> UInt
$cabs :: UInt -> UInt
negate :: UInt -> UInt
$cnegate :: UInt -> UInt
* :: UInt -> UInt -> UInt
$c* :: UInt -> UInt -> UInt
- :: UInt -> UInt -> UInt
$c- :: UInt -> UInt -> UInt
+ :: UInt -> UInt -> UInt
$c+ :: UInt -> UInt -> UInt
Num, UInt
forall a. a -> a -> Bounded a
maxBound :: UInt
$cmaxBound :: UInt
minBound :: UInt
$cminBound :: UInt
Bounded, Int -> UInt
UInt -> Int
UInt -> [UInt]
UInt -> UInt
UInt -> UInt -> [UInt]
UInt -> UInt -> UInt -> [UInt]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: UInt -> UInt -> UInt -> [UInt]
$cenumFromThenTo :: UInt -> UInt -> UInt -> [UInt]
enumFromTo :: UInt -> UInt -> [UInt]
$cenumFromTo :: UInt -> UInt -> [UInt]
enumFromThen :: UInt -> UInt -> [UInt]
$cenumFromThen :: UInt -> UInt -> [UInt]
enumFrom :: UInt -> [UInt]
$cenumFrom :: UInt -> [UInt]
fromEnum :: UInt -> Int
$cfromEnum :: UInt -> Int
toEnum :: Int -> UInt
$ctoEnum :: Int -> UInt
pred :: UInt -> UInt
$cpred :: UInt -> UInt
succ :: UInt -> UInt
$csucc :: UInt -> UInt
Enum, UInt -> UInt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UInt -> UInt -> Bool
$c/= :: UInt -> UInt -> Bool
== :: UInt -> UInt -> Bool
$c== :: UInt -> UInt -> Bool
Eq, Eq UInt
UInt -> UInt -> Bool
UInt -> UInt -> Ordering
UInt -> UInt -> UInt
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UInt -> UInt -> UInt
$cmin :: UInt -> UInt -> UInt
max :: UInt -> UInt -> UInt
$cmax :: UInt -> UInt -> UInt
>= :: UInt -> UInt -> Bool
$c>= :: UInt -> UInt -> Bool
> :: UInt -> UInt -> Bool
$c> :: UInt -> UInt -> Bool
<= :: UInt -> UInt -> Bool
$c<= :: UInt -> UInt -> Bool
< :: UInt -> UInt -> Bool
$c< :: UInt -> UInt -> Bool
compare :: UInt -> UInt -> Ordering
$ccompare :: UInt -> UInt -> Ordering
Ord)
  deriving stock (forall x. Rep UInt x -> UInt
forall x. UInt -> Rep UInt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UInt x -> UInt
$cfrom :: forall x. UInt -> Rep UInt x
Generic)
  deriving anyclass (UInt -> ()
forall a. (a -> ()) -> NFData a
rnf :: UInt -> ()
$crnf :: UInt -> ()
NFData)

instance Hashable UInt where hashWithSalt :: Int -> UInt -> Int
hashWithSalt Int
s (UInt Mod (2 ^ 31)
n) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
n)

instance Show UInt where
  show :: UInt -> String
show (UInt Mod (2 ^ 31)
u) = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
u

instance Read UInt where
  readPrec :: ReadPrec UInt
readPrec = forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => ReadPrec a
readPrec

instance Real UInt where
  toRational :: UInt -> Rational
toRational (UInt Mod (2 ^ 31)
u) = forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
u

instance Integral UInt where
  quotRem :: UInt -> UInt -> (UInt, UInt)
quotRem (UInt Mod (2 ^ 31)
x) (UInt Mod (2 ^ 31)
y) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> a -> (a, a)
quotRem (forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
x) (forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
y)
  toInteger :: UInt -> Integer
toInteger (UInt Mod (2 ^ 31)
u) = forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall (m :: Nat). Mod m -> Word
unMod Mod (2 ^ 31)
u

instance ToJSON UInt where
  toJSON :: UInt -> Value
toJSON UInt
u = forall a. ToJSON a => a -> Value
toJSON (forall a. Integral a => a -> Integer
toInteger UInt
u)

instance FromJSON UInt where
  parseJSON :: Value -> Parser UInt
parseJSON Value
v = forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | An alternative type (isomorphic to 'Either'), but which
-- is encoded into JSON without a tag for the alternative.
--
-- This corresponds to @a | b@ types in the LSP specification.
data a |? b = InL a
            | InR b
  deriving stock (ReadPrec [a |? b]
ReadPrec (a |? b)
ReadS [a |? b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [a |? b]
forall a b. (Read a, Read b) => ReadPrec (a |? b)
forall a b. (Read a, Read b) => Int -> ReadS (a |? b)
forall a b. (Read a, Read b) => ReadS [a |? b]
readListPrec :: ReadPrec [a |? b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [a |? b]
readPrec :: ReadPrec (a |? b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (a |? b)
readList :: ReadS [a |? b]
$creadList :: forall a b. (Read a, Read b) => ReadS [a |? b]
readsPrec :: Int -> ReadS (a |? b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (a |? b)
Read, Int -> (a |? b) -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> (a |? b) -> ShowS
forall a b. (Show a, Show b) => [a |? b] -> ShowS
forall a b. (Show a, Show b) => (a |? b) -> String
showList :: [a |? b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [a |? b] -> ShowS
show :: (a |? b) -> String
$cshow :: forall a b. (Show a, Show b) => (a |? b) -> String
showsPrec :: Int -> (a |? b) -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> (a |? b) -> ShowS
Show, (a |? b) -> (a |? b) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => (a |? b) -> (a |? b) -> Bool
/= :: (a |? b) -> (a |? b) -> Bool
$c/= :: forall a b. (Eq a, Eq b) => (a |? b) -> (a |? b) -> Bool
== :: (a |? b) -> (a |? b) -> Bool
$c== :: forall a b. (Eq a, Eq b) => (a |? b) -> (a |? b) -> Bool
Eq, (a |? b) -> (a |? b) -> Bool
(a |? b) -> (a |? b) -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. (Ord a, Ord b) => Eq (a |? b)
forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Bool
forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Ordering
forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> a |? b
min :: (a |? b) -> (a |? b) -> a |? b
$cmin :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> a |? b
max :: (a |? b) -> (a |? b) -> a |? b
$cmax :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> a |? b
>= :: (a |? b) -> (a |? b) -> Bool
$c>= :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Bool
> :: (a |? b) -> (a |? b) -> Bool
$c> :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Bool
<= :: (a |? b) -> (a |? b) -> Bool
$c<= :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Bool
< :: (a |? b) -> (a |? b) -> Bool
$c< :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Bool
compare :: (a |? b) -> (a |? b) -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => (a |? b) -> (a |? b) -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (a |? b) x -> a |? b
forall a b x. (a |? b) -> Rep (a |? b) x
$cto :: forall a b x. Rep (a |? b) x -> a |? b
$cfrom :: forall a b x. (a |? b) -> Rep (a |? b) x
Generic)
  deriving anyclass (forall a. (a -> ()) -> NFData a
forall a b. (NFData a, NFData b) => (a |? b) -> ()
rnf :: (a |? b) -> ()
$crnf :: forall a b. (NFData a, NFData b) => (a |? b) -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {a} {b}. (Hashable a, Hashable b) => Eq (a |? b)
forall a b. (Hashable a, Hashable b) => Int -> (a |? b) -> Int
forall a b. (Hashable a, Hashable b) => (a |? b) -> Int
hash :: (a |? b) -> Int
$chash :: forall a b. (Hashable a, Hashable b) => (a |? b) -> Int
hashWithSalt :: Int -> (a |? b) -> Int
$chashWithSalt :: forall a b. (Hashable a, Hashable b) => Int -> (a |? b) -> Int
Hashable)
infixr |?

-- | Prism for the left-hand side of an '(|?)'.
_L :: Prism' (a |? b) a
_L :: forall a b. Prism' (a |? b) a
_L = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ \case
  InL a
a -> forall a. a -> Maybe a
Just a
a
  InR b
_ -> forall a. Maybe a
Nothing

-- | Prism for the right-hand side of an '(|?)'.
_R :: Prism' (a |? b) b
_R :: forall a b. Prism' (a |? b) b
_R = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ \case
  InL a
_ -> forall a. Maybe a
Nothing
  InR b
b -> forall a. a -> Maybe a
Just b
b

toEither :: a |? b -> Either a b
toEither :: forall a b. (a |? b) -> Either a b
toEither (InL a
a) = forall a b. a -> Either a b
Left a
a
toEither (InR b
b) = forall a b. b -> Either a b
Right b
b

instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where
  toJSON :: (a |? b) -> Value
toJSON (InL a
x) = forall a. ToJSON a => a -> Value
toJSON a
x
  toJSON (InR b
x) = forall a. ToJSON a => a -> Value
toJSON b
x

instance (FromJSON a, ToJSON a, FromJSON b, ToJSON b) => FromJSON (a |? b) where
  -- Truly atrocious and abominable hack. The issue is tha we may have siutations
  -- where some input JSON can parse correctly as both sides of the union, because
  -- we have no tag. What do we do in this situation? It's very unclear, and the
  -- spec is no help. The heuristic we adopt here is that it is better to take
  -- the version with "more fields". How do we work that out? By converting back
  -- to JSON and looking at the object fields.
  --
  -- Possibly we could do better by relying on Generic instances for a and b
  -- in order to work out which has more fields on the Haskell side.
  parseJSON :: Value -> Parser (a |? b)
parseJSON Value
v = do
    let Result a
ra :: Result a = forall a. FromJSON a => Value -> Result a
fromJSON Value
v
        Result b
rb :: Result b = forall a. FromJSON a => Value -> Result a
fromJSON Value
v
    case (Result a
ra, Result b
rb) of
      (Success a
a, Error String
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL a
a
      (Error String
_, Success b
b) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR b
b
      (Error String
e, Error String
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      (Success a
a, Success b
b) -> case (forall a. ToJSON a => a -> Value
toJSON a
a, forall a. ToJSON a => a -> Value
toJSON b
b) of
        -- Both sides encode to the same thing, just pick one arbitrarily
        (Value
l, Value
r) | Value
l forall a. Eq a => a -> a -> Bool
== Value
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL a
a
        (Object Object
oa, Object Object
ob) -> 
          let ka :: Set Key
ka = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [Key]
KM.keys Object
oa
              kb :: Set Key
kb = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [Key]
KM.keys Object
ob
          in if Set Key
kb forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Key
ka
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL a
a
          else if Set Key
ka forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Key
kb
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR b
b
          else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not decide which type of value to produce, left encodes to an object with keys: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Set Key
ka forall a. [a] -> [a] -> [a]
++ String
"; right has keys " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Set Key
kb
        (Value
l, Value
r) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not decide which type of value to produce, left encodes to: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
l forall a. [a] -> [a] -> [a]
++ String
"; right encodes to: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
r

-- We could use 'Proxy' for this, as aeson also serializes it to/from null,
-- but this is more explicit.
-- | A type for that is precisely null and nothing else.
--
-- This is useful since the LSP specification often includes types like @a | null@
-- as distinct from an optional value of type @a@.
data Null = Null
  deriving stock (Null -> Null -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Null -> Null -> Bool
$c/= :: Null -> Null -> Bool
== :: Null -> Null -> Bool
$c== :: Null -> Null -> Bool
Eq, Eq Null
Null -> Null -> Bool
Null -> Null -> Ordering
Null -> Null -> Null
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Null -> Null -> Null
$cmin :: Null -> Null -> Null
max :: Null -> Null -> Null
$cmax :: Null -> Null -> Null
>= :: Null -> Null -> Bool
$c>= :: Null -> Null -> Bool
> :: Null -> Null -> Bool
$c> :: Null -> Null -> Bool
<= :: Null -> Null -> Bool
$c<= :: Null -> Null -> Bool
< :: Null -> Null -> Bool
$c< :: Null -> Null -> Bool
compare :: Null -> Null -> Ordering
$ccompare :: Null -> Null -> Ordering
Ord, Int -> Null -> ShowS
[Null] -> ShowS
Null -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Null] -> ShowS
$cshowList :: [Null] -> ShowS
show :: Null -> String
$cshow :: Null -> String
showsPrec :: Int -> Null -> ShowS
$cshowsPrec :: Int -> Null -> ShowS
Show, forall x. Rep Null x -> Null
forall x. Null -> Rep Null x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Null x -> Null
$cfrom :: forall x. Null -> Rep Null x
Generic)
  deriving anyclass (Null -> ()
forall a. (a -> ()) -> NFData a
rnf :: Null -> ()
$crnf :: Null -> ()
NFData, Eq Null
Int -> Null -> Int
Null -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Null -> Int
$chash :: Null -> Int
hashWithSalt :: Int -> Null -> Int
$chashWithSalt :: Int -> Null -> Int
Hashable)

instance ToJSON Null where
  toJSON :: Null -> Value
toJSON Null
Null = Value
J.Null
instance FromJSON Null where
  parseJSON :: Value -> Parser Null
parseJSON Value
J.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure Null
Null
  parseJSON Value
_      = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected 'null'"

absorbNull :: Monoid a => a |? Null -> a
absorbNull :: forall a. Monoid a => (a |? Null) -> a
absorbNull (InL a
a) = a
a
absorbNull (InR Null
_) = forall a. Monoid a => a
mempty

nullToMaybe :: a |? Null -> Maybe a
nullToMaybe :: forall a. (a |? Null) -> Maybe a
nullToMaybe (InL a
a) = forall a. a -> Maybe a
Just a
a
nullToMaybe (InR Null
_) = forall a. Maybe a
Nothing

maybeToNull :: Maybe a -> a |? Null
maybeToNull :: forall a. Maybe a -> a |? Null
maybeToNull (Just a
x) = forall a b. a -> a |? b
InL a
x
maybeToNull Maybe a
Nothing  = forall a b. b -> a |? b
InR Null
Null

-- This is equivalent to the instance for 'Maybe s'
instance Semigroup s => Semigroup (s |? Null) where
  InL s
x <> :: (s |? Null) -> (s |? Null) -> s |? Null
<> InL s
y = forall a b. a -> a |? b
InL (s
x forall a. Semigroup a => a -> a -> a
<> s
y)
  InL s
x <> InR Null
_ = forall a b. a -> a |? b
InL s
x
  InR Null
_ <> InL s
x = forall a b. a -> a |? b
InL s
x
  InR Null
_ <> InR Null
y = forall a b. b -> a |? b
InR Null
y

  -- We use String so we can use fromString on it to get a key that works
  -- in both aeson-1 and aeson-2
-- | Include a value in an JSON object optionally, omitting it if it is 'Nothing'.
(.=?) :: (J.KeyValue kv, J.ToJSON v) => String -> Maybe v -> [kv]
String
k .=? :: forall kv v. (KeyValue kv, ToJSON v) => String -> Maybe v -> [kv]
.=? Maybe v
v = case Maybe v
v of
  Just v
v' -> [forall a. IsString a => String -> a
fromString String
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= v
v']
  Maybe v
Nothing -> forall a. Monoid a => a
mempty