{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Language.LSP.Hover (
  showHoverInfo,

  -- * Documentation rendering
  renderDoc,
  treeToMarkdown,

  -- * Finding source location
  narrowToPosition,

  -- * Explaining source position
  explain,
) where

import Control.Applicative ((<|>))
import Control.Lens ((^.))
import Control.Monad (guard, void)
import Data.Foldable (asum)
import Data.Graph
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map qualified as M
import Data.Maybe (catMaybes, fromMaybe, isNothing)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lines qualified as R
import Data.Text.Utf16.Rope.Mixed qualified as R
import Language.LSP.Protocol.Types qualified as J
import Language.LSP.VFS
import Swarm.Language.Parser (readTerm')
import Swarm.Language.Parser.Core (defaultParserConfig)
import Swarm.Language.Pipeline (processParsedTerm)
import Swarm.Language.Syntax
import Swarm.Language.TDVar (tdVarName)
import Swarm.Language.Typecheck (inferConst)
import Swarm.Language.Types
import Swarm.Pretty (prettyText, prettyTextLine)
import Swarm.Util qualified as U

withinBound :: Int -> SrcLoc -> Bool
withinBound :: Int -> SrcLoc -> Bool
withinBound Int
pos (SrcLoc Int
s Int
e) = Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
s Bool -> Bool -> Bool
&& Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
e
withinBound Int
_ SrcLoc
NoLoc = Bool
False

ropeToLspPosition :: R.Position -> J.Position
ropeToLspPosition :: Position -> Position
ropeToLspPosition (R.Position Word
l Word
c) =
  UInt -> UInt -> Position
J.Position (Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
l) (Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
c)

lspToRopePosition :: J.Position -> R.Position
lspToRopePosition :: Position -> Position
lspToRopePosition (J.Position UInt
myLine UInt
myCol) =
  Word -> Word -> Position
R.Position (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
myLine) (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
myCol)

showHoverInfo ::
  J.NormalizedUri ->
  J.Position ->
  VirtualFile ->
  Maybe (Text, Maybe J.Range)
showHoverInfo :: NormalizedUri
-> Position -> VirtualFile -> Maybe (Text, Maybe Range)
showHoverInfo NormalizedUri
_ Position
p vf :: VirtualFile
vf@(VirtualFile Int32
_ Int
_ Rope
myRope) =
  (ParserError -> Maybe (Text, Maybe Range))
-> (Maybe Syntax -> Maybe (Text, Maybe Range))
-> Either ParserError (Maybe Syntax)
-> Maybe (Text, Maybe Range)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Text, Maybe Range)
-> ParserError -> Maybe (Text, Maybe Range)
forall a b. a -> b -> a
const Maybe (Text, Maybe Range)
forall a. Maybe a
Nothing) ((Syntax -> (Text, Maybe Range))
-> Maybe Syntax -> Maybe (Text, Maybe Range)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Syntax -> (Text, Maybe Range)
genHoverInfo) (ParserConfig -> Text -> Either ParserError (Maybe Syntax)
readTerm' ParserConfig
defaultParserConfig Text
content)
 where
  content :: Text
content = VirtualFile -> Text
virtualFileText VirtualFile
vf
  absolutePos :: Word
absolutePos =
    Rope -> Word
R.charLength (Rope -> Word) -> ((Rope, Rope) -> Rope) -> (Rope, Rope) -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rope, Rope) -> Rope
forall a b. (a, b) -> a
fst ((Rope, Rope) -> Word) -> (Rope, Rope) -> Word
forall a b. (a -> b) -> a -> b
$ Position -> Rope -> (Rope, Rope)
R.charSplitAtPosition (Position -> Position
lspToRopePosition Position
p) Rope
myRope

  genHoverInfo :: Syntax -> (Text, Maybe Range)
genHoverInfo Syntax
stx =
    case Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm Syntax
stx of
      Left ContextualTypeErr
_e ->
        let found :: Syntax
found = Syntax -> Int -> Syntax
forall ty. ExplainableType ty => Syntax' ty -> Int -> Syntax' ty
narrowToPosition Syntax
stx (Int -> Syntax) -> Int -> Syntax
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
absolutePos
            finalPos :: Maybe Range
finalPos = Rope -> SrcLoc -> Maybe Range
posToRange Rope
myRope (Syntax
found Syntax -> Getting SrcLoc Syntax SrcLoc -> SrcLoc
forall s a. s -> Getting a s a -> a
^. Getting SrcLoc Syntax SrcLoc
forall ty (f :: * -> *).
Functor f =>
(SrcLoc -> f SrcLoc) -> Syntax' ty -> f (Syntax' ty)
sLoc)
         in (,Maybe Range
finalPos) (Text -> (Text, Maybe Range))
-> (Tree Text -> Text) -> Tree Text -> (Text, Maybe Range)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Tree Text -> Text
treeToMarkdown Int
0 (Tree Text -> (Text, Maybe Range))
-> Tree Text -> (Text, Maybe Range)
forall a b. (a -> b) -> a -> b
$ Syntax -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax
found
      Right TSyntax
pt ->
        let found :: TSyntax
found =
              TSyntax -> Int -> TSyntax
forall ty. ExplainableType ty => Syntax' ty -> Int -> Syntax' ty
narrowToPosition TSyntax
pt (Int -> TSyntax) -> Int -> TSyntax
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
absolutePos
            finalPos :: Maybe Range
finalPos = Rope -> SrcLoc -> Maybe Range
posToRange Rope
myRope (TSyntax
found TSyntax -> Getting SrcLoc TSyntax SrcLoc -> SrcLoc
forall s a. s -> Getting a s a -> a
^. Getting SrcLoc TSyntax SrcLoc
forall ty (f :: * -> *).
Functor f =>
(SrcLoc -> f SrcLoc) -> Syntax' ty -> f (Syntax' ty)
sLoc)
         in (,Maybe Range
finalPos) (Text -> (Text, Maybe Range))
-> (Tree Text -> Text) -> Tree Text -> (Text, Maybe Range)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Tree Text -> Text
treeToMarkdown Int
0 (Tree Text -> (Text, Maybe Range))
-> Tree Text -> (Text, Maybe Range)
forall a b. (a -> b) -> a -> b
$ TSyntax -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain TSyntax
found

posToRange :: R.Rope -> SrcLoc -> Maybe J.Range
posToRange :: Rope -> SrcLoc -> Maybe Range
posToRange Rope
myRope SrcLoc
foundSloc = do
  (Int
s, Int
e) <- case SrcLoc
foundSloc of
    SrcLoc Int
s Int
e -> (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
s, Int
e)
    SrcLoc
_ -> Maybe (Int, Int)
forall a. Maybe a
Nothing
  let (Rope
startRope, Rope
_) = Word -> Rope -> (Rope, Rope)
R.charSplitAt (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s) Rope
myRope
      (Rope
endRope, Rope
_) = Word -> Rope -> (Rope, Rope)
R.charSplitAt (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
e) Rope
myRope
  Range -> Maybe Range
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$
    Position -> Position -> Range
J.Range
      (Position -> Position
ropeToLspPosition (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Rope -> Position
R.charLengthAsPosition Rope
startRope)
      (Position -> Position
ropeToLspPosition (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Rope -> Position
R.charLengthAsPosition Rope
endRope)

descend ::
  ExplainableType ty =>
  -- | position
  Int ->
  -- | next element to inspect
  Syntax' ty ->
  Maybe (Syntax' ty)
descend :: forall ty.
ExplainableType ty =>
Int -> Syntax' ty -> Maybe (Syntax' ty)
descend Int
pos s1 :: Syntax' ty
s1@(Syntax' SrcLoc
l1 Term' ty
_ Comments
_ ty
_) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int -> SrcLoc -> Bool
withinBound Int
pos SrcLoc
l1
  Syntax' ty -> Maybe (Syntax' ty)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Syntax' ty -> Maybe (Syntax' ty))
-> Syntax' ty -> Maybe (Syntax' ty)
forall a b. (a -> b) -> a -> b
$ Syntax' ty -> Int -> Syntax' ty
forall ty. ExplainableType ty => Syntax' ty -> Int -> Syntax' ty
narrowToPosition Syntax' ty
s1 Int
pos

-- | Find the most specific term for a given
-- position within the code.
narrowToPosition ::
  ExplainableType ty =>
  -- | parent term
  Syntax' ty ->
  -- | absolute offset within the file
  Int ->
  Syntax' ty
narrowToPosition :: forall ty. ExplainableType ty => Syntax' ty -> Int -> Syntax' ty
narrowToPosition s0 :: Syntax' ty
s0@(Syntax' SrcLoc
_ Term' ty
t Comments
_ ty
ty) Int
pos = Syntax' ty -> Maybe (Syntax' ty) -> Syntax' ty
forall a. a -> Maybe a -> a
fromMaybe Syntax' ty
s0 (Maybe (Syntax' ty) -> Syntax' ty)
-> Maybe (Syntax' ty) -> Syntax' ty
forall a b. (a -> b) -> a -> b
$ case Term' ty
t of
  SLam LocVar
lv Maybe Type
_ Syntax' ty
s -> Syntax' ty -> Maybe (Syntax' ty)
d (LocVar -> ty -> Syntax' ty
forall ty. LocVar -> ty -> Syntax' ty
locVarToSyntax' LocVar
lv (ty -> Syntax' ty) -> ty -> Syntax' ty
forall a b. (a -> b) -> a -> b
$ ty -> ty
forall t. ExplainableType t => t -> t
getInnerType ty
ty) Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s
  SApp Syntax' ty
s1 Syntax' ty
s2 -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1 Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s2
  SLet LetSyntax
_ Bool
_ LocVar
lv Maybe RawPolytype
_ Maybe Polytype
_ Maybe Requirements
_ s1 :: Syntax' ty
s1@(Syntax' SrcLoc
_ Term' ty
_ Comments
_ ty
lty) Syntax' ty
s2 -> Syntax' ty -> Maybe (Syntax' ty)
d (LocVar -> ty -> Syntax' ty
forall ty. LocVar -> ty -> Syntax' ty
locVarToSyntax' LocVar
lv ty
lty) Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1 Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s2
  SBind Maybe LocVar
mlv Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ s1 :: Syntax' ty
s1@(Syntax' SrcLoc
_ Term' ty
_ Comments
_ ty
lty) Syntax' ty
s2 -> (Maybe LocVar
mlv Maybe LocVar
-> (LocVar -> Maybe (Syntax' ty)) -> Maybe (Syntax' ty)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Syntax' ty -> Maybe (Syntax' ty)
d (Syntax' ty -> Maybe (Syntax' ty))
-> (LocVar -> Syntax' ty) -> LocVar -> Maybe (Syntax' ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocVar -> ty -> Syntax' ty) -> ty -> LocVar -> Syntax' ty
forall a b c. (a -> b -> c) -> b -> a -> c
flip LocVar -> ty -> Syntax' ty
forall ty. LocVar -> ty -> Syntax' ty
locVarToSyntax' (ty -> ty
forall t. ExplainableType t => t -> t
getInnerType ty
lty)) Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1 Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s2
  STydef Located TDVar
typ Polytype
typBody Maybe TydefInfo
_ti Syntax' ty
s1 -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1 Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
forall a. a -> Maybe a
Just (LocVar -> ty -> Syntax' ty
forall ty. LocVar -> ty -> Syntax' ty
locVarToSyntax' (TDVar -> Text
tdVarName (TDVar -> Text) -> Located TDVar -> LocVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located TDVar
typ) (ty -> Syntax' ty) -> ty -> Syntax' ty
forall a b. (a -> b) -> a -> b
$ Polytype -> ty
forall t. ExplainableType t => Polytype -> t
fromPoly Polytype
typBody)
  SPair Syntax' ty
s1 Syntax' ty
s2 -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1 Maybe (Syntax' ty) -> Maybe (Syntax' ty) -> Maybe (Syntax' ty)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s2
  SDelay Syntax' ty
s -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s
  SRcd Map Text (Maybe (Syntax' ty))
m -> [Maybe (Syntax' ty)] -> Maybe (Syntax' ty)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe (Syntax' ty)] -> Maybe (Syntax' ty))
-> (Map Text (Maybe (Syntax' ty)) -> [Maybe (Syntax' ty)])
-> Map Text (Maybe (Syntax' ty))
-> Maybe (Syntax' ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Syntax' ty -> Maybe (Syntax' ty))
-> [Syntax' ty] -> [Maybe (Syntax' ty)]
forall a b. (a -> b) -> [a] -> [b]
map Syntax' ty -> Maybe (Syntax' ty)
d ([Syntax' ty] -> [Maybe (Syntax' ty)])
-> (Map Text (Maybe (Syntax' ty)) -> [Syntax' ty])
-> Map Text (Maybe (Syntax' ty))
-> [Maybe (Syntax' ty)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Syntax' ty)] -> [Syntax' ty]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Syntax' ty)] -> [Syntax' ty])
-> (Map Text (Maybe (Syntax' ty)) -> [Maybe (Syntax' ty)])
-> Map Text (Maybe (Syntax' ty))
-> [Syntax' ty]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Maybe (Syntax' ty)) -> [Maybe (Syntax' ty)]
forall k a. Map k a -> [a]
M.elems (Map Text (Maybe (Syntax' ty)) -> Maybe (Syntax' ty))
-> Map Text (Maybe (Syntax' ty)) -> Maybe (Syntax' ty)
forall a b. (a -> b) -> a -> b
$ Map Text (Maybe (Syntax' ty))
m
  SProj Syntax' ty
s1 Text
_ -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s1
  SAnnotate Syntax' ty
s RawPolytype
_ -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s
  SRequirements Text
_ Syntax' ty
s -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s
  SParens Syntax' ty
s -> Syntax' ty -> Maybe (Syntax' ty)
d Syntax' ty
s
  -- atoms - return their position and end recursion
  Term' ty
TUnit -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TConst {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TDir {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TInt {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TText {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TBool {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TVar {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TStock {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TRequire {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TType {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  -- these should not show up in surface language
  TRef {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TRobot {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TAntiInt {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TAntiText {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  TAntiSyn {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
  SSuspend {} -> Maybe (Syntax' ty)
forall a. Maybe a
Nothing
 where
  d :: Syntax' ty -> Maybe (Syntax' ty)
d = Int -> Syntax' ty -> Maybe (Syntax' ty)
forall ty.
ExplainableType ty =>
Int -> Syntax' ty -> Maybe (Syntax' ty)
descend Int
pos

renderDoc :: Int -> Text -> Text
renderDoc :: Int -> Text -> Text
renderDoc Int
d Text
t
  | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text
t
  | Bool
otherwise = Int -> Text -> Text
T.drop Int
2 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
indent (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"* " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
 where
  indent :: Int -> Text -> Text
indent Int
x = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.replicate Int
x Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

treeToMarkdown :: Int -> Tree Text -> Text
treeToMarkdown :: Int -> Tree Text -> Text
treeToMarkdown Int
d (Node Text
t [Tree Text]
children) =
  [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
renderDoc Int
d Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Tree Text -> Text) -> [Tree Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Tree Text -> Text
treeToMarkdown (Int -> Tree Text -> Text) -> Int -> Tree Text -> Text
forall a b. (a -> b) -> a -> b
$ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Tree Text]
children

class Show t => ExplainableType t where
  fromPoly :: Polytype -> t

  -- | Pretty print the type.
  prettyType :: t -> Text

  -- | Strip the type of its outermost layer.
  --
  -- This allows us to strip lambda or command type
  -- and get the type of the bound variable.
  getInnerType :: t -> t

  -- | Check if this type is same as the given 'Polytype'.
  --
  -- We use it to not print same type twice (e.g. inferred and generic).
  eq :: t -> Polytype -> Bool

instance ExplainableType () where
  fromPoly :: Polytype -> ()
fromPoly = () -> Polytype -> ()
forall a b. a -> b -> a
const ()
  prettyType :: () -> Text
prettyType = Text -> () -> Text
forall a b. a -> b -> a
const Text
"?"
  getInnerType :: () -> ()
getInnerType = () -> ()
forall a. a -> a
id
  eq :: () -> Polytype -> Bool
eq ()
_ Polytype
_ = Bool
False

instance ExplainableType Polytype where
  fromPoly :: Polytype -> Polytype
fromPoly = Polytype -> Polytype
forall a. a -> a
id
  prettyType :: Polytype -> Text
prettyType = Polytype -> Text
forall a. PrettyPrec a => a -> Text
prettyTextLine
  getInnerType :: Polytype -> Polytype
getInnerType = (Type -> Type) -> Polytype -> Polytype
forall a b. (a -> b) -> Poly 'Quantified a -> Poly 'Quantified b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type) -> Polytype -> Polytype)
-> (Type -> Type) -> Polytype -> Polytype
forall a b. (a -> b) -> a -> b
$ \case
    (Type
l :->: Type
_r) -> Type
l
    (TyCmd Type
t) -> Type
t
    Type
t -> Type
t
  eq :: Polytype -> Polytype -> Bool
eq = Polytype -> Polytype -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance ExplainableType RawPolytype where
  fromPoly :: Polytype -> RawPolytype
fromPoly = Polytype -> RawPolytype
forall t. Poly 'Quantified t -> Poly 'Unquantified t
forgetQ
  prettyType :: RawPolytype -> Text
prettyType = RawPolytype -> Text
forall a. PrettyPrec a => a -> Text
prettyTextLine
  getInnerType :: RawPolytype -> RawPolytype
getInnerType = (Type -> Type) -> RawPolytype -> RawPolytype
forall a b.
(a -> b) -> Poly 'Unquantified a -> Poly 'Unquantified b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type) -> RawPolytype -> RawPolytype)
-> (Type -> Type) -> RawPolytype -> RawPolytype
forall a b. (a -> b) -> a -> b
$ \case
    (Type
l :->: Type
_r) -> Type
l
    (TyCmd Type
t) -> Type
t
    Type
t -> Type
t
  eq :: RawPolytype -> Polytype -> Bool
eq RawPolytype
r Polytype
t = RawPolytype
r RawPolytype -> RawPolytype -> Bool
forall a. Eq a => a -> a -> Bool
== Polytype -> RawPolytype
forall t. Poly 'Quantified t -> Poly 'Unquantified t
forgetQ Polytype
t

explain :: ExplainableType ty => Syntax' ty -> Tree Text
explain :: forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax' ty
trm = case Syntax' ty
trm Syntax' ty
-> Getting (Term' ty) (Syntax' ty) (Term' ty) -> Term' ty
forall s a. s -> Getting a s a -> a
^. Getting (Term' ty) (Syntax' ty) (Term' ty)
forall ty (f :: * -> *).
Functor f =>
(Term' ty -> f (Term' ty)) -> Syntax' ty -> f (Syntax' ty)
sTerm of
  Term' ty
TUnit -> Text -> Tree Text
literal Text
"The unit value."
  TConst Const
c -> Text -> Tree Text
literal (Text -> Tree Text) -> (Text -> Text) -> Text -> Tree Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Text -> Text
constGenSig Const
c (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ ConstDoc -> Text
briefDoc (ConstInfo -> ConstDoc
constDoc (ConstInfo -> ConstDoc) -> ConstInfo -> ConstDoc
forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
constInfo Const
c)
  TDir {} -> Text -> Tree Text
literal Text
"A direction literal."
  TInt {} -> Text -> Tree Text
literal Text
"An integer literal."
  TText {} -> Text -> Tree Text
literal Text
"A text literal."
  TBool {} -> Text -> Tree Text
literal Text
"A boolean literal."
  TVar Text
v -> Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
v ty
ty Text
""
  SRcd {} -> Text -> Tree Text
literal Text
"A record literal."
  SProj {} -> Text -> Tree Text
literal Text
"A record projection."
  STydef {} -> Text -> Tree Text
literal Text
"A type synonym definition."
  TType {} -> Text -> Tree Text
literal Text
"A type literal."
  SParens Syntax' ty
s -> Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax' ty
s
  -- type ascription
  SAnnotate Syntax' ty
lhs RawPolytype
typeAnn ->
    Text -> [Tree Text] -> Tree Text
forall a. a -> [Tree a] -> Tree a
Node
      (Text -> RawPolytype -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
"_" RawPolytype
typeAnn Text
"A type ascription for")
      [Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax' ty
lhs]
  -- special forms (function application will show for `$`, but really should be rare)
  SApp {} -> Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explainFunction Syntax' ty
trm
  TRequire {} -> Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Require a specific device to be equipped."
  TStock {} -> Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Stock a certain number of an entity."
  SRequirements {} -> Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Query the requirements of a term."
  -- definition or bindings
  SLet LetSyntax
ls Bool
isRecursive LocVar
var Maybe RawPolytype
mTypeAnn Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
rhs Syntax' ty
_b -> Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text
forall ty.
ExplainableType ty =>
LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text
explainDefinition LetSyntax
ls Bool
isRecursive LocVar
var (Syntax' ty
rhs Syntax' ty -> Getting ty (Syntax' ty) ty -> ty
forall s a. s -> Getting a s a -> a
^. Getting ty (Syntax' ty) ty
forall ty (f :: * -> *).
Functor f =>
(ty -> f ty) -> Syntax' ty -> f (Syntax' ty)
sType) Maybe RawPolytype
mTypeAnn
  SLam (LV SrcLoc
_s Text
v) Maybe Type
_mType Syntax' ty
_syn ->
    Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$
      Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
v ty
ty (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text
"A lambda expression binding the variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
U.bquote Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
  SBind Maybe LocVar
mv Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
rhs Syntax' ty
_cmds ->
    Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$
      Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature (Text -> (LocVar -> Text) -> Maybe LocVar -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"__rhs" LocVar -> Text
forall v. Located v -> v
lvVar Maybe LocVar
mv) (ty -> ty
forall t. ExplainableType t => t -> t
getInnerType (ty -> ty) -> ty -> ty
forall a b. (a -> b) -> a -> b
$ Syntax' ty
rhs Syntax' ty -> Getting ty (Syntax' ty) ty -> ty
forall s a. s -> Getting a s a -> a
^. Getting ty (Syntax' ty) ty
forall ty (f :: * -> *).
Functor f =>
(ty -> f ty) -> Syntax' ty -> f (Syntax' ty)
sType) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text
"A monadic bind for commands" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (LocVar -> Text) -> Maybe LocVar -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"." (\(LV SrcLoc
_s Text
v) -> Text
", that binds variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
U.bquote Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") Maybe LocVar
mv
  -- composite types
  SPair {} ->
    Text -> [Tree Text] -> Tree Text
forall a. a -> [Tree a] -> Tree a
Node
      (Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
"_" ty
ty Text
"A tuple consisting of:")
      (Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain (Syntax' ty -> Tree Text) -> [Syntax' ty] -> [Tree Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Syntax' ty -> [Syntax' ty]
forall ty. Syntax' ty -> [Syntax' ty]
unTuple Syntax' ty
trm)
  SDelay {} ->
    Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> ([Text] -> Text) -> [Text] -> Tree Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Tree Text) -> [Text] -> Tree Text
forall a b. (a -> b) -> a -> b
$
      [ Text
"Delay evaluation of a term, written `{...}`."
      , Text
""
      , Text
"Swarm is an eager language, but in some cases (e.g. for `if` statements and recursive bindings) we need to delay evaluation."
      , Text
""
      , Text
"The counterpart to `{...}` is `force`:"
      , Text
"```"
      , Text
"force {t} = t"
      , Text
"```"
      ]
  -- internal syntax that should not actually show in hover
  TRef {} -> Text -> Tree Text
internal Text
"A memory reference."
  TAntiInt {} -> Text -> Tree Text
internal Text
"An antiquoted Haskell variable name of type Integer."
  TAntiText {} -> Text -> Tree Text
internal Text
"An antiquoted Haskell variable name of type Text."
  TAntiSyn {} -> Text -> Tree Text
internal Text
"An antiquoted Haskell variable name of type Syntax."
  TRobot {} -> Text -> Tree Text
internal Text
"A robot reference."
  SSuspend {} -> Text -> Tree Text
internal Text
"A suspension."
 where
  ty :: ty
ty = Syntax' ty
trm Syntax' ty -> Getting ty (Syntax' ty) ty -> ty
forall s a. s -> Getting a s a -> a
^. Getting ty (Syntax' ty) ty
forall ty (f :: * -> *).
Functor f =>
(ty -> f ty) -> Syntax' ty -> f (Syntax' ty)
sType
  literal :: Text -> Tree Text
literal = Text -> Tree Text
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Tree Text) -> (Text -> Text) -> Text -> Tree Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature (Term' () -> Text
forall a. PrettyPrec a => a -> Text
prettyText (Term' () -> Text) -> (Term' ty -> Term' ()) -> Term' ty -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' ty -> Term' ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Term' ty -> Text) -> Term' ty -> Text
forall a b. (a -> b) -> a -> b
$ Syntax' ty
trm Syntax' ty
-> Getting (Term' ty) (Syntax' ty) (Term' ty) -> Term' ty
forall s a. s -> Getting a s a -> a
^. Getting (Term' ty) (Syntax' ty) (Term' ty)
forall ty (f :: * -> *).
Functor f =>
(Term' ty -> f (Term' ty)) -> Syntax' ty -> f (Syntax' ty)
sTerm) ty
ty
  internal :: Text -> Tree Text
internal Text
description = Text -> Tree Text
literal (Text -> Tree Text) -> Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ Text
description Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n**These should never show up in surface syntax.**"
  constGenSig :: Const -> Text -> Text
constGenSig Const
c =
    let ity :: Polytype
ity = Const -> Polytype
inferConst Const
c
     in Bool -> (Text -> Text) -> Text -> Text
forall a. Bool -> (a -> a) -> a -> a
U.applyWhen (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ty
ty ty -> Polytype -> Bool
forall t. ExplainableType t => t -> Polytype -> Bool
`eq` Polytype
ity) ((Text -> Text) -> Text -> Text) -> (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Polytype -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature (Const -> Text
forall a. PrettyPrec a => a -> Text
prettyText Const
c) Polytype
ity

-- | Helper function to explain function application.
--
-- Note that 'Force' is often inserted internally, so
-- if it shows up here we drop it.
explainFunction :: ExplainableType ty => Syntax' ty -> Tree Text
explainFunction :: forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explainFunction Syntax' ty
s =
  case Syntax' ty -> NonEmpty (Syntax' ty)
forall ty. Syntax' ty -> NonEmpty (Syntax' ty)
unfoldApps Syntax' ty
s of
    (Syntax' SrcLoc
_ (TConst Const
Force) Comments
_ ty
_ :| [Syntax' ty
innerT]) -> Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax' ty
innerT
    (Syntax' SrcLoc
_ (TConst Const
Force) Comments
_ ty
_ :| Syntax' ty
f : [Syntax' ty]
params) -> Syntax' ty -> [Syntax' ty] -> Tree Text
forall {ty} {ty}.
(ExplainableType ty, ExplainableType ty) =>
Syntax' ty -> [Syntax' ty] -> Tree Text
explainF Syntax' ty
f [Syntax' ty]
params
    (Syntax' ty
f :| [Syntax' ty]
params) -> Syntax' ty -> [Syntax' ty] -> Tree Text
forall {ty} {ty}.
(ExplainableType ty, ExplainableType ty) =>
Syntax' ty -> [Syntax' ty] -> Tree Text
explainF Syntax' ty
f [Syntax' ty]
params
 where
  explainF :: Syntax' ty -> [Syntax' ty] -> Tree Text
explainF Syntax' ty
f [Syntax' ty]
params =
    Text -> [Tree Text] -> Tree Text
forall a. a -> [Tree a] -> Tree a
Node
      Text
"Function application of:"
      [ Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain Syntax' ty
f
      , Text -> [Tree Text] -> Tree Text
forall a. a -> [Tree a] -> Tree a
Node
          Text
"with parameters:"
          ((Syntax' ty -> Tree Text) -> [Syntax' ty] -> [Tree Text]
forall a b. (a -> b) -> [a] -> [b]
map Syntax' ty -> Tree Text
forall ty. ExplainableType ty => Syntax' ty -> Tree Text
explain [Syntax' ty]
params)
      ]

explainDefinition :: ExplainableType ty => LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text
explainDefinition :: forall ty.
ExplainableType ty =>
LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text
explainDefinition LetSyntax
ls Bool
isRecursive (LV SrcLoc
_s Text
var) ty
ty Maybe RawPolytype
maybeTypeAnnotation =
  Text -> ty -> Text -> Text
forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
var ty
ty (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.unwords
      [ Text
"A"
      , (if Bool
isRecursive then Text
"" else Text
"non-") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"recursive"
      , if LetSyntax
ls LetSyntax -> LetSyntax -> Bool
forall a. Eq a => a -> a -> Bool
== LetSyntax
LSDef then Text
"definition" else Text
"let"
      , Text
"expression"
      , if Maybe RawPolytype -> Bool
forall a. Maybe a -> Bool
isNothing Maybe RawPolytype
maybeTypeAnnotation then Text
"without" else Text
"with"
      , Text
"a type annotation on the variable."
      ]

typeSignature :: ExplainableType ty => Var -> ty -> Text -> Text
typeSignature :: forall ty. ExplainableType ty => Text -> ty -> Text -> Text
typeSignature Text
v ty
typ Text
body = [Text] -> Text
T.unlines [Text
"```", Text
short, Text
"```", Text
body]
 where
  short :: Text
short = Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ty -> Text
forall t. ExplainableType t => t -> Text
prettyType ty
typ