├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .vscode └── settings.json ├── README.md ├── assets ├── dosh-minimal.svg ├── dosh.png └── dosh.svg ├── cabal.project ├── cabal.project.local ├── dosh-prelude ├── dosh-prelude.cabal └── src │ └── Dosh │ └── Prelude.hs ├── dosh ├── CHANGELOG.md ├── LICENCE ├── app │ └── Main.hs ├── dosh.cabal ├── src │ ├── Data │ │ ├── Sequence │ │ │ └── Zipper.hs │ │ └── Text │ │ │ └── CodeZipper.hs │ ├── Dosh │ │ ├── Cell.hs │ │ ├── GHC │ │ │ ├── Client.hs │ │ │ ├── Evaluator.hs │ │ │ ├── Lexer.hs │ │ │ ├── Parser.hs │ │ │ ├── Server.hs │ │ │ └── Session.hs │ │ ├── LSP │ │ │ ├── Client.hs │ │ │ ├── Document.hs │ │ │ └── Server.hs │ │ ├── Notebook.hs │ │ └── Util.hs │ └── Reflex │ │ └── Vty │ │ └── Widget │ │ └── Input │ │ └── Code.hs └── test │ ├── Data │ ├── Sequence │ │ └── ZipperSpec.hs │ └── Text │ │ └── CodeZipperSpec.hs │ ├── Dosh │ └── GHC │ │ ├── EvaluatorSpec.hs │ │ ├── LexerSpec.hs │ │ └── ParserSpec.hs │ ├── Spec.hs │ └── Test │ └── Hspec │ └── Expectations │ └── Extra.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── hie.yaml ├── lsp-client ├── LICENCE ├── lsp-client.cabal ├── src │ └── Language │ │ └── LSP │ │ ├── Client.hs │ │ └── Client │ │ ├── Compat.hs │ │ ├── Decoding.hs │ │ ├── Encoding.hs │ │ ├── Exceptions.hs │ │ └── Session.hs └── test │ ├── Language │ └── LSP │ │ └── ClientSpec.hs │ └── Spec.hs └── shell.nix /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Continuous integration 2 | on: 3 | push: 4 | branches: main 5 | pull_request: 6 | branches: main 7 | workflow_dispatch: # allows manual triggering 8 | env: 9 | # Bump this number to invalidate the GH actions cache 10 | cache-version: 0 11 | 12 | jobs: 13 | build: 14 | strategy: 15 | matrix: 16 | target: ['default', 'ghc94.dosh'] 17 | os: ['ubuntu-latest', 'macos-latest'] 18 | runs-on: ${{ matrix.os }} 19 | name: Build ${{ matrix.target }} on ${{ matrix.os }} 20 | steps: 21 | - uses: actions/checkout@v3 22 | - uses: cachix/install-nix-action@v19 23 | - uses: cachix/cachix-action@v12 24 | with: 25 | name: dosh 26 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 27 | - name: Build 28 | run: | 29 | nix build \ 30 | --accept-flake-config \ 31 | --print-build-logs \ 32 | .#${{ matrix.target }} 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .envrc 2 | .direnv 3 | dist* 4 | result* 5 | *.log 6 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.formatOnSave": true, 3 | "haskell.formattingProvider": "fourmolu", 4 | "haskell.manageHLS": "PATH", 5 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix", 6 | "cSpell.language": "en-GB" 7 | } 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | dosh logo 2 | 3 | # dosh 4 | 5 | The power of ~~capitalism~~ Haskell in your terminal! 6 | 7 | ## What have we got here? 8 | 9 | `dosh` is a Haskell Read-Eval-Print Loop, or REPL for short. 10 | While other REPLs for Haskell exist, this one aims to be good enough to replace Bash as a daily driver. 11 | 12 | We offer: 13 | - syntax highlighting 14 | - advanced history interaction 15 | - LSP-powered autocompletion and error detection 16 | 17 | ## Really? *Haskell* as a daily driver? 18 | 19 | Why not? Haskell is an advanced functional programming language with an excellent blend of power and elegance that scales well as commands grow nontrivial. 20 | 21 | > This is the Unix philosophy: Write programs that do one thing and do it well. Write 22 | > programs to work together. Write programs to handle text streams, because that is a 23 | > universal interface. 24 | 25 | — Doug McIlroy 26 | 27 | Aside from executing programs, an essential operation of the shell is to manipulate text streams that pass between programs. 28 | Many programs output structured data, which Bash is [notoriously bad at handling](https://stackoverflow.com/a/45201229). 29 | 30 | There are many alternatives to Bash, but they are all fundamentally boring shells. They tend to invent new domain specific languages which ultimately offer no real value as a programming language. 31 | 32 | Instead of inventing a new shell language that can do slighty more than Bash, why not go the other way around and make an existing language usable as a shell? 33 | And what language is more suitable than one that was quite literally invented as a testbed for novel uses such as this? 34 | 35 | ## Why is it named `dosh`? 36 | 37 | Because our REPL has special handling of Haskell's [`do` notation](https://en.wikibooks.org/wiki/Haskell/do_notation). 38 | 39 | In Haskell, the keyword `do` introduces a block of commands that evaluate sequentially and can depend on each other. 40 | When the user enters a `do` block in `dosh`, the prompt changes to `do$`, which is also where the logo comes from. 41 | 42 | I've also been advised to avoid overt references to Haskell in the name (e.g. `hashell`, `shellmonad`), as those might spook people. 43 | 44 | ## Prior art 45 | 46 | This is not a novel idea, as evidenced by the abundance of Haskell libaries that provide shell primitives. 47 | The only novelty of this project is a snazzy REPL around them. 48 | 49 | - [turtle: Shell programming, Haskell-style](https://hackage.haskell.org/package/turtle) 50 | - [shh: Simple shell scripting from Haskell](https://hackage.haskell.org/package/shh) 51 | - [shelly: shell-like (systems) programming in Haskell](https://hackage.haskell.org/package/shelly) 52 | - [ptGHCi](https://github.com/litxio/ptghci) is a high-powered REPL for Haskell, inspired by IPython 53 | - [Using Haskell as my shell](https://las.rs/blog/haskell-as-shell.html) (2021) by Las Safin 54 | - [Use Haskell for shell scripting](https://www.haskellforall.com/2015/01/use-haskell-for-shell-scripting.html) (2015) by Gabriella Gonzalez 55 | -------------------------------------------------------------------------------- /assets/dosh-minimal.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /assets/dosh.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ners/dosh/ef939baf1d508b0c3bb318ab20683cb500105b82/assets/dosh.png -------------------------------------------------------------------------------- /assets/dosh.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 39 | 41 | 58 | 75 | 76 | 86 | 96 | do$ 109 | 110 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | dosh/ 3 | dosh-prelude/ 4 | lsp-client/ 5 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | ignore-project: False 2 | tests: True 3 | test-options: "--color", "--times", "--print-cpu-time" 4 | test-show-details: direct 5 | profiling: True 6 | library-profiling: True 7 | -------------------------------------------------------------------------------- /dosh-prelude/dosh-prelude.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dosh-prelude 3 | version: 23.3 4 | synopsis: The power of Haskell in your terminal! 5 | homepage: https://github.com/ners/dosh 6 | license: GPL-3.0-or-later 7 | author: ners 8 | maintainer: ners@gmx.ch 9 | category: System 10 | build-type: Simple 11 | 12 | library 13 | hs-source-dirs: src 14 | default-language: GHC2021 15 | ghc-options: 16 | -Wall 17 | default-extensions: 18 | ApplicativeDo 19 | DataKinds 20 | DefaultSignatures 21 | DeriveAnyClass 22 | DeriveGeneric 23 | DerivingStrategies 24 | DerivingVia 25 | ExplicitNamespaces 26 | OverloadedLabels 27 | OverloadedRecordDot 28 | OverloadedStrings 29 | RecordWildCards 30 | RecursiveDo 31 | TypeFamilies 32 | build-depends: 33 | base, 34 | bytestring, 35 | data-default, 36 | generic-lens, 37 | lens, 38 | sixel, 39 | text, 40 | unliftio, 41 | unliftio-core 42 | exposed-modules: 43 | Dosh.Prelude 44 | -------------------------------------------------------------------------------- /dosh-prelude/src/Dosh/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Dosh.Prelude 2 | ( module Prelude 3 | , module Control.Applicative 4 | , module Control.Arrow 5 | , module Control.Lens 6 | , module Control.Monad 7 | , module Control.Monad.IO.Unlift 8 | , module Data.ByteString 9 | , module Data.ByteString.Lazy 10 | , module Data.Char 11 | , module Data.Foldable 12 | , module Data.Functor 13 | , module Data.Generics.Labels 14 | , module Data.Generics.Product 15 | , module Data.Maybe 16 | , module Data.String 17 | , module Data.Text 18 | , module Debug.Trace 19 | , module GHC.Generics 20 | , module System.IO 21 | , module UnliftIO.Async 22 | , module UnliftIO.Concurrent 23 | , module UnliftIO.Exception 24 | , module UnliftIO.STM 25 | , module UnliftIO.Timeout 26 | ) 27 | where 28 | 29 | import Control.Applicative 30 | import Control.Arrow 31 | import Control.Lens 32 | import Control.Monad 33 | import Control.Monad.IO.Unlift 34 | import Data.ByteString (ByteString) 35 | import Data.ByteString.Lazy (LazyByteString) 36 | import Data.Char 37 | import Data.Foldable 38 | import Data.Functor 39 | import Data.Generics.Labels 40 | import Data.Generics.Product 41 | import Data.Maybe 42 | import Data.String 43 | import Data.Text (Text) 44 | import Debug.Trace 45 | import GHC.Generics (Generic) 46 | import System.IO 47 | import UnliftIO.Async 48 | import UnliftIO.Concurrent 49 | import UnliftIO.Exception 50 | import UnliftIO.STM 51 | import UnliftIO.Timeout 52 | -------------------------------------------------------------------------------- /dosh/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for dosh 2 | 3 | ## 2023 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /dosh/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Text.IO qualified as Text 4 | import Dosh.GHC.Client qualified as GHC 5 | import Dosh.GHC.Server qualified as GHC 6 | import Dosh.LSP.Client qualified as LSP 7 | import Dosh.LSP.Document (newDocument) 8 | import Dosh.LSP.Server qualified as LSP 9 | import Dosh.Notebook 10 | import Dosh.Prelude 11 | import Dosh.Util 12 | import Reflex.Network (networkView) 13 | import Reflex.Vty 14 | 15 | main :: IO () 16 | main = mainWidget $ do 17 | ghcServer <- GHC.server 18 | ghcClient <- GHC.client ghcServer 19 | lspServer <- LSP.server 20 | lspClient <- LSP.client lspServer 21 | initialNotebook <- newNotebook $ #language .~ "haskell" 22 | let identifier = initialNotebook.identifier 23 | let document = newDocument identifier & #getSessionDynFlags .~ GHC.getSessionDynFlags ghcServer 24 | liftIO $ do 25 | lspClient.request LSP.Initialize 26 | lspClient.request $ LSP.CreateDocument document 27 | performEvent $ lspClient.onLog <&> \l -> liftIO $ Text.appendFile "hls-log.log" $ tshow l <> "\n" 28 | performEvent $ lspClient.onError <&> \e -> liftIO $ Text.appendFile "hls-error.log" $ tshow e <> "\n" 29 | initManager_ $ mdo 30 | dn :: Dynamic t Notebook <- holdDyn initialNotebook u 31 | u :: Event t Notebook <- networkView (notebook ghcClient lspClient <$> dn) >>= switchHold never 32 | void <$> ctrldPressed 33 | -------------------------------------------------------------------------------- /dosh/dosh.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: dosh 3 | version: 23.3 4 | synopsis: The power of Haskell in your terminal! 5 | homepage: https://github.com/ners/dosh 6 | license: GPL-3.0-or-later 7 | license-file: LICENCE 8 | author: ners 9 | maintainer: ners@gmx.ch 10 | category: System 11 | build-type: Simple 12 | 13 | common common 14 | default-language: GHC2021 15 | ghc-options: 16 | -Weverything 17 | -Wno-unsafe 18 | -Wno-missing-safe-haskell-mode 19 | -Wno-missing-export-lists 20 | -Wno-missing-import-lists 21 | -Wno-missing-kind-signatures 22 | -Wno-all-missed-specialisations 23 | default-extensions: 24 | ApplicativeDo 25 | DataKinds 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DeriveGeneric 29 | DerivingStrategies 30 | DerivingVia 31 | ExplicitNamespaces 32 | NoImplicitPrelude 33 | OverloadedLabels 34 | OverloadedRecordDot 35 | OverloadedStrings 36 | RecordWildCards 37 | RecursiveDo 38 | TypeFamilies 39 | ViewPatterns 40 | build-depends: 41 | dosh-prelude, 42 | text 43 | 44 | library 45 | import: common 46 | hs-source-dirs: src 47 | exposed-modules: 48 | Data.Sequence.Zipper, 49 | Data.Text.CodeZipper, 50 | Dosh.Cell, 51 | Dosh.GHC.Client, 52 | Dosh.GHC.Evaluator, 53 | Dosh.GHC.Lexer, 54 | Dosh.GHC.Parser, 55 | Dosh.GHC.Server, 56 | Dosh.GHC.Session, 57 | Dosh.LSP.Client, 58 | Dosh.LSP.Document, 59 | Dosh.LSP.Server, 60 | Dosh.Notebook, 61 | Dosh.Util 62 | other-modules: 63 | Reflex.Vty.Widget.Input.Code 64 | build-depends: 65 | base, 66 | bytestring, 67 | containers, 68 | data-default, 69 | exceptions, 70 | extra, 71 | generic-lens, 72 | ghc, 73 | ghc-paths, 74 | ghc-syntax-highlighter, 75 | ghcide, 76 | hashable, 77 | haskell-language-server, 78 | hie-bios, 79 | lens, 80 | lsp-client, 81 | lsp-types, 82 | mtl, 83 | process, 84 | reflex, 85 | reflex-vty, 86 | skylighting, 87 | skylighting-core, 88 | stm, 89 | template-haskell, 90 | text-rope, 91 | these, 92 | unordered-containers, 93 | uuid, 94 | vty 95 | 96 | executable dosh 97 | import: common 98 | main-is: Main.hs 99 | hs-source-dirs: app 100 | ghc-options: 101 | -threaded 102 | build-depends: 103 | dosh, 104 | reflex, 105 | reflex-vty 106 | 107 | test-suite dosh-test 108 | import: common 109 | ghc-options: -threaded 110 | type: exitcode-stdio-1.0 111 | main-is: Spec.hs 112 | hs-source-dirs: test 113 | build-depends: 114 | QuickCheck, 115 | base, 116 | containers, 117 | dosh, 118 | extra, 119 | ghcide, 120 | hspec, 121 | quickcheck-text, 122 | other-modules: 123 | Data.Sequence.ZipperSpec, 124 | Data.Text.CodeZipperSpec, 125 | Dosh.GHC.EvaluatorSpec, 126 | Dosh.GHC.LexerSpec, 127 | Dosh.GHC.ParserSpec, 128 | Test.Hspec.Expectations.Extra, 129 | -------------------------------------------------------------------------------- /dosh/src/Data/Sequence/Zipper.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Data.Sequence.Zipper where 4 | 5 | import Control.Applicative ((<|>)) 6 | import Data.Foldable (find) 7 | import Data.Maybe (fromJust) 8 | import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (|>)) 9 | import Data.Sequence qualified as Seq 10 | import GHC.Exts (IsList (..)) 11 | import GHC.Generics (Generic) 12 | import Prelude 13 | 14 | data SeqZipper t = SeqZipper 15 | { before :: Seq t 16 | , after :: Seq t 17 | } 18 | deriving stock (Generic, Eq, Show) 19 | 20 | empty :: SeqZipper t 21 | empty = SeqZipper{before = Seq.empty, after = Seq.empty} 22 | 23 | singleton :: t -> SeqZipper t 24 | singleton x = SeqZipper{before = mempty, after = Seq.singleton x} 25 | 26 | length :: SeqZipper t -> Int 27 | length SeqZipper{..} = Seq.length before + Seq.length after 28 | 29 | instance Semigroup (SeqZipper t) where 30 | a <> b = SeqZipper{before = before a, after = after a <> before b <> after b} 31 | 32 | instance Monoid (SeqZipper t) where 33 | mempty = empty 34 | 35 | instance IsList (SeqZipper t) where 36 | type Item (SeqZipper t) = t 37 | fromList xs = SeqZipper{before = mempty, after = fromList xs} 38 | toList SeqZipper{..} = toList $ before <> after 39 | 40 | instance Foldable SeqZipper where 41 | foldr f z = foldr f z . toList 42 | 43 | instance Traversable SeqZipper where 44 | traverse :: Applicative f => (a -> f b) -> SeqZipper a -> f (SeqZipper b) 45 | traverse f SeqZipper{..} = do 46 | before <- traverse f before 47 | after <- traverse f after 48 | pure SeqZipper{..} 49 | 50 | instance Functor SeqZipper where 51 | fmap :: (a -> b) -> SeqZipper a -> SeqZipper b 52 | fmap f SeqZipper{..} = 53 | SeqZipper 54 | { before = fmap f before 55 | , after = fmap f after 56 | } 57 | 58 | seqFirst :: Seq a -> Maybe a 59 | seqFirst s = case Seq.viewl s of 60 | EmptyL -> Nothing 61 | (x :< _) -> Just x 62 | 63 | seqLast :: Seq a -> Maybe a 64 | seqLast s = case Seq.viewr s of 65 | EmptyR -> Nothing 66 | (_ :> x) -> Just x 67 | 68 | first :: SeqZipper t -> Maybe t 69 | first SeqZipper{..} = seqFirst before 70 | 71 | current :: SeqZipper t -> Maybe t 72 | current SeqZipper{..} = seqFirst after 73 | 74 | next :: SeqZipper t -> Maybe t 75 | next = current . forward 76 | 77 | previous :: SeqZipper t -> Maybe t 78 | previous SeqZipper{before} = case Seq.viewr before of 79 | EmptyR -> Nothing 80 | (_ :> x) -> Just x 81 | 82 | last :: SeqZipper t -> Maybe t 83 | last SeqZipper{..} = seqLast after <|> seqLast before 84 | 85 | forward :: SeqZipper t -> SeqZipper t 86 | forward sz@SeqZipper{..} = case Seq.viewl after of 87 | EmptyL -> sz 88 | (x :< after) -> sz{before = before |> x, after} 89 | 90 | forwardWhile :: (t -> Bool) -> SeqZipper t -> SeqZipper t 91 | forwardWhile p = fromJust . find (not . maybe False p . current) . iterate forward 92 | 93 | back :: SeqZipper t -> SeqZipper t 94 | back sz@SeqZipper{..} = case Seq.viewr before of 95 | EmptyR -> sz 96 | (before :> x) -> sz{before, after = x <| after} 97 | 98 | backWhile :: (t -> Bool) -> SeqZipper t -> SeqZipper t 99 | backWhile p sz = go $ Prelude.take (1 + Seq.length (before sz)) $ iterate back sz 100 | where 101 | go [x] = x 102 | go (x : y : xs) 103 | | maybe True p (current y) = go (y : xs) 104 | | otherwise = x 105 | go _ = sz 106 | 107 | home :: SeqZipper t -> SeqZipper t 108 | home sz@SeqZipper{..} = sz{before = mempty, after = before <> after} 109 | 110 | end :: SeqZipper t -> SeqZipper t 111 | end sz@SeqZipper{..} = sz{before = before <> after, after = mempty} 112 | 113 | drop :: Int -> SeqZipper t -> SeqZipper t 114 | drop n sz@SeqZipper{..} = sz{after = Seq.drop n after} 115 | 116 | dropBefore :: Int -> SeqZipper t -> SeqZipper t 117 | dropBefore n sz@SeqZipper{..} = Data.Sequence.Zipper.drop n' $ iterate back sz !! n' 118 | where 119 | n' = min n $ Seq.length before 120 | 121 | take :: Int -> SeqZipper t -> Seq t 122 | take n SeqZipper{..} = Seq.take n after 123 | 124 | takeBefore :: Int -> SeqZipper t -> Seq t 125 | takeBefore n sz@SeqZipper{..} = Data.Sequence.Zipper.take n' $ iterate back sz !! n' 126 | where 127 | n' = min n $ Seq.length before 128 | 129 | -- | Insert a new element before the current element (after the cursor) and move the focus to the newly inserted one. 130 | insert :: t -> SeqZipper t -> SeqZipper t 131 | insert v sz@SeqZipper{..} = sz{after = v <| after} 132 | 133 | {- | Insert a new element after the current element, keeping the focus on the current element. 134 | In absence of a current element (at the end of a sequence), the inserted element becomes the current element. 135 | -} 136 | insertAfter :: t -> SeqZipper t -> SeqZipper t 137 | insertAfter v sz@SeqZipper{..} 138 | | Seq.null after = insert v sz 139 | | otherwise = back $ insert v $ forward sz 140 | 141 | -- | Insert a new element before the current element and keep the focus unchanged. 142 | insertBefore :: t -> SeqZipper t -> SeqZipper t 143 | insertBefore v sz@SeqZipper{..} = sz{before = before |> v} 144 | -------------------------------------------------------------------------------- /dosh/src/Data/Text/CodeZipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Data.Text.CodeZipper where 5 | 6 | import Data.Function ((&)) 7 | import Data.Functor ((<&>)) 8 | import Data.List (find, uncons) 9 | import Data.List.NonEmpty (NonEmpty (..)) 10 | import Data.List.NonEmpty qualified as NonEmpty 11 | import Data.Maybe (fromMaybe) 12 | import Data.Text (Text) 13 | import Data.Text qualified as Text 14 | import GHC.Generics (Generic) 15 | import Prelude 16 | 17 | data Token t = Token 18 | { tokenType :: t 19 | , tokenContent :: Text 20 | } 21 | deriving stock (Generic, Eq) 22 | 23 | instance Show t => Show (Token t) where 24 | show Token{..} = show tokenType <> " " <> show tokenContent 25 | 26 | type SourceLine t = [Token t] 27 | 28 | class Pretty t where 29 | plain :: Text -> [SourceLine t] 30 | pretty :: Text -> Text -> Maybe [SourceLine t] 31 | 32 | plainLine :: Pretty t => Text -> SourceLine t 33 | plainLine = maybe [] fst . uncons . plain 34 | 35 | data CodeZipper t = CodeZipper 36 | { language :: Text 37 | , linesBefore :: [SourceLine t] 38 | , linesAfter :: [SourceLine t] 39 | , tokensBefore :: [Token t] 40 | , tokensAfter :: [Token t] 41 | } 42 | deriving stock (Generic, Eq, Show) 43 | 44 | instance Eq t => Monoid (CodeZipper t) where 45 | mempty = empty 46 | 47 | instance Eq t => Semigroup (CodeZipper t) where 48 | a <> b = a{linesAfter = linesAfter a <> allLines b} 49 | 50 | empty :: CodeZipper t 51 | empty = 52 | CodeZipper 53 | { language = mempty 54 | , linesBefore = mempty 55 | , linesAfter = mempty 56 | , tokensBefore = mempty 57 | , tokensAfter = mempty 58 | } 59 | 60 | plainZipper :: Pretty t => Text -> Text -> CodeZipper t 61 | plainZipper before after = empty{linesBefore, linesAfter, tokensBefore, tokensAfter} 62 | where 63 | (reverse -> tokensBefore, linesBefore) = fromMaybe ([], []) $ uncons $ reverse $ plain before 64 | (tokensAfter, linesAfter) = fromMaybe ([], []) $ uncons $ plain after 65 | 66 | prettyZipper :: Pretty t => Text -> Text -> Maybe (CodeZipper t) 67 | prettyZipper language t = pretty language t <&> \(fromMaybe ([], []) . uncons -> (tokensAfter, linesAfter)) -> empty{language, tokensAfter, linesAfter} 68 | 69 | currentLine :: Eq t => CodeZipper t -> SourceLine t 70 | currentLine CodeZipper{tokensBefore, tokensAfter} = 71 | normaliseToks $ reverse tokensBefore <> tokensAfter 72 | 73 | linesBetween :: Eq t => Int -> Int -> CodeZipper t -> [SourceLine t] 74 | linesBetween from to = take (to - from) . fmap currentLine . iterate down . home . goToRow from 75 | 76 | null :: CodeZipper t -> Bool 77 | null CodeZipper{..} = no linesBefore && no linesAfter && no tokensBefore && no tokensAfter 78 | where 79 | no :: [a] -> Bool 80 | no = Prelude.null 81 | 82 | lines :: CodeZipper t -> Int 83 | lines CodeZipper{linesBefore, linesAfter} = length linesBefore + 1 + length linesAfter 84 | 85 | allLines :: Eq t => CodeZipper t -> [SourceLine t] 86 | allLines cz@CodeZipper{linesBefore, linesAfter} = 87 | reverse linesBefore <> [currentLine cz] <> linesAfter 88 | 89 | row :: CodeZipper t -> Int 90 | row = length . linesBefore 91 | 92 | col :: CodeZipper t -> Int 93 | col = lineWidth . tokensBefore 94 | 95 | currentToken :: Eq t => CodeZipper t -> Maybe (Token t) 96 | currentToken CodeZipper{tokensBefore = []} = Nothing 97 | currentToken CodeZipper{tokensBefore = tb : _, tokensAfter = []} = Just tb 98 | currentToken CodeZipper{tokensBefore = tb : _, tokensAfter = ta : _} = Just $ maybe tb fst (uncons (normaliseToks [tb, ta])) 99 | 100 | nextChar :: CodeZipper t -> Maybe Char 101 | nextChar CodeZipper{tokensAfter = [], linesAfter = []} = Nothing 102 | nextChar CodeZipper{tokensAfter} = maybe (Just '\n') (Just . Text.head . tokenContent) $ find ((> 0) . tokenWidth) tokensAfter 103 | 104 | prevChar :: CodeZipper t -> Maybe Char 105 | prevChar CodeZipper{tokensBefore = [], linesBefore = []} = Nothing 106 | prevChar CodeZipper{tokensBefore} = maybe (Just '\n') (Just . Text.last . tokenContent) $ find ((> 0) . tokenWidth) tokensBefore 107 | 108 | textBefore :: CodeZipper t -> Text 109 | textBefore CodeZipper{linesBefore, tokensBefore} = 110 | Text.unlines (lineToText <$> reverse linesBefore) <> lineToText (reverse tokensBefore) 111 | 112 | textAfter :: CodeZipper t -> Text 113 | textAfter CodeZipper{linesAfter, tokensAfter} = 114 | Text.intercalate "\n" $ lineToText <$> (tokensAfter : linesAfter) 115 | 116 | toText :: CodeZipper t -> Text 117 | toText cz = textBefore cz <> textAfter cz 118 | 119 | textBetween :: Eq t => Int -> Int -> CodeZipper t -> Text 120 | textBetween = (((Text.unlines . fmap lineToText) .) .) . linesBetween 121 | 122 | lineToText :: SourceLine t -> Text 123 | lineToText line = mconcat $ tokenContent <$> line 124 | 125 | insert :: (Eq t, Pretty t) => Text -> CodeZipper t -> CodeZipper t 126 | insert t cz@CodeZipper{..} = 127 | cz 128 | { tokensAfter = NonEmpty.head insertedLines' 129 | , linesAfter = NonEmpty.tail insertedLines' <> linesAfter 130 | } 131 | & downN (NonEmpty.length insertedLines - 1) 132 | & (if length insertedLines > 1 then home else id) 133 | & rightN (lineWidth $ NonEmpty.last insertedLines) 134 | & prettifyZipper 135 | where 136 | insertedLines = uncurry (:|) $ fromMaybe ([], []) $ uncons (plain t) 137 | insertedLines' = insertedLines & overLast (<> tokensAfter) 138 | 139 | prettifyZipper :: (Eq t, Pretty t) => CodeZipper t -> CodeZipper t 140 | prettifyZipper cz@CodeZipper{language} = 141 | maybe cz (rightN (col cz) . downN (row cz)) $ 142 | prettyZipper language $ 143 | toText cz 144 | 145 | overLast :: (a -> a) -> NonEmpty a -> NonEmpty a 146 | overLast f = NonEmpty.reverse . (\(x :| xs) -> f x :| xs) . NonEmpty.reverse 147 | 148 | insertChar :: (Eq t, Pretty t) => Char -> CodeZipper t -> CodeZipper t 149 | insertChar = insert . Text.singleton 150 | 151 | left :: Eq t => CodeZipper t -> CodeZipper t 152 | left cz@CodeZipper{tokensBefore = []} = cz 153 | left cz@CodeZipper{tokensBefore = tb : tbs, tokensAfter} = 154 | cz 155 | { tokensBefore = normaliseToks $ tb' : tbs 156 | , tokensAfter = normaliseToks $ ta' : tokensAfter 157 | } 158 | where 159 | (tb', ta') = splitTokenAt (tokenWidth tb - 1) tb 160 | 161 | leftN :: Eq t => Int -> CodeZipper t -> CodeZipper t 162 | leftN n cz 163 | | n < 1 = cz 164 | | otherwise = iterate left cz !! n 165 | 166 | right :: Eq t => CodeZipper t -> CodeZipper t 167 | right cz@CodeZipper{tokensAfter = []} = cz 168 | right cz@CodeZipper{tokensAfter = ta : tas, tokensBefore} = 169 | cz 170 | { tokensBefore = reverse $ normaliseToks $ reverse $ tb' : tokensBefore 171 | , tokensAfter = normaliseToks $ ta' : tas 172 | } 173 | where 174 | (tb', ta') = splitTokenAt 1 ta 175 | 176 | rightN :: Eq t => Int -> CodeZipper t -> CodeZipper t 177 | rightN n cz 178 | | n < 1 = cz 179 | | otherwise = iterate right cz !! n 180 | 181 | -- | Go to the beginning of the current line. 182 | home :: Eq t => CodeZipper t -> CodeZipper t 183 | home cz = 184 | cz 185 | { tokensBefore = [] 186 | , tokensAfter = currentLine cz 187 | } 188 | 189 | -- | Go to the end of the current line. 190 | end :: Eq t => CodeZipper t -> CodeZipper t 191 | end cz = 192 | cz 193 | { tokensAfter = [] 194 | , tokensBefore = reverse $ currentLine cz 195 | } 196 | 197 | deleteLeft :: (Eq t, Pretty t) => CodeZipper t -> CodeZipper t 198 | deleteLeft cz@CodeZipper{tokensBefore = [], linesBefore = []} = cz 199 | deleteLeft cz@CodeZipper{tokensBefore = [], linesBefore = lb : lbs} = 200 | cz 201 | { linesBefore = lbs 202 | , tokensBefore = reverse lb 203 | } 204 | & prettifyZipper 205 | deleteLeft cz@CodeZipper{tokensBefore = tb : tbs} = 206 | cz 207 | { tokensBefore = normaliseToks $ tb' : tbs 208 | } 209 | & prettifyZipper 210 | where 211 | (tb', _) = splitTokenAt (tokenWidth tb - 1) tb 212 | 213 | deleteRight :: (Eq t, Pretty t) => CodeZipper t -> CodeZipper t 214 | deleteRight cz@CodeZipper{tokensAfter = [], linesAfter = []} = cz 215 | deleteRight cz@CodeZipper{tokensAfter = [], linesAfter = la : las} = 216 | cz 217 | { linesAfter = las 218 | , tokensAfter = la 219 | } 220 | & prettifyZipper 221 | deleteRight cz@CodeZipper{tokensAfter = ta : tas} = 222 | cz 223 | { tokensAfter = normaliseToks $ ta' : tas 224 | } 225 | & prettifyZipper 226 | where 227 | (_, ta') = splitTokenAt 1 ta 228 | 229 | -- | Go up to the previous line and try to preserve the current column. 230 | up :: Eq t => CodeZipper t -> CodeZipper t 231 | up cz@CodeZipper{linesBefore = []} = cz 232 | up cz@CodeZipper{tokensBefore} = up' cz & rightN (lineWidth tokensBefore) 233 | 234 | -- | Go up to the beginning of the previous line. 235 | up' :: Eq t => CodeZipper t -> CodeZipper t 236 | up' cz@CodeZipper{linesBefore = []} = cz 237 | up' cz@CodeZipper{linesBefore = lb : lbs, linesAfter} = 238 | cz 239 | { linesBefore = lbs 240 | , linesAfter = normaliseToks (currentLine cz) : linesAfter 241 | , tokensBefore = [] 242 | , tokensAfter = lb 243 | } 244 | 245 | -- | Go up N lines and try to preserve the current column. 246 | upN :: Eq t => Int -> CodeZipper t -> CodeZipper t 247 | upN _ cz@CodeZipper{linesBefore = []} = cz 248 | upN n cz@CodeZipper{tokensBefore} 249 | | n < 1 = cz 250 | | otherwise = 251 | (iterate up' cz !! n) 252 | & rightN (lineWidth tokensBefore) 253 | 254 | -- | Move to the specifid row and try to preserve the current column. 255 | goToRow :: Eq t => Int -> CodeZipper t -> CodeZipper t 256 | goToRow r cz 257 | | dr < 0 = downN (abs dr) cz 258 | | dr > 0 = upN dr cz 259 | | otherwise = cz 260 | where 261 | dr = row cz - r 262 | 263 | -- | Go down to the next line and try to preserve the current column. 264 | down :: Eq t => CodeZipper t -> CodeZipper t 265 | down cz@CodeZipper{linesAfter = []} = cz 266 | down cz@CodeZipper{tokensBefore} = cz & down' & rightN (lineWidth tokensBefore) 267 | 268 | -- | Go down to the beginning of the next line. 269 | down' :: Eq t => CodeZipper t -> CodeZipper t 270 | down' cz@CodeZipper{linesAfter = []} = cz 271 | down' cz@CodeZipper{linesAfter = la : las, linesBefore} = 272 | cz 273 | { linesAfter = las 274 | , linesBefore = currentLine cz : linesBefore 275 | , tokensBefore = [] 276 | , tokensAfter = la 277 | } 278 | 279 | -- | Go down N lines and try to preserve the current column. 280 | downN :: Eq t => Int -> CodeZipper t -> CodeZipper t 281 | downN _ cz@CodeZipper{linesAfter = []} = cz 282 | downN n cz@CodeZipper{tokensBefore} 283 | | n < 1 = cz 284 | | otherwise = 285 | (iterate down' cz !! n) 286 | & rightN (lineWidth tokensBefore) 287 | 288 | -- | Go to the first line and try to preserve the current column. 289 | top :: Eq t => CodeZipper t -> CodeZipper t 290 | top cz@CodeZipper{linesBefore} = length linesBefore `upN` cz 291 | 292 | -- | Go to the last line and try to preserve the current column. 293 | bottom :: Eq t => CodeZipper t -> CodeZipper t 294 | bottom cz@CodeZipper{linesAfter} = length linesAfter `downN` cz 295 | 296 | mapTokenContent :: (Text -> Text) -> Token t -> Token t 297 | mapTokenContent f t = t{tokenContent = f t.tokenContent} 298 | 299 | tokenWidth :: Token t -> Int 300 | tokenWidth = Text.length . tokenContent 301 | 302 | nullToken :: Token t -> Bool 303 | nullToken = Text.null . tokenContent 304 | 305 | append :: Text -> Token t -> Token t 306 | append t = mapTokenContent (<> t) 307 | 308 | prepend :: Text -> Token t -> Token t 309 | prepend t = mapTokenContent (t <>) 310 | 311 | lineWidth :: SourceLine t -> Int 312 | lineWidth = sum . fmap tokenWidth 313 | 314 | splitTokenAt :: Int -> Token t -> (Token t, Token t) 315 | splitTokenAt i t | i < 0 = splitTokenAt 0 t 316 | splitTokenAt i t = (t{tokenContent = a}, t{tokenContent = b}) 317 | where 318 | (a, b) = Text.splitAt i t.tokenContent 319 | 320 | splitTokenAt' :: Int -> Token t -> (Token t, Token t, Token t) 321 | splitTokenAt' i t = (a, b, c') 322 | where 323 | (a, c) = splitTokenAt i t 324 | (b, c') = splitTokenAt 1 c 325 | 326 | normaliseToks :: forall t. Eq t => [Token t] -> [Token t] 327 | normaliseToks = foldr maybePrepend [] 328 | where 329 | maybePrepend :: Token t -> [Token t] -> [Token t] 330 | maybePrepend (nullToken -> True) acc = acc 331 | maybePrepend t (p : ps) | t.tokenType == p.tokenType = prepend t.tokenContent p : ps 332 | maybePrepend t ps = t : ps 333 | 334 | tokenLines :: Token t -> [Token t] 335 | tokenLines t = Text.splitOn "\n" t.tokenContent <&> \c -> t{tokenContent = c} 336 | -------------------------------------------------------------------------------- /dosh/src/Dosh/Cell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Dosh.Cell where 5 | 6 | import Control.Monad.Fix 7 | import Data.Default (Default) 8 | import Data.Generics.Labels () 9 | import Data.List (sortBy) 10 | import Data.List.Extra (groupOn) 11 | import Data.Ord (comparing) 12 | import Data.Text qualified as Text 13 | import Data.Text.CodeZipper qualified as CZ 14 | import Data.Text.Encoding qualified as Text 15 | import Data.Text.Zipper (Span (Span)) 16 | import Data.Tuple.Extra (thd3) 17 | import Data.UUID (UUID) 18 | import Data.UUID qualified as UUID 19 | import Data.UUID.V4 qualified as UUID 20 | import Dosh.Prelude 21 | import Dosh.Util 22 | import Graphics.Vty qualified as V 23 | import Language.Haskell.TH.Syntax (thenCmp) 24 | import Language.LSP.Types (Diagnostic, DiagnosticSeverity (..)) 25 | import Language.LSP.Types.Lens (message, severity) 26 | import Reflex 27 | import Reflex.Vty 28 | import Reflex.Vty.Widget.Input.Code 29 | import Skylighting (TokenType) 30 | 31 | type CodeZipper = CZ.CodeZipper TokenType 32 | 33 | data Cell = Cell 34 | { uid :: UUID 35 | , number :: Int 36 | , firstLine :: Int 37 | , input :: CodeZipper 38 | , output :: Maybe ByteString 39 | , error :: Maybe Text 40 | , disabled :: Bool 41 | , evaluated :: Bool 42 | , diagnostics :: [Diagnostic] 43 | } 44 | deriving stock (Generic, Eq, Show) 45 | 46 | newCell :: MonadIO m => (Cell -> Cell) -> m Cell 47 | newCell f = liftIO UUID.nextRandom <&> \uid -> f def{uid} 48 | 49 | instance Default Cell where 50 | def = 51 | Cell 52 | { uid = UUID.nil 53 | , number = 0 54 | , firstLine = 0 55 | , input = mempty 56 | , output = Nothing 57 | , error = Nothing 58 | , disabled = True 59 | , evaluated = False 60 | , diagnostics = [] 61 | } 62 | 63 | lastLine :: Cell -> Int 64 | lastLine Cell{..} = firstLine + CZ.lines input 65 | 66 | data CellEvent 67 | = UpdateCellInput InputUpdate 68 | | UpdateCellCursor CursorMove 69 | | EvaluateCell 70 | | GoToPreviousCell 71 | | GoToNextCell 72 | 73 | data CursorMove 74 | = CursorUp Int 75 | | CursorDown Int 76 | | CursorLeft Int 77 | | CursorRight Int 78 | | CursorHome 79 | | CursorEnd 80 | | CursorTop 81 | | CursorBottom 82 | 83 | moveCursor :: CursorMove -> (CodeZipper -> CodeZipper) 84 | moveCursor (CursorUp n) = CZ.upN n 85 | moveCursor (CursorDown n) = CZ.downN n 86 | moveCursor (CursorLeft n) = CZ.leftN n 87 | moveCursor (CursorRight n) = CZ.rightN n 88 | moveCursor CursorHome = CZ.home 89 | moveCursor CursorEnd = CZ.end 90 | moveCursor CursorTop = CZ.top 91 | moveCursor CursorBottom = CZ.bottom 92 | 93 | data InputUpdate 94 | = DeleteLeft 95 | | DeleteRight 96 | | Insert Text 97 | 98 | updateZipper :: InputUpdate -> (CodeZipper -> CodeZipper) 99 | updateZipper DeleteLeft = CZ.deleteLeft 100 | updateZipper DeleteRight = CZ.deleteRight 101 | updateZipper (Insert t) = CZ.insert t 102 | 103 | cell 104 | :: forall t m 105 | . ( PerformEvent t m 106 | , TriggerEvent t m 107 | , HasFocusReader t m 108 | , HasImageWriter t m 109 | , HasInput t m 110 | , HasLayout t m 111 | , HasDisplayRegion t m 112 | , MonadFix m 113 | , HasTheme t m 114 | , MonadHold t m 115 | , MonadIO (Performable m) 116 | ) 117 | => Cell 118 | -> m (Event t CellEvent) 119 | cell c = do 120 | let inPrompt = mconcat [if c.evaluated then "*" else " ", "In[", tshow c.number, "]: "] 121 | outPrompt = "Out[" <> tshow c.number <> "]: " 122 | errPrompt = "Err[" <> tshow c.number <> "]: " 123 | virtualLines :: [(Int, [Span V.Attr])] 124 | virtualLines = concatMap diagLines $ groupOn diagnosticLine $ sortBy diagOrd c.diagnostics 125 | where 126 | diagOrd :: Diagnostic -> Diagnostic -> Ordering 127 | diagOrd d1 d2 = comparing diagnosticLine d1 d2 `thenCmp` comparing diagnosticChar d1 d2 128 | diagLines :: [Diagnostic] -> [(Int, [Span V.Attr])] 129 | diagLines = 130 | thd3 131 | . foldl' 132 | ( \(padWidth, pads, lines) d -> 133 | let c = diagnosticChar d 134 | deltaC = c - padWidth 135 | BoxStyle{..} = roundedBoxStyle 136 | newPads = [Span V.currentAttr spaces | let spaces = Text.replicate deltaC " ", not (Text.null spaces)] 137 | newPipe = [Span (diagAttr d) (Text.singleton _boxStyle_e) | deltaC > 0 || padWidth == 0] 138 | newLines = 139 | Text.lines (prependAndPadLines (Text.pack [_boxStyle_sw, _boxStyle_s, ' ']) $ d ^. message) <&> \l -> 140 | (diagnosticLine d, pads <> newPads <> [Span (diagAttr d) l]) 141 | in ( c + 1 142 | , pads <> newPads <> newPipe 143 | , newLines <> lines 144 | ) 145 | ) 146 | (0, [], []) 147 | diagAttr :: Diagnostic -> V.Attr 148 | diagAttr = 149 | view severity >>> \case 150 | Just DsError -> V.withForeColor V.currentAttr V.red 151 | Just DsWarning -> V.withForeColor V.currentAttr V.magenta 152 | _ -> V.currentAttr 153 | (cellEvent, triggerCellEvent) <- newTriggerEvent 154 | unless c.disabled $ void $ do 155 | vtyInput :: Event t VtyEvent <- Reflex.Vty.input 156 | dh :: Dynamic t Int <- displayHeight 157 | let updateZipper = triggerCellEvent . UpdateCellInput 158 | updateCursor = triggerCellEvent . UpdateCellCursor 159 | performEvent $ 160 | current dh `attach` vtyInput <&> \(dh, ev) -> 161 | liftIO $ case ev of 162 | -- Delete character in zipper 163 | V.EvKey V.KBS [] -> updateZipper DeleteLeft 164 | V.EvKey V.KDel [] -> updateZipper DeleteRight 165 | -- Movement in zipper and between cells 166 | V.EvKey V.KUp [] -> 167 | if null c.input.linesBefore 168 | then triggerCellEvent GoToPreviousCell 169 | else updateCursor $ CursorUp 1 170 | V.EvKey V.KDown [] -> 171 | if null c.input.linesAfter 172 | then triggerCellEvent GoToNextCell 173 | else updateCursor $ CursorDown 1 174 | V.EvKey V.KLeft [] -> updateCursor $ CursorLeft 1 175 | V.EvKey V.KRight [] -> updateCursor $ CursorRight 1 176 | V.EvKey V.KHome [] -> updateCursor CursorHome 177 | V.EvKey V.KEnd [] -> updateCursor CursorEnd 178 | V.EvKey V.KPageUp [] -> updateCursor $ CursorUp dh 179 | V.EvKey V.KPageDown [] -> updateCursor $ CursorDown dh 180 | -- Insert characters into zipper 181 | V.EvKey (V.KChar '\t') [] -> do 182 | -- move to the next multiple of 4 183 | let x = CZ.col c.input 184 | dx = 4 - mod x 4 185 | updateZipper $ Insert $ Text.replicate dx " " 186 | V.EvKey (V.KChar k) [] -> updateZipper $ Insert $ Text.singleton k 187 | V.EvKey V.KEnter [V.MMeta] -> updateZipper $ Insert $ Text.singleton '\n' 188 | -- Evaluate the cell if it has any input 189 | V.EvKey V.KEnter [] -> triggerCellEvent EvaluateCell 190 | _ -> pure () 191 | grout (fixed $ pure $ length virtualLines + CZ.lines c.input) $ row $ do 192 | grout (fixed $ pure $ Text.length inPrompt) $ text $ pure inPrompt 193 | -- let w = length (show $ lastLine c) 194 | -- grout (fixed $ pure $ w + 1) $ col $ forM_ [firstLine c .. lastLine c] $ \l -> 195 | -- let t = tshow l 196 | -- pad = w - Text.length t 197 | -- tp = Text.replicate pad " " <> t 198 | -- in grout (fixed $ pure 1) $ dimText $ pure tp 199 | grout flex $ 200 | codeInput 201 | def 202 | { _codeInputConfig_value = Just $ pure c.input 203 | , _codeInputConfig_virtualLines = virtualLines 204 | , _codeInputConfig_showCursor = not c.disabled 205 | } 206 | forM_ c.output $ \out -> do 207 | blankLine 208 | let (height, content) = case Text.decodeUtf8' out of 209 | Right utf8 -> (length $ Text.lines utf8, text $ pure utf8) 210 | Left _ -> (10, display $ pure out) 211 | grout (fixed $ pure height) $ row $ do 212 | grout (fixed $ pure $ Text.length outPrompt) $ text $ pure outPrompt 213 | grout flex content 214 | forM_ c.error $ \err -> do 215 | blankLine 216 | grout (fixed $ pure $ length $ Text.lines err) $ row $ do 217 | grout (fixed $ pure $ Text.length errPrompt) $ text $ pure errPrompt 218 | grout flex $ colorText V.red $ pure err 219 | blankLine 220 | pure cellEvent 221 | 222 | colorText :: forall t m. (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => V.Color -> Behavior t Text -> m () 223 | colorText c = richText RichTextConfig{_richTextConfig_attributes = pure $ V.withForeColor V.currentAttr c} 224 | 225 | dimText :: forall t m. (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Text -> m () 226 | dimText = richText RichTextConfig{_richTextConfig_attributes = pure $ V.withStyle V.currentAttr V.dim} 227 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 5 | {-# OPTIONS_GHC -Wno-orphans #-} 6 | {-# OPTIONS_GHC -Wno-partial-fields #-} 7 | 8 | module Dosh.GHC.Client where 9 | 10 | import Control.Monad.Reader (ReaderT (..)) 11 | import Data.ByteString (hGetSome) 12 | import Data.ByteString.Builder.Extra (defaultChunkSize) 13 | import Data.Generics.Labels () 14 | import Data.UUID (UUID) 15 | import Dosh.GHC.Evaluator qualified as GHC 16 | import Dosh.GHC.Server (Server (..)) 17 | import Dosh.Prelude 18 | import Dosh.Util 19 | import GHC.Driver.Monad (Ghc (..), Session (..)) 20 | import Reflex hiding (Request, Response) 21 | 22 | data Request = Evaluate {uid :: UUID, content :: Text} 23 | 24 | data Response 25 | = FullResponse {uid :: UUID, content :: ByteString} 26 | | PartialResponse {uid :: UUID, content :: ByteString} 27 | | Error {uid :: UUID, error :: SomeException} 28 | | EndResponse {uid :: UUID} 29 | 30 | data Client t = Client 31 | { request :: Request -> IO () 32 | , onResponse :: Event t Response 33 | } 34 | 35 | client 36 | :: forall t m 37 | . ( TriggerEvent t m 38 | , PerformEvent t m 39 | , MonadIO (Performable m) 40 | ) 41 | => Server t 42 | -> m (Client t) 43 | client ghc = do 44 | (onRequest, request) <- newTriggerEvent 45 | (onResponse, respond) <- newTriggerEvent 46 | performEvent $ 47 | onRequest <&> \case 48 | Evaluate{..} -> liftIO $ do 49 | mv <- newEmptyMVar 50 | ghc.input $ do 51 | let exec = do 52 | GHC.evaluate content 53 | GHC.evaluate "mapM_ hFlush [stdout, stderr]" 54 | let log = forever $ liftIO $ do 55 | content <- hGetSome ghc.output defaultChunkSize 56 | respond PartialResponse{..} 57 | race_ exec log `catch` \error -> liftIO (respond Error{..}) 58 | liftIO $ respond EndResponse{..} 59 | putMVar mv () 60 | readMVar mv 61 | pure Client{..} 62 | 63 | deriving via (ReaderT Session IO) instance MonadUnliftIO Ghc 64 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Dosh.GHC.Evaluator where 2 | 3 | import Data.Text qualified as Text 4 | import Development.IDE.GHC.Compat.Core (GhcMonad) 5 | import Dosh.GHC.Lexer 6 | import Dosh.GHC.Parser 7 | import Dosh.Prelude hiding (mod) 8 | import GHC (execOptions, execStmt, runParsedDecls) 9 | 10 | evaluate :: GhcMonad m => Text -> m () 11 | evaluate (chunkFromText "" 1 -> chunk) = do 12 | forM_ (splitChunks chunk) $ parseChunk >=> evaluateChunk 13 | 14 | evaluateChunk :: GhcMonad m => ParsedChunk -> m () 15 | evaluateChunk (ExpressionChunk exprs) = 16 | -- TODO: evaluate in single-step mode instead of all at once 17 | forM_ exprs $ \e -> execStmt (Text.unpack $ unLoc e) execOptions 18 | evaluateChunk (DeclarationChunk decls) = 19 | void $ runParsedDecls decls 20 | evaluateChunk (ModuleChunk _) = 21 | void $ execStmt "putStrLn \"Modules are not yet supported\"" execOptions 22 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Dosh.GHC.Lexer 5 | ( module GHC.Types.SrcLoc 6 | , Chunk 7 | , chunkFromText 8 | , splitChunks 9 | , splitExpressions 10 | , chunkLines 11 | , chunkUnlines 12 | , firstLine 13 | , lastLine 14 | ) 15 | where 16 | 17 | import Data.Text qualified as Text 18 | import Dosh.Prelude 19 | import Dosh.Util 20 | import GHC.Data.FastString 21 | import GHC.Types.SrcLoc 22 | 23 | type Chunk = RealLocated Text 24 | 25 | #if !MIN_VERSION_ghc(9,4,0) 26 | deriving stock instance Show Chunk 27 | #endif 28 | 29 | chunkFromText :: FastString -> Int -> Text -> Chunk 30 | chunkFromText file firstLine t = L (mkRealSrcSpan a b) t 31 | where 32 | a = mkRealSrcLoc file firstLine 1 33 | b = mkRealSrcLoc file (firstLine + Text.count "\n" t) (max 1 $ Text.length $ last ts) 34 | ts = Text.splitOn "\n" t 35 | 36 | {- | Split a code object into chunks. A chunk is a sequence of lines that should be evaluated in the same way; 37 | either as a module or as expressions. 38 | 39 | Chunks are separated by an empty line followed by a graphical character on the zero column. 40 | 41 | An example of code with four chunks that parse as expected: 42 | 43 | > {\-# LANGUAGE OverloadedStrings #-\} 44 | > 45 | > import Dosh.Prelude 46 | > import Data.Text qualified as Text 47 | > 48 | > startsWith :: (Char -> Bool) -> Text -> Bool 49 | > startsWith f = maybe False f . Text.uncons 50 | > 51 | > startsWith isSpace "example" 52 | 53 | If we remove the last empty line between the declaration and function call, 54 | the chunks will be merged and parsed as one: 55 | 56 | > startsWith :: (Char -> Bool) -> Text -> Bool 57 | > startsWith f = maybe False f . Text.uncons 58 | > startsWith isSpace "example" 59 | 60 | This will cause a parsing error, because expressions are not allowed in a module chunk. 61 | -} 62 | splitChunks :: Chunk -> [Chunk] 63 | splitChunks chunk = reverse $ foldl' appendLine [] $ chunkLines chunk 64 | where 65 | appendLine :: [Chunk] -> Chunk -> [Chunk] 66 | appendLine [] line = [line] 67 | appendLine (c : cs) line 68 | | maybeStartsWith True isSpace (unLoc line) || not (isNewline c) = 69 | chunkUnlines [c, line] : cs 70 | | otherwise = line : c : cs 71 | isNewline :: Chunk -> Bool 72 | isNewline = maybeEndsWith True (== '\n') . unLoc 73 | 74 | {- | Split a code object into expressions. 75 | 76 | Expressions are lines that start with a graphical character on the zero column. 77 | -} 78 | splitExpressions :: Chunk -> [Chunk] 79 | splitExpressions chunk = reverse $ foldl' appendLine [] $ chunkLines chunk 80 | where 81 | appendLine :: [Chunk] -> Chunk -> [Chunk] 82 | appendLine [] line = [line] 83 | appendLine (e : es) line 84 | | maybeStartsWith False isSpace (unLoc line) = 85 | chunkUnlines [e, line] : es 86 | | otherwise = line : e : es 87 | 88 | chunkLines :: Chunk -> [Chunk] 89 | chunkLines c@(L loc t) 90 | | null ts = [L loc ""] 91 | | otherwise = uncurry line <$> zip [0 ..] ts 92 | where 93 | file = srcSpanFile loc 94 | line i = chunkFromText file (firstLine c + i) 95 | ts = Text.splitOn "\n" t 96 | 97 | chunkUnlines :: [Chunk] -> Chunk 98 | chunkUnlines ts@((realSrcSpanStart . getLoc -> start) : _) = chunkFromText (srcLocFile start) (srcLocLine start) $ Text.intercalate "\n" $ unLoc <$> ts 99 | chunkUnlines [] = error "locatedUnlines: cannot locate empty list" 100 | 101 | firstLine :: GenLocated RealSrcSpan e -> Int 102 | firstLine = srcLocLine . realSrcSpanStart . getLoc 103 | 104 | lastLine :: GenLocated RealSrcSpan e -> Int 105 | lastLine = srcLocLine . realSrcSpanEnd . getLoc 106 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Dosh.GHC.Parser where 5 | 6 | import Data.Text qualified as Text 7 | import Development.IDE (runParser) 8 | import Development.IDE.GHC.Compat.Core (DynFlags, GhcMonad, GhcPs, HsModule (..), LHsDecl, getSessionDynFlags, parseExpression, parseModule) 9 | import Dosh.GHC.Lexer 10 | import Dosh.Prelude 11 | import GHC.Parser.Lexer 12 | 13 | data ParsedChunk 14 | = ModuleChunk HsModule 15 | | ExpressionChunk [Chunk] 16 | | DeclarationChunk [LHsDecl GhcPs] 17 | 18 | parseChunk :: forall m. GhcMonad m => Chunk -> m ParsedChunk 19 | parseChunk c = do 20 | flags <- getSessionDynFlags 21 | let def = ExpressionChunk [c] 22 | parsed = foldr1 (<|>) $ [parseModuleChunk, parseExprChunk, parseDeclChunk] <&> (c &) . (flags &) 23 | pure $ fromMaybe def parsed 24 | 25 | parseModuleChunk :: DynFlags -> Chunk -> Maybe ParsedChunk 26 | parseModuleChunk flags (Text.unpack . unLoc -> code) = case runParser flags code parseModule of 27 | POk _ (unLoc -> mod@(hsmodName -> Just _)) -> Just $ ModuleChunk mod 28 | _ -> Nothing 29 | 30 | parseExprChunk :: DynFlags -> Chunk -> Maybe ParsedChunk 31 | parseExprChunk flags (splitExpressions -> exprs) 32 | | all isExpr exprs = Just $ ExpressionChunk exprs 33 | | otherwise = Nothing 34 | where 35 | isExpr (unLoc -> "") = True 36 | isExpr (Text.unpack . unLoc -> code) = case runParser flags code parseExpression of 37 | POk{} -> True 38 | _ -> False 39 | 40 | parseDeclChunk :: DynFlags -> Chunk -> Maybe ParsedChunk 41 | parseDeclChunk flags (Text.unpack . unLoc -> code) = case runParser flags code parseModule of 42 | POk _ (hsmodDecls . unLoc -> decls) -> Just $ DeclarationChunk decls 43 | _ -> Nothing 44 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Server.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Dosh.GHC.Server where 4 | 5 | import Control.Monad.Catch (MonadMask, bracket, catch) 6 | import Dosh.GHC.Session qualified as GHC 7 | import Dosh.Prelude hiding (bracket, catch) 8 | import Dosh.Util 9 | import GHC (DynFlags, Ghc, getSessionDynFlags, runGhc) 10 | import GHC.IO.Handle (hDuplicate, hDuplicateTo) 11 | import GHC.Paths qualified as GHC 12 | import Reflex 13 | ( Event 14 | , TriggerEvent (newTriggerEvent) 15 | ) 16 | import System.Process (createPipe) 17 | 18 | data Server t = Server 19 | { input :: Ghc () -> IO () 20 | , output :: Handle 21 | , error :: Handle 22 | , onError :: Event t SomeException 23 | } 24 | 25 | server 26 | :: forall t m 27 | . ( TriggerEvent t m 28 | , MonadIO m 29 | ) 30 | => m (Server t) 31 | server = do 32 | (onError, reportError) <- newTriggerEvent 33 | (input, output, error) <- liftIO $ asyncServer reportError 34 | pure Server{..} 35 | 36 | asyncServer :: (SomeException -> IO ()) -> IO (Ghc () -> IO (), Handle, Handle) 37 | asyncServer reportError = do 38 | -- TODO: try to use Knob rather than pipes 39 | (outRead, outWrite) <- createPipe 40 | hSetBuffering outRead NoBuffering 41 | hSetBuffering outWrite NoBuffering 42 | (errRead, errWrite) <- createPipe 43 | hSetBuffering errRead NoBuffering 44 | hSetBuffering errWrite NoBuffering 45 | sessionActions <- newTQueueIO 46 | void $ forkIO $ runGhc (Just GHC.libdir) $ do 47 | GHC.initialiseSession 48 | forever $ do 49 | action <- atomically $ readTQueue sessionActions 50 | hCapture [(stdout, outWrite), (stderr, errWrite)] action 51 | `catch` (liftIO . reportError) 52 | let input = atomically . writeTQueue sessionActions 53 | pure (input, outRead, errRead) 54 | 55 | testServer :: Ghc () -> IO (ByteString, ByteString, [SomeException]) 56 | testServer action = do 57 | errors <- newMVar [] 58 | let reportError :: SomeException -> IO () 59 | reportError = modifyMVar_ errors . (pure .) . (:) 60 | (i, o, e) <- asyncServer reportError 61 | i action 62 | threadDelay 1_000 63 | (,,) <$> getAvailableContents o <*> getAvailableContents e <*> takeMVar errors 64 | 65 | withGhc :: Ghc a -> IO (Either SomeException a) 66 | withGhc action = try $ runGhc (Just GHC.libdir) $ do 67 | GHC.initialiseSession 68 | action 69 | 70 | getSessionDynFlags :: Server t -> IO GHC.DynFlags 71 | getSessionDynFlags s = do 72 | flags <- newEmptyMVar 73 | s.input $ GHC.getSessionDynFlags >>= putMVar flags 74 | takeMVar flags 75 | 76 | hCapture :: forall m a. (MonadIO m, MonadMask m) => [(Handle, Handle)] -> m a -> m a 77 | hCapture handleMap action = go handleMap 78 | where 79 | go :: [(Handle, Handle)] -> m a 80 | go [] = action 81 | go ((oldHandle, newHandle) : hs) = do 82 | buffering <- liftIO $ hGetBuffering oldHandle 83 | let redirect = liftIO $ do 84 | old <- hDuplicate oldHandle 85 | hDuplicateTo newHandle oldHandle 86 | pure old 87 | restore old = liftIO $ do 88 | hDuplicateTo old oldHandle 89 | hSetBuffering oldHandle buffering 90 | hClose old 91 | bracket redirect restore (const $ go hs) 92 | 93 | hReset :: Handle -> IO () 94 | hReset h = hSeek h AbsoluteSeek 0 95 | -------------------------------------------------------------------------------- /dosh/src/Dosh/GHC/Session.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Dosh.GHC.Session where 4 | 5 | import Data.Text (stripPrefix, unpack) 6 | import Development.IDE.GHC.Compat qualified as GHC 7 | import Dosh.Prelude 8 | import Dosh.Util 9 | import GHC (GhcMonad) 10 | import GHC qualified 11 | import GHC.Driver.Session qualified as GHC 12 | import GHC.Platform.Ways qualified as GHC 13 | import Language.Haskell.TH.LanguageExtensions 14 | 15 | deriving stock instance Generic GHC.DynFlags 16 | 17 | setExtension :: GHC.Extension -> GHC.DynFlags -> GHC.DynFlags 18 | setExtension = flip GHC.xopt_set 19 | 20 | unsetExtension :: GHC.Extension -> GHC.DynFlags -> GHC.DynFlags 21 | unsetExtension = flip GHC.xopt_unset 22 | 23 | setGeneral :: GHC.GeneralFlag -> GHC.DynFlags -> GHC.DynFlags 24 | setGeneral = flip GHC.gopt_set 25 | 26 | unsetGeneral :: GHC.GeneralFlag -> GHC.DynFlags -> GHC.DynFlags 27 | unsetGeneral = flip GHC.gopt_unset 28 | 29 | setWay :: GHC.Way -> GHC.DynFlags -> GHC.DynFlags 30 | setWay w dflags0 = 31 | let platform = GHC.targetPlatform dflags0 32 | dflags1 = dflags0{GHC.targetWays_ = GHC.addWay w (GHC.targetWays_ dflags0)} 33 | dflags2 = foldr GHC.setGeneralFlag' dflags1 (GHC.wayGeneralFlags platform w) 34 | dflags3 = foldr GHC.unSetGeneralFlag' dflags2 (GHC.wayUnsetGeneralFlags platform w) 35 | in dflags3 36 | 37 | overDynFlags :: GhcMonad m => (GHC.DynFlags -> GHC.DynFlags) -> m () 38 | overDynFlags f = 39 | GHC.getSessionDynFlags 40 | >>= ((GHC.getLogger >>=) . (liftIO .) . flip GHC.interpretPackageEnv) 41 | >>= GHC.setSessionDynFlags . f 42 | 43 | initialiseSession :: GhcMonad m => m () 44 | initialiseSession = do 45 | overDynFlags $ 46 | #backend .~ GHC.Interpreter 47 | >>> setGeneral GHC.Opt_GhciSandbox 48 | >>> filtered (const GHC.hostIsDynamic) %~ setWay GHC.WayDyn 49 | >>> unsetExtension GHC.MonomorphismRestriction 50 | >>> setExtension GHC.IncoherentInstances 51 | >>> setExtension GHC.ApplicativeDo 52 | >>> setExtension GHC.RecursiveDo 53 | addImport "Dosh.Prelude" 54 | 55 | deriving stock instance Generic (GHC.ImportDecl GHC.GhcPs) 56 | 57 | addImport :: GhcMonad m => Text -> m () 58 | addImport lib = do 59 | parsed <- GHC.parseImportDecl $ "import " <> unpack lib 60 | context <- GHC.getContext 61 | GHC.setContext $ GHC.IIDecl parsed : context 62 | 63 | deriving stock instance Read Extension 64 | 65 | enableExtension :: GhcMonad m => Extension -> m () 66 | enableExtension ext = overDynFlags $ setExtension ext 67 | 68 | disableExtension :: GhcMonad m => Extension -> m () 69 | disableExtension ext = overDynFlags $ unsetExtension ext 70 | 71 | applyExtensionText :: GhcMonad m => Text -> m () 72 | applyExtensionText (stripPrefix "No" -> Just ext@(maybeStartsWith True isUpper -> True)) = overDynFlags $ unsetExtension $ tread ext 73 | applyExtensionText ext = overDynFlags $ setExtension $ tread ext 74 | -------------------------------------------------------------------------------- /dosh/src/Dosh/LSP/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-partial-fields #-} 6 | 7 | module Dosh.LSP.Client where 8 | 9 | import Control.Concurrent.STM (flushTQueue) 10 | import Control.Monad.Extra (whenJust, whenJustM) 11 | import Control.Monad.State (execStateT) 12 | import Data.Coerce (coerce) 13 | import Data.HashMap.Internal.Strict (HashMap) 14 | import Data.HashMap.Strict qualified as HashMap 15 | import Data.Hashable (Hashable) 16 | import Data.Text qualified as Text 17 | import Data.Text.IO qualified as Text 18 | import Data.Text.Utf16.Rope (Rope) 19 | import Development.IDE (WithPriority) 20 | import Dosh.LSP.Document 21 | import Dosh.LSP.Server (Server (..)) 22 | import Dosh.Prelude hiding (List) 23 | import Language.LSP.Client.Session (Session) 24 | import Language.LSP.Client.Session qualified as LSP 25 | import Language.LSP.Types hiding (Initialize) 26 | import Language.LSP.Types qualified as LSP 27 | import Language.LSP.Types.Lens (uri) 28 | import Language.LSP.Types.Lens qualified as LSP 29 | import Reflex hiding (Request, Response) 30 | import Prelude hiding (id) 31 | 32 | data Request 33 | = Initialize {} 34 | | CreateDocument {document :: Document} 35 | | CloseDocument {identifier :: TextDocumentIdentifier} 36 | | ChangeDocument {identifier :: TextDocumentIdentifier, range :: Maybe Range, contents :: Text} 37 | | GetDocumentContents {identifier :: TextDocumentIdentifier} 38 | | GetCompletions {identifier :: TextDocumentIdentifier, position :: Position} 39 | 40 | data Response 41 | = DocumentContents {identifier :: TextDocumentIdentifier, contents :: Rope} 42 | | Diagnostics {identifier :: TextDocumentIdentifier, diagnostics :: [Diagnostic]} 43 | | Completions {identifier :: TextDocumentIdentifier, completions :: [CompletionItem]} 44 | 45 | data Client t = Client 46 | { request :: Request -> IO () 47 | , onResponse :: Event t Response 48 | , onError :: Event t SomeException 49 | , onLog :: Event t (WithPriority Text) 50 | } 51 | deriving stock (Generic) 52 | 53 | data DocumentState = DocumentState 54 | { document :: TVar Document 55 | , changes :: TQueue TextDocumentContentChangeEvent 56 | , updateThread :: ThreadId 57 | } 58 | deriving stock (Generic) 59 | 60 | modifyTMVar :: TMVar a -> (a -> Maybe a) -> STM () 61 | modifyTMVar var f = readTMVar var >>= mapM_ (putTMVar var) . f 62 | 63 | client 64 | :: forall t m 65 | . ( PerformEvent t m 66 | , TriggerEvent t m 67 | , MonadIO m 68 | , MonadIO (Performable m) 69 | ) 70 | => Server t 71 | -> m (Client t) 72 | client server = do 73 | (onRequest, request) <- newTriggerEvent 74 | (onResponse, respond) <- newTriggerEvent 75 | documentStates <- newTVarIO HashMap.empty 76 | liftIO . server.input $ do 77 | LSP.receiveNotification LSP.STextDocumentPublishDiagnostics $ \msg -> do 78 | let identifier = TextDocumentIdentifier $ msg ^. LSP.params . LSP.uri 79 | diagnostics = coerce $ msg ^. LSP.params . LSP.diagnostics 80 | maybeDiagnostics <- withDocumentState documentStates identifier $ \doc -> normaliseDiagnostics <$> readTVar doc.document <*> pure diagnostics 81 | whenJust maybeDiagnostics $ \diagnostics -> 82 | respond Diagnostics{..} 83 | performEvent $ liftIO . server.input . handleRequest respond documentStates <$> onRequest 84 | pure 85 | Client 86 | { request 87 | , onResponse 88 | , onError = server.error 89 | , onLog = server.log 90 | } 91 | 92 | tryReadTMVarIO :: MonadIO m => TMVar a -> m (Maybe a) 93 | tryReadTMVarIO = atomically . tryReadTMVar 94 | 95 | deriving stock instance Generic TextDocumentIdentifier 96 | 97 | deriving anyclass instance Hashable TextDocumentIdentifier 98 | 99 | withDocumentState :: MonadIO m => TVar (HashMap TextDocumentIdentifier DocumentState) -> TextDocumentIdentifier -> (DocumentState -> STM a) -> m (Maybe a) 100 | withDocumentState docs identifier f = atomically $ readTVar docs <&> preview (at identifier . traverse) >>= mapM f 101 | 102 | handleRequest :: (Response -> IO ()) -> TVar (HashMap TextDocumentIdentifier DocumentState) -> Request -> Session () 103 | handleRequest _ _ Initialize{} = LSP.initialize 104 | handleRequest _ docs CreateDocument{document = document@Document{..}} = do 105 | document <- newTVarIO document 106 | changes <- newTQueueIO 107 | updateThread <- forkIO $ forever $ do 108 | changes <- atomically $ peekTQueue changes >> flushTQueue changes 109 | readTVarIO document 110 | >>= execStateT (handleUpdates changes) 111 | >>= atomically . writeTVar document 112 | atomically $ modifyTVar docs $ HashMap.insert identifier DocumentState{..} 113 | liftIO $ Text.appendFile "dosh.log" $ "LSP.createDoc " <> Text.pack (identifier ^. uri & fromJust . uriToFilePath) 114 | void $ 115 | LSP.createDoc 116 | (identifier ^. uri & fromJust . uriToFilePath) 117 | language 118 | "" 119 | handleRequest _ docs CloseDocument{..} = do 120 | withDocumentState docs identifier (pure . updateThread) >>= mapM_ killThread 121 | atomically $ modifyTVar docs $ HashMap.delete identifier 122 | LSP.closeDoc identifier 123 | handleRequest _ docs ChangeDocument{..} = 124 | void $ 125 | withDocumentState docs identifier $ 126 | changes 127 | >>> flip 128 | writeTQueue 129 | TextDocumentContentChangeEvent 130 | { _range = range 131 | , _rangeLength = Nothing 132 | , _text = contents 133 | } 134 | handleRequest respond _ GetDocumentContents{..} = 135 | whenJustM (LSP.documentContents identifier) $ \contents -> 136 | liftIO $ respond DocumentContents{..} 137 | handleRequest respond _ GetCompletions{..} = 138 | void $ requestCompletions identifier position $ \completions -> 139 | liftIO $ respond Completions{..} 140 | 141 | -- | Requests the completions for the position in the document. 142 | requestCompletions 143 | :: TextDocumentIdentifier 144 | -> Position 145 | -> ([CompletionItem] -> IO ()) 146 | -> Session (LspId 'TextDocumentCompletion) 147 | requestCompletions doc pos callback = 148 | LSP.sendRequest 149 | STextDocumentCompletion 150 | CompletionParams 151 | { _textDocument = doc 152 | , _position = pos 153 | , _workDoneToken = Nothing 154 | , _partialResultToken = Nothing 155 | , _context = Nothing 156 | } 157 | $ LSP.getResponseResult 158 | >>> \case 159 | InL (List items) -> items 160 | InR (CompletionList{_items = List items}) -> items 161 | >>> callback 162 | 163 | -- | Returns the symbols in a document. 164 | requestDocumentSymbols 165 | :: TextDocumentIdentifier 166 | -> (Either [DocumentSymbol] [SymbolInformation] -> IO ()) 167 | -> Session (LspId 'TextDocumentDocumentSymbol) 168 | requestDocumentSymbols doc callback = do 169 | LSP.sendRequest 170 | STextDocumentDocumentSymbol 171 | DocumentSymbolParams 172 | { _workDoneToken = Nothing 173 | , _partialResultToken = Nothing 174 | , _textDocument = doc 175 | } 176 | $ LSP.getResponseResult 177 | >>> \case 178 | InL (List xs) -> Left xs 179 | InR (List xs) -> Right xs 180 | >>> callback 181 | -------------------------------------------------------------------------------- /dosh/src/Dosh/LSP/Document.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Dosh.LSP.Document where 4 | 5 | import Control.Monad.Extra (whenM) 6 | import Control.Monad.State (StateT, get, gets, lift, modify) 7 | import Data.HashSet (HashSet) 8 | import Data.HashSet qualified as HashSet 9 | import Data.Sequence (Seq) 10 | import Data.Sequence qualified as Seq 11 | import Data.Sequence.Zipper (SeqZipper, backWhile, forwardWhile) 12 | import Data.Text qualified as Text 13 | import Data.Text.IO qualified as Text 14 | import Data.Text.Utf16.Rope (Rope) 15 | import Data.Text.Utf16.Rope qualified as Rope 16 | import Data.UUID (UUID) 17 | import Data.UUID qualified as UUID 18 | import Data.UUID.V4 qualified as UUID 19 | import Dosh.GHC.Lexer qualified as GHC 20 | import Dosh.GHC.Parser qualified as GHC 21 | import Dosh.Prelude hiding (toList) 22 | import Dosh.Util (tshow, withLineNumbers) 23 | import GHC.Driver.Session qualified as GHC 24 | import GHC.Exts (IsList (..)) 25 | import Language.LSP.Client.Session (Session, changeDoc, documentContents) 26 | import Language.LSP.Types (Diagnostic, TextDocumentContentChangeEvent (..), TextDocumentIdentifier (..), UInt) 27 | import Language.LSP.Types qualified as LSP 28 | import Language.LSP.Types.Lens (HasCharacter (character), end, line, range, start) 29 | 30 | data ChunkMetadata = ChunkMetadata 31 | { firstLine :: UInt 32 | , lastLine :: UInt 33 | , dirty :: Bool 34 | } 35 | deriving stock (Generic, Show) 36 | 37 | mergeChunks :: ChunkMetadata -> ChunkMetadata -> Either String ChunkMetadata 38 | mergeChunks a b 39 | | a.lastLine /= b.firstLine = Left "Cannot merge non-adjacent chunks" 40 | | otherwise = Right a{lastLine = b.lastLine} 41 | 42 | moveChunkLines :: Int -> ChunkMetadata -> ChunkMetadata 43 | moveChunkLines dy = #firstLine %~ (+- dy) >>> #lastLine %~ (+- dy) 44 | 45 | (+-) :: UInt -> Int -> UInt 46 | (+-) u i 47 | | i >= 0 = u + fromIntegral i 48 | | otherwise = u - fromIntegral (abs i) 49 | 50 | data Document = Document 51 | { identifier :: TextDocumentIdentifier 52 | , language :: Text 53 | , chunks :: SeqZipper ChunkMetadata 54 | , expressionLines :: HashSet UInt 55 | , getSessionDynFlags :: IO GHC.DynFlags 56 | } 57 | deriving stock (Generic) 58 | 59 | newDocument :: TextDocumentIdentifier -> Document 60 | newDocument identifier = do 61 | Document 62 | { identifier 63 | , language = mempty 64 | , chunks = mempty 65 | , expressionLines = mempty 66 | , getSessionDynFlags = undefined 67 | } 68 | 69 | handleUpdates :: [TextDocumentContentChangeEvent] -> StateT Document Session () 70 | handleUpdates events = do 71 | updates <- mapM normaliseUpdate events 72 | identifier <- gets identifier 73 | lift $ changeDoc identifier updates 74 | gets (toList . chunks) >>= normaliseChunks >>= modify . set #chunks . fromList 75 | chunks <- gets chunks 76 | contents :: Rope <- 77 | maybe (error "handleUpdates: document contents not found") pure 78 | =<< lift (documentContents identifier) 79 | expressionLines <- gets expressionLines 80 | liftIO $ 81 | Text.writeFile "lsp-contents.hs" $ 82 | Text.unlines 83 | [ withLineNumbers (Rope.toText contents) 84 | , "\nChunks:" 85 | , Text.unlines $ tshow <$> toList chunks 86 | , "\nExpression lines:" 87 | , Text.unlines $ tshow <$> toList expressionLines 88 | ] 89 | where 90 | -- Moves the update locations forward by prefix length, if the first and/or last line of the update fall on prefixed expr lines. 91 | -- Removes prefixed line locations that are being overwritten by the update. 92 | -- Translates prefixed line locations and chunks AFTER the update by the number of lines affected by this update. 93 | -- Ensures that there is a chunk that wholly contains this update. 94 | -- Notably, does not create any new prefixed lines. 95 | normaliseUpdate :: TextDocumentContentChangeEvent -> StateT Document Session TextDocumentContentChangeEvent 96 | normaliseUpdate u@(view range -> Just r) = do 97 | d <- get 98 | let afterPrefix x = x . filtered (view line >>> (`HashSet.member` d.expressionLines)) . character %~ (+ fromIntegral prefixLength) 99 | u' = u & range . traverse %~ (afterPrefix start >>> afterPrefix end) 100 | startLine, endLine, endLine' :: UInt 101 | startLine = r ^. start . line 102 | endLine = r ^. end . line 103 | endLine' = startLine +- Text.count "\n" u._text 104 | dy :: Int 105 | dy = fromIntegral endLine' - fromIntegral endLine 106 | ifMultiline :: (Choice p, Applicative f) => Optic' p f a a 107 | ifMultiline = filtered (const $ dy /= 0) 108 | modify $ 109 | ifMultiline . #expressionLines 110 | %~ ( HashSet.filter (\y -> not $ y > startLine && y <= endLine) 111 | >>> HashSet.map (\y -> if y > startLine then y +- dy else y) 112 | ) 113 | >>> #chunks 114 | %~ ( goToLine startLine 115 | >>> #after 116 | %~ ( ifMultiline . dropping 1 traverse %~ moveChunkLines dy 117 | >>> ensureChunkContains startLine endLine' 118 | ) 119 | ) 120 | pure u' 121 | normaliseUpdate u = pure u 122 | ensureChunkContains :: UInt -> UInt -> Seq ChunkMetadata -> Seq ChunkMetadata 123 | ensureChunkContains firstLine lastLine = 124 | filtered Seq.null .~ Seq.singleton ChunkMetadata{dirty = True, ..} 125 | >>> Seq.adjust (#firstLine %~ min firstLine >>> #lastLine %~ max lastLine >>> #dirty .~ True) 0 126 | normaliseChunks :: [ChunkMetadata] -> StateT Document Session [ChunkMetadata] 127 | normaliseChunks (a : b : c) | a.lastLine == b.firstLine = normaliseChunks $ a{lastLine = b.lastLine, dirty = True} : c 128 | normaliseChunks (c : cs) | c.dirty = mappend <$> reparseChunk c <*> normaliseChunks cs 129 | normaliseChunks (c : cs) = (c :) <$> normaliseChunks cs 130 | normaliseChunks cs = pure cs 131 | 132 | -- Moves diagnostics left on virtually prefixed lines. 133 | normaliseDiagnostics :: Document -> [Diagnostic] -> [Diagnostic] 134 | normaliseDiagnostics doc = fmap $ range %~ mangle start . mangle end 135 | where 136 | isExprLine = flip HashSet.member doc.expressionLines . view line 137 | mangle l = l . filtered isExprLine . character . filtered (>= fromIntegral prefixLength) %~ (+- (-prefixLength)) 138 | 139 | exprPrefix :: UUID -> Text 140 | exprPrefix u = "_" <> Text.replace "-" "_" (UUID.toText u) <> " = " 141 | 142 | prefixLength :: Int 143 | prefixLength = Text.length $ exprPrefix UUID.nil 144 | 145 | newExprPrefix :: IO Text 146 | newExprPrefix = exprPrefix <$> UUID.nextRandom 147 | 148 | prefixLine :: UInt -> StateT Document Session () 149 | prefixLine n = whenM (gets $ not . HashSet.member n . expressionLines) $ do 150 | identifier <- gets identifier 151 | prefix <- liftIO newExprPrefix 152 | let loc = 153 | LSP.Position 154 | { _line = n 155 | , _character = 0 156 | } 157 | modify $ #expressionLines %~ HashSet.insert n 158 | lift $ 159 | changeDoc 160 | identifier 161 | [ TextDocumentContentChangeEvent 162 | { _range = 163 | Just 164 | LSP.Range 165 | { _start = loc 166 | , _end = loc 167 | } 168 | , _rangeLength = Nothing 169 | , _text = prefix 170 | } 171 | ] 172 | 173 | unprefixLine :: UInt -> StateT Document Session () 174 | unprefixLine n = whenM (gets $ HashSet.member n . expressionLines) $ do 175 | identifier <- gets identifier 176 | modify $ #expressionLines %~ HashSet.delete n 177 | lift $ 178 | changeDoc 179 | identifier 180 | [ TextDocumentContentChangeEvent 181 | { _range = 182 | Just 183 | LSP.Range 184 | { _start = 185 | LSP.Position 186 | { _line = n 187 | , _character = 0 188 | } 189 | , _end = 190 | LSP.Position 191 | { _line = n 192 | , _character = fromIntegral prefixLength 193 | } 194 | } 195 | , _rangeLength = Nothing 196 | , _text = "" 197 | } 198 | ] 199 | 200 | reparseChunk :: ChunkMetadata -> StateT Document Session [ChunkMetadata] 201 | reparseChunk c = do 202 | mapM_ unprefixLine [c.firstLine .. c.lastLine] 203 | contents :: Text <- 204 | maybe (error "handleUpdates: document contents not found") (pure . chunkContents c) 205 | =<< lift . documentContents 206 | =<< gets identifier 207 | dynFlags <- gets getSessionDynFlags >>= liftIO 208 | let chunk = GHC.chunkFromText "" (fromIntegral c.firstLine) contents 209 | chunks = GHC.splitChunks chunk 210 | forM chunks $ \c -> do 211 | let firstLine = fromIntegral $ GHC.firstLine c 212 | let lastLine = fromIntegral $ GHC.lastLine c 213 | case GHC.parseExprChunk dynFlags c of 214 | Just (GHC.ExpressionChunk exprs) -> 215 | forM_ (filter (not . Text.null . GHC.unLoc) exprs) $ 216 | prefixLine . fromIntegral . GHC.firstLine 217 | Nothing -> mapM_ unprefixLine [firstLine .. lastLine] 218 | _ -> undefined 219 | 220 | pure 221 | ChunkMetadata 222 | { firstLine = fromIntegral $ GHC.firstLine c 223 | , lastLine = fromIntegral $ GHC.lastLine c 224 | , dirty = False 225 | } 226 | where 227 | ropeContents :: UInt -> UInt -> Rope -> Text 228 | ropeContents firstLine lastLine = 229 | Text.intercalate "\n" 230 | . take (fromIntegral $ lastLine - firstLine + 1) 231 | . Rope.lines 232 | . snd 233 | . Rope.splitAtLine (fromIntegral firstLine) 234 | chunkContents :: ChunkMetadata -> Rope -> Text 235 | chunkContents ChunkMetadata{firstLine, lastLine} = ropeContents firstLine lastLine 236 | 237 | -- multiChunkContents :: [ChunkMetadata] -> Rope -> Text 238 | -- multiChunkContents cs = ropeContents (minimum $ firstLine <$> cs) (maximum $ lastLine <$> cs) 239 | 240 | goToLine :: UInt -> SeqZipper ChunkMetadata -> SeqZipper ChunkMetadata 241 | goToLine r = forwardWhile chunkContains >>> backWhile chunkContains 242 | where 243 | chunkContains ChunkMetadata{..} = r >= firstLine && r <= lastLine 244 | -------------------------------------------------------------------------------- /dosh/src/Dosh/LSP/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Dosh.LSP.Server where 6 | 7 | import Data.ByteString (hGetSome, hPut) 8 | import Data.ByteString.Builder.Extra (defaultChunkSize) 9 | import Data.Default (def) 10 | import Data.Text.Encoding qualified as Text 11 | import Data.Text.IO qualified as Text 12 | import Development.IDE (Logger (Logger), Pretty (pretty), Recorder (..), WithPriority, cmapWithPrio, logWith) 13 | import Development.IDE.Main (Arguments (..), defaultArguments, defaultMain) 14 | import Development.IDE.Session (findCradle, loadCradle) 15 | import Dosh.Prelude 16 | import Dosh.Util hiding (withTimeout) 17 | import GHC.Paths qualified as GHC 18 | import GHC.Settings.Config qualified as GHC 19 | import HIE.Bios.Config (CradleConfig (..), CradleType (..)) 20 | import HIE.Bios.Cradle (getCradle) 21 | import HIE.Bios.Types (ComponentOptions (..), Cradle (..), CradleAction (..), CradleLoadResult (..)) 22 | import HIE.Bios.Types qualified as Cradle 23 | import HlsPlugins (idePlugins) 24 | import Language.LSP.Client qualified as LSP 25 | import Language.LSP.Client.Session (Session) 26 | import Reflex 27 | ( Reflex (Event) 28 | , TriggerEvent (newTriggerEvent) 29 | ) 30 | import System.Process.Extra 31 | 32 | data Server t = Server 33 | { input :: Session () -> IO () 34 | , error :: Event t SomeException 35 | , log :: Event t (WithPriority Text) 36 | } 37 | 38 | server 39 | :: forall t m 40 | . ( MonadIO m 41 | , TriggerEvent t m 42 | ) 43 | => m (Server t) 44 | server = do 45 | (log, logTrigger) <- newTriggerEvent 46 | (error, reportError) <- newTriggerEvent 47 | (serverInput, serverOutput) <- liftIO $ do 48 | -- TODO: try to use Knob rather than pipes 49 | (inRead, inWrite) <- createPipe 50 | hSetBuffering inRead NoBuffering 51 | hSetBuffering inWrite NoBuffering 52 | (inRead', inWrite') <- createPipe 53 | hSetBuffering inRead' NoBuffering 54 | hSetBuffering inWrite' NoBuffering 55 | (outRead, outWrite) <- createPipe 56 | hSetBuffering outRead NoBuffering 57 | hSetBuffering outWrite NoBuffering 58 | (outRead', outWrite') <- createPipe 59 | hSetBuffering outRead' NoBuffering 60 | hSetBuffering outWrite' NoBuffering 61 | let recorder = Recorder{logger_ = liftIO . logTrigger} 62 | forkIO $ forever $ do 63 | c <- hGetSome inRead defaultChunkSize 64 | Text.appendFile "hls-input.log" $ Text.decodeUtf8 c 65 | hPut inWrite' c 66 | forkIO $ forever $ do 67 | c <- hGetSome outRead' defaultChunkSize 68 | Text.appendFile "hls-output.log" $ Text.decodeUtf8 c 69 | hPut outWrite c 70 | forkIO $ ghcide recorder inRead' outWrite' 71 | pure (inWrite, outRead) 72 | sessionActions <- newTQueueIO 73 | liftIO $ 74 | forkIO $ 75 | LSP.runSessionWithHandles serverOutput serverInput $ 76 | forever $ do 77 | action <- atomically $ readTQueue sessionActions 78 | action `catch` (liftIO . reportError) 79 | pure 80 | Server 81 | { input = atomically . writeTQueue sessionActions 82 | , error 83 | , log 84 | } 85 | 86 | -- TODO: can we get rid of handles altogether? 87 | ghcide :: Recorder (WithPriority Text) -> Handle -> Handle -> IO () 88 | ghcide recorder stdin stdout = do 89 | let logger = Logger $ logWith recorder 90 | recorder' = cmapWithPrio (tshow . pretty) recorder 91 | plugins = idePlugins $ cmapWithPrio (tshow . pretty) recorder 92 | arguments = 93 | (defaultArguments recorder' logger plugins) 94 | { argsHandleIn = pure stdin 95 | , argsHandleOut = pure stdout 96 | , argsSessionLoadingOptions = 97 | def 98 | { findCradle = const $ pure Nothing 99 | , loadCradle = \_ _ -> 100 | pure $ 101 | getCradle 102 | undefined 103 | ( CradleConfig 104 | { cradleDependencies = [] 105 | , cradleType = Direct{arguments = []} 106 | } 107 | , "." 108 | ) 109 | } 110 | } 111 | defaultMain recorder' arguments 112 | 113 | directCradle :: FilePath -> [String] -> Cradle a 114 | directCradle wdir args = 115 | Cradle 116 | { cradleRootDir = wdir 117 | , cradleOptsProg = 118 | CradleAction 119 | { actionName = Cradle.Direct 120 | , runCradle = \_ _ -> 121 | return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir [])) 122 | , runGhcCmd = 123 | const $ 124 | pure . \case 125 | ["--print-libdir"] -> CradleSuccess GHC.libdir 126 | ["--numeric-version"] -> CradleSuccess GHC.cProjectVersion 127 | _ -> CradleNone 128 | } 129 | } 130 | where 131 | argDynamic :: [String] 132 | argDynamic = ["-dynamic"] 133 | -------------------------------------------------------------------------------- /dosh/src/Dosh/Notebook.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Dosh.Notebook where 6 | 7 | import Control.Lens 8 | import Control.Monad.Fix 9 | import Data.Default 10 | import Data.HashMap.Strict (HashMap) 11 | import Data.List.NonEmpty qualified as NonEmpty 12 | import Data.Sequence qualified as Seq 13 | import Data.Sequence.Zipper (SeqZipper (..)) 14 | import Data.Sequence.Zipper qualified as SZ 15 | import Data.Text.CodeZipper qualified as CZ 16 | import Data.Text.Utf16.Rope (Rope) 17 | import Data.These (These (..)) 18 | import Data.Traversable (for) 19 | import Data.UUID (UUID) 20 | import Dosh.Cell 21 | import Dosh.Cell qualified as Cell 22 | import Dosh.GHC.Client qualified as GHC 23 | import Dosh.LSP.Client qualified as LSP 24 | import Dosh.Prelude 25 | import Dosh.Util 26 | import Language.LSP.Types (TextDocumentIdentifier (..), Uri (..)) 27 | import Language.LSP.Types qualified as LSP hiding (line) 28 | import Language.LSP.Types.Lens qualified as LSP 29 | import Reflex hiding (Query, Response) 30 | import Reflex.Vty hiding (Query, Response) 31 | 32 | data Notebook = Notebook 33 | { identifier :: TextDocumentIdentifier 34 | , cells :: HashMap UUID Cell 35 | , cellOrder :: SeqZipper UUID 36 | , nextCellNumber :: Int 37 | , disabled :: Bool 38 | , language :: Text 39 | , contents :: Rope 40 | } 41 | deriving stock (Generic, Show) 42 | 43 | instance Default Notebook where 44 | def = 45 | Notebook 46 | { identifier = TextDocumentIdentifier $ Uri mempty 47 | , cells = mempty 48 | , cellOrder = mempty 49 | , nextCellNumber = 1 50 | , disabled = False 51 | , language = mempty 52 | , contents = mempty 53 | } 54 | 55 | newNotebook :: MonadIO m => (Notebook -> Notebook) -> m Notebook 56 | newNotebook f = do 57 | uri <- newRandomUri "/" ".hs" 58 | def 59 | & #identifier .~ TextDocumentIdentifier uri 60 | & f 61 | & createCell (#disabled .~ False) 62 | 63 | -- | Create a new cell with a random UUID. 64 | createCell :: MonadIO m => (Cell -> Cell) -> Notebook -> m Notebook 65 | createCell f n = flip addCell n <$> newCell f 66 | 67 | -- | Add a cell to the notebook. 68 | addCell :: Cell -> Notebook -> Notebook 69 | addCell c n = 70 | n 71 | & #cells . at c.uid 72 | ?~ ( c 73 | & #number .~ n.nextCellNumber 74 | & #input . #language .~ n.language 75 | ) 76 | & #cellOrder %~ SZ.insertAfter c.uid 77 | 78 | currentCellUid :: Notebook -> Maybe UUID 79 | currentCellUid n = SZ.current n.cellOrder 80 | 81 | overUid :: UUID -> (Cell -> Cell) -> Notebook -> Notebook 82 | overUid uid f = #cells . ix uid %~ f 83 | 84 | currentCell :: Notebook -> Maybe Cell 85 | currentCell n = currentCellUid n >>= \cid -> n ^. #cells . at cid 86 | 87 | overCurrentCell :: (Cell -> Cell) -> Notebook -> Notebook 88 | overCurrentCell f n = maybe n ((n &) . flip overUid f) (currentCellUid n) 89 | 90 | notebook 91 | :: forall t m 92 | . ( PerformEvent t m 93 | , TriggerEvent t m 94 | , HasInput t m 95 | , MonadFix m 96 | , HasImageWriter t m 97 | , HasTheme t m 98 | , HasFocusReader t m 99 | , HasDisplayRegion t m 100 | , HasLayout t m 101 | , MonadHold t m 102 | , MonadIO (Performable m) 103 | ) 104 | => GHC.Client t 105 | -> LSP.Client t 106 | -> Notebook 107 | -> m (Event t Notebook) 108 | notebook ghc lsp n = do 109 | cellEvents :: Event t [(Cell, CellEvent)] <- NonEmpty.toList <$$> (mergeList . toList) <$> for n.cellOrder (\cid -> (fromJust $ n.cells ^. at cid,) <$$> cell (fromJust $ n ^. #cells . at cid)) 110 | cellUpdates :: Event t Notebook <- performEvent $ foldrM (uncurry $ handleCellEvent ghc lsp) n <$> cellEvents 111 | ghcUpdates :: Event t Notebook <- 112 | performEvent $ 113 | flip (`alignEventWithMaybe` cellUpdates) ghc.onResponse $ 114 | Just . \case 115 | This n -> pure n 116 | That r -> handleGhcResponse r n 117 | These n r -> handleGhcResponse r n 118 | performEvent $ 119 | flip (`alignEventWithMaybe` ghcUpdates) lsp.onResponse $ 120 | Just . \case 121 | This n -> pure n 122 | That r -> handleLspResponse r n 123 | These n r -> handleLspResponse r n 124 | 125 | handleCellEvent 126 | :: forall t m 127 | . MonadIO m 128 | => GHC.Client t 129 | -> LSP.Client t 130 | -> Cell 131 | -> CellEvent 132 | -> Notebook 133 | -> m Notebook 134 | handleCellEvent _ _ Cell{uid} (UpdateCellCursor (moveCursor -> update)) n = do 135 | pure $ n & #cells . ix uid . #input %~ update 136 | handleCellEvent _ lsp c@Cell{uid, input} (UpdateCellInput update) n = do 137 | liftIO $ 138 | lsp.request 139 | LSP.ChangeDocument 140 | { identifier = n.identifier 141 | , range = 142 | Just 143 | LSP.Range 144 | { _start = case update of 145 | Insert _ -> position 146 | DeleteLeft -> newPosition 147 | DeleteRight -> position 148 | , _end = case update of 149 | Insert _ -> position 150 | DeleteLeft -> position 151 | DeleteRight -> 152 | let deltaLines = fromIntegral $ CZ.lines input - CZ.lines newZipper 153 | in position 154 | & if deltaLines == 0 155 | then LSP.character %~ (+ 1) 156 | else LSP.line %~ (+ deltaLines) >>> LSP.character .~ 0 157 | } 158 | , contents = case update of 159 | Insert t -> t 160 | DeleteLeft -> "" 161 | DeleteRight -> "" 162 | } 163 | pure $ 164 | n 165 | & #cells . ix uid . #input .~ newZipper 166 | & filtered (const $ row /= newRow) %~ updateLineNumbers 167 | where 168 | row = firstLine c + CZ.row input 169 | col = CZ.col input 170 | position = LSP.Position (fromIntegral row) (fromIntegral col) 171 | newZipper = updateZipper update input 172 | newRow = firstLine c + CZ.row newZipper 173 | newCol = CZ.col newZipper 174 | newPosition = LSP.Position (fromIntegral newRow) (fromIntegral newCol) 175 | -- TODO: can we leverage a finger tree to do this automatically? 176 | updateLineNumbers :: Notebook -> Notebook 177 | updateLineNumbers n = flip (`foldl'` n) (Seq.zip n.cellOrder.after $ Seq.drop 1 n.cellOrder.after) $ 178 | \n (c1, c2) -> 179 | n 180 | & #cells . ix c2 %~ #firstLine .~ lastLine (fromJust $ n ^. #cells . at c1) + 1 181 | handleCellEvent ghc lsp c@Cell{uid, input} EvaluateCell n = do 182 | -- we send a new-line to LSP so it will be aware of the next cell 183 | when (shouldCreateNewCell n) $ 184 | liftIO $ 185 | lsp.request 186 | LSP.ChangeDocument 187 | { identifier = n.identifier 188 | , range = 189 | Just 190 | LSP.Range 191 | { _start = LSP.Position{_line = fromIntegral $ lastLine c, _character = maxBound} 192 | , _end = LSP.Position{_line = fromIntegral $ lastLine c, _character = maxBound} 193 | } 194 | , contents = "\n\n" 195 | } 196 | let content = CZ.toText input 197 | liftIO $ ghc.request GHC.Evaluate{uid, content} 198 | maybeNewCell <- 199 | if shouldCreateNewCell n 200 | then Just <$> newCell (#firstLine .~ lastLine c + 1) 201 | else pure Nothing 202 | pure $ 203 | n 204 | & updateNumbers 205 | & maybe id addCell maybeNewCell 206 | & #cells . ix uid %~ \c -> 207 | c 208 | { output = Nothing 209 | , error = Nothing 210 | , Cell.disabled = True 211 | , evaluated = True 212 | } 213 | where 214 | cellEvaluated :: Notebook -> Bool 215 | cellEvaluated = maybe False evaluated . view (#cells . at uid) 216 | cellNotEvaluated :: Notebook -> Bool 217 | cellNotEvaluated = not . cellEvaluated 218 | isLastCell :: Notebook -> Bool 219 | isLastCell = (Just uid ==) . SZ.last . cellOrder 220 | shouldCreateNewCell :: Notebook -> Bool 221 | shouldCreateNewCell n = isLastCell n && cellNotEvaluated n 222 | updateNumbers :: Notebook -> Notebook 223 | updateNumbers n = 224 | n 225 | & #cells . traverse . filtered (not . evaluated) . #number %~ (+ 1) 226 | & #cells . ix uid . #number .~ n.nextCellNumber 227 | & #nextCellNumber %~ (+ 1) 228 | handleCellEvent _ _ _ GoToPreviousCell n 229 | | havePrev n = 230 | pure $ 231 | n 232 | & overCurrentCell (#disabled .~ True) 233 | & #cellOrder %~ SZ.back 234 | & overCurrentCell (#disabled .~ False) 235 | | otherwise = pure n 236 | where 237 | havePrev = not . null . SZ.before . cellOrder 238 | handleCellEvent _ _ _ GoToNextCell n 239 | | haveNext n = 240 | pure $ 241 | n 242 | & overCurrentCell (#disabled .~ True) 243 | & #cellOrder %~ SZ.forward 244 | & overCurrentCell (#disabled .~ False) 245 | | otherwise = pure n 246 | where 247 | haveNext = isJust . SZ.current . SZ.forward . cellOrder 248 | 249 | handleGhcResponse 250 | :: forall m 251 | . MonadIO m 252 | => GHC.Response 253 | -> Notebook 254 | -> m Notebook 255 | handleGhcResponse r = 256 | pure 257 | . ( #cells . ix r.uid %~ case r of 258 | GHC.FullResponse{content} -> #output ?~ content 259 | GHC.PartialResponse{content} -> #output %~ (Just . (<> content) . fromMaybe "") 260 | GHC.Error{error} -> #error ?~ tshow error 261 | GHC.EndResponse{} -> #disabled .~ False 262 | ) 263 | 264 | handleLspResponse 265 | :: forall m 266 | . MonadIO m 267 | => LSP.Response 268 | -> Notebook 269 | -> m Notebook 270 | handleLspResponse LSP.DocumentContents{..} = #contents .~ contents >>> pure 271 | handleLspResponse LSP.Diagnostics{..} = clearDiagnostics >>> setDiagnostics >>> pure 272 | where 273 | clearDiagnostics :: Notebook -> Notebook 274 | clearDiagnostics = #cells . traverse . #diagnostics .~ [] 275 | setDiagnostics :: Notebook -> Notebook 276 | setDiagnostics = foldr (.) id $ setDiagnostic <$> diagnostics 277 | setDiagnostic :: LSP.Diagnostic -> Notebook -> Notebook 278 | setDiagnostic d = #cells . traverse . filtered (hasDiagnostic d) %~ #diagnostics %~ (d :) 279 | hasDiagnostic :: LSP.Diagnostic -> Cell -> Bool 280 | hasDiagnostic (diagnosticLine -> l) c = firstLine c <= l && lastLine c >= l 281 | handleLspResponse LSP.Completions{} = pure 282 | -------------------------------------------------------------------------------- /dosh/src/Dosh/Util.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Dosh.Util where 5 | 6 | import Control.Monad.Extra (whenMaybeM, whileJustM) 7 | import Control.Monad.Fix (MonadFix) 8 | import Data.ByteString (hGetSome) 9 | import Data.ByteString.Builder.Extra (defaultChunkSize) 10 | import Data.Map (Map) 11 | import Data.Map qualified as Map 12 | import Data.Text qualified as Text 13 | import Data.Text.Encoding qualified as Text 14 | import Data.UUID (UUID) 15 | import Data.UUID qualified as UUID 16 | import Data.UUID.V4 qualified as UUID 17 | import Development.IDE (Priority, WithPriority (..)) 18 | import Dosh.Prelude 19 | import Graphics.Vty (Key (..), Modifier (..)) 20 | import Language.LSP.Types (Diagnostic, Uri (..), filePathToUri) 21 | import Language.LSP.Types.Lens (HasLine (line), character, range, start) 22 | import Reflex 23 | import Reflex.Vty 24 | 25 | (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 26 | (<$$>) = fmap . fmap 27 | 28 | (<&&>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b) 29 | (<&&>) = flip (<$$>) 30 | 31 | (<$$) :: (Functor f, Functor g) => a -> f (g b) -> f (g a) 32 | (<$$) = fmap . (<$) 33 | 34 | ($$>) :: (Functor f, Functor g) => f (g a) -> b -> f (g b) 35 | ($$>) = flip (<$$) 36 | 37 | tread :: Read a => Text -> a 38 | tread = read . Text.unpack 39 | 40 | tshow :: Show a => a -> Text 41 | tshow = Text.pack . show 42 | 43 | bshow :: Show a => a -> ByteString 44 | bshow = Text.encodeUtf8 . tshow 45 | 46 | fromText :: IsString s => Text -> s 47 | fromText = fromString . Text.unpack 48 | 49 | ctrlcPressed :: (Monad m, Reflex t, HasInput t m) => m (Event t KeyCombo) 50 | ctrlcPressed = keyCombo (KChar 'c', [MCtrl]) 51 | 52 | ctrldPressed :: (Monad m, Reflex t, HasInput t m) => m (Event t KeyCombo) 53 | ctrldPressed = keyCombo (KChar 'd', [MCtrl]) 54 | 55 | enterPressed :: (Monad m, Reflex t, HasInput t m) => m (Event t KeyCombo) 56 | enterPressed = key KEnter 57 | 58 | shiftEnterPressed :: (Monad m, Reflex t, HasInput t m) => m (Event t KeyCombo) 59 | shiftEnterPressed = keyCombo (KEnter, [MShift]) 60 | 61 | altEnterPressed :: (Monad m, Reflex t, HasInput t m) => m (Event t KeyCombo) 62 | altEnterPressed = keyCombo (KEnter, [MMeta]) 63 | 64 | {- | Given a map of values and a map of value transformations, apply 65 | transformations on the intersection of these two maps. 66 | -} 67 | transformMap :: Map Int (c -> c) -> Map Int c -> Map Int c 68 | transformMap = 69 | Map.mergeWithKey 70 | (const (Just .)) 71 | (const mempty) 72 | id 73 | 74 | getAvailableContents :: Handle -> IO ByteString 75 | getAvailableContents h = whileJustM $ whenMaybeM (hReady h) (hGetSome h defaultChunkSize) 76 | 77 | {- | Run two @IO@ actions concurrently. 78 | The loser of the race is 'cancel'led after a delay (in microseconds). 79 | -} 80 | raceWithDelay_ :: MonadUnliftIO m => Int -> m a -> m b -> m () 81 | raceWithDelay_ (threadDelay -> d) a b = race_ (a <* d) (b <* d) 82 | 83 | attach2 :: Reflex t => (Behavior t a, Behavior t b) -> Event t c -> Event t (a, b, c) 84 | attach2 (b1, b2) e = attach b1 (attach b2 e) <&> \(a, (b, c)) -> (a, b, c) 85 | 86 | attach3 :: Reflex t => (Behavior t a, Behavior t b, Behavior t c) -> Event t d -> Event t (a, b, c, d) 87 | attach3 (b1, b2, b3) e = attach b1 (attach2 (b2, b3) e) <&> \(a, (b, c, d)) -> (a, b, c, d) 88 | 89 | blankLine :: forall t m. (HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, MonadHold t m, MonadFix m) => m () 90 | blankLine = grout (fixed $ pure 1) blank 91 | 92 | toMaybe :: Bool -> a -> Maybe a 93 | toMaybe False = const Nothing 94 | toMaybe True = Just 95 | 96 | maybeStartsWith :: Bool -> (Char -> Bool) -> Text -> Bool 97 | maybeStartsWith d f = maybe d (f . fst) . Text.uncons 98 | 99 | maybeEndsWith :: Bool -> (Char -> Bool) -> Text -> Bool 100 | maybeEndsWith d _ "" = d 101 | maybeEndsWith _ f t = f $ Text.last t 102 | 103 | newlined :: Text -> Text 104 | newlined t 105 | | maybeEndsWith False (== '\n') t = t 106 | | otherwise = t <> "\n" 107 | 108 | withTimeout :: (MonadUnliftIO m, MonadFail m) => Int -> m a -> m a 109 | withTimeout = ((maybe (fail "Timeout exceeded") pure =<<) .) . timeout 110 | 111 | prependAndPadLines :: Text -> Text -> Text 112 | prependAndPadLines x = (x <>) . Text.drop len . Text.intercalate "\n" . fmap (pad <>) . Text.splitOn "\n" 113 | where 114 | len = Text.length x 115 | pad = Text.replicate len " " 116 | 117 | instance Show (WithPriority Text) where 118 | show WithPriority{..} = Text.unpack $ prependAndPadLines prio payload 119 | where 120 | len = (1 +) . maximum $ Text.length . tshow <$> [minBound @Priority .. maxBound] 121 | prio = Text.justifyLeft len ' ' $ tshow priority 122 | 123 | diagnosticLine :: Diagnostic -> Int 124 | diagnosticLine = fromIntegral . view (range . start . line) 125 | 126 | diagnosticChar :: Diagnostic -> Int 127 | diagnosticChar = fromIntegral . view (range . start . character) 128 | 129 | withLineNumbers :: Text -> Text 130 | withLineNumbers t = Text.intercalate "\n" $ zipWith (\i t -> Text.justifyRight w ' ' (tshow i) <> " " <> t) [0 :: Int ..] ls 131 | where 132 | ls = Text.splitOn "\n" t 133 | w = Text.length $ tshow $ length ls 134 | 135 | uuidToUri :: FilePath -> FilePath -> UUID -> Uri 136 | uuidToUri prefix postfix = filePathToUri . Text.unpack . (Text.pack prefix <>) . (<> Text.pack postfix) . UUID.toText 137 | 138 | newRandomUri :: MonadIO m => FilePath -> FilePath -> m Uri 139 | newRandomUri prefix postfix = uuidToUri prefix postfix <$> liftIO UUID.nextRandom 140 | -------------------------------------------------------------------------------- /dosh/src/Reflex/Vty/Widget/Input/Code.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 5 | {-# OPTIONS_GHC -Wno-unused-matches #-} 6 | 7 | module Reflex.Vty.Widget.Input.Code where 8 | 9 | import Control.Arrow ((>>>)) 10 | import Control.Lens 11 | import Control.Monad.Fix (MonadFix) 12 | import Data.Default (Default) 13 | import Data.Either.Extra (eitherToMaybe, maybeToEither) 14 | import Data.Generics.Labels () 15 | import Data.Generics.Product (position) 16 | import Data.List (intersperse) 17 | import Data.List.Extra qualified 18 | import Data.Maybe (fromMaybe) 19 | import Data.Text (Text) 20 | import Data.Text qualified as Text 21 | import Data.Text.CodeZipper (CodeZipper (..), Pretty (..), normaliseToks, tokenLines) 22 | import Data.Text.CodeZipper qualified as CZ 23 | import Data.Text.Zipper (DisplayLines (..), Span (..), TextAlignment (..)) 24 | import Data.Word (Word8) 25 | import GHC.Generics (Generic) 26 | import GHC.SyntaxHighlighter qualified as GS 27 | import Graphics.Vty qualified as V 28 | import Reflex hiding (tag) 29 | import Reflex.Vty.Widget 30 | import Reflex.Vty.Widget.Input.Mouse 31 | import Reflex.Vty.Widget.Input.Text 32 | import Skylighting qualified as S 33 | import Skylighting.Types (TokenType (..)) 34 | import Prelude 35 | 36 | deriving stock instance Generic (Span tag) 37 | 38 | deriving stock instance Generic (DisplayLines t) 39 | 40 | type Token = CZ.Token TokenType 41 | 42 | type SourceLine = CZ.SourceLine TokenType 43 | 44 | instance Pretty TokenType where 45 | plain code = [[CZ.Token{tokenType = NormalTok, ..}] | tokenContent <- Text.splitOn "\n" code] 46 | pretty (Text.toLower -> "haskell") = ghcHighlight 47 | pretty lang = skylight lang 48 | 49 | plainToken :: Text -> Token 50 | plainToken tokenContent = CZ.Token{tokenType = NormalTok, ..} 51 | 52 | skylight :: Text -> Text -> Maybe [SourceLine] 53 | skylight lang code = eitherToMaybe $ do 54 | syntax <- maybeToEither @String "Syntax not found" $ S.lookupSyntax lang S.defaultSyntaxMap 55 | let cfg = S.TokenizerConfig{syntaxMap = S.defaultSyntaxMap, traceOutput = False} 56 | case S.tokenize cfg syntax (code <> "\n") of 57 | Left _ -> Left "Tokenize failed" 58 | Right [] -> Left "No tokens produced" 59 | Right lines -> Right $ (fmap . fmap) (\(tokenType, tokenContent) -> CZ.Token{..}) lines 60 | 61 | ghcHighlight :: Text -> Maybe [SourceLine] 62 | ghcHighlight code = fmap normaliseToks . gsTokensToLines <$> GS.tokenizeHaskell code 63 | where 64 | gsTokensToLines :: [(GS.Token, Text)] -> [SourceLine] 65 | gsTokensToLines = Data.List.Extra.split (("\n" ==) . CZ.tokenContent) . concatMap (intersperse (plainToken "\n") . tokenLines . mapToken) 66 | mapToken :: (GS.Token, Text) -> Token 67 | mapToken (mapTokenType -> tokenType, tokenContent) = CZ.Token{..} 68 | mapTokenType :: GS.Token -> TokenType 69 | mapTokenType GS.CharTok = CharTok 70 | mapTokenType GS.CommentTok = CommentTok 71 | mapTokenType GS.ConstructorTok = FunctionTok 72 | mapTokenType GS.IntegerTok = ConstantTok 73 | mapTokenType GS.KeywordTok = KeywordTok 74 | mapTokenType GS.OperatorTok = OperatorTok 75 | mapTokenType GS.OtherTok = OtherTok 76 | mapTokenType GS.PragmaTok = PreprocessorTok 77 | mapTokenType GS.RationalTok = FloatTok 78 | mapTokenType GS.SpaceTok = NormalTok 79 | mapTokenType GS.StringTok = StringTok 80 | mapTokenType GS.SymbolTok = OperatorTok 81 | mapTokenType GS.VariableTok = VariableTok 82 | 83 | data CodeInputConfig t = CodeInputConfig 84 | { _codeInputConfig_initialValue :: CodeZipper TokenType 85 | , _codeInputConfig_value :: Maybe (Dynamic t (CodeZipper TokenType)) 86 | , _codeInputConfig_virtualLines :: [(Int, [Span V.Attr])] 87 | , _codeInputConfig_modify :: Event t (CodeZipper TokenType -> CodeZipper TokenType) 88 | , _codeInputConfig_tabWidth :: Int 89 | , _codeInputConfig_display :: Dynamic t (Char -> Char) 90 | , _codeInputConfig_showCursor :: Bool 91 | } 92 | 93 | instance Reflex t => Default (CodeInputConfig t) where 94 | def = 95 | CodeInputConfig 96 | { _codeInputConfig_initialValue = CZ.empty 97 | , _codeInputConfig_value = Nothing 98 | , _codeInputConfig_virtualLines = [] 99 | , _codeInputConfig_modify = never 100 | , _codeInputConfig_tabWidth = 4 101 | , _codeInputConfig_display = pure id 102 | , _codeInputConfig_showCursor = True 103 | } 104 | 105 | data CodeInput t = CodeInput 106 | { _codeInput_value :: Dynamic t Text 107 | , _codeInput_lines :: Dynamic t Int 108 | } 109 | 110 | codeInput 111 | :: forall t m 112 | . ( MonadHold t m 113 | , MonadFix m 114 | , HasInput t m 115 | , HasFocusReader t m 116 | , HasTheme t m 117 | , HasImageWriter t m 118 | , HasDisplayRegion t m 119 | ) 120 | => CodeInputConfig t 121 | -> m (CodeInput t) 122 | codeInput cfg = mdo 123 | i <- input 124 | f <- focus 125 | dh <- displayHeight 126 | dw <- displayWidth 127 | bt <- theme 128 | attr0 <- sample bt 129 | let valueChangedByCaller, valueChangedByUI :: Event t (CodeZipper TokenType -> CodeZipper TokenType) 130 | valueChangedByCaller = _codeInputConfig_modify cfg 131 | valueChangedByUI = 132 | mergeWith 133 | (.) 134 | [ uncurry (updateCodeZipper (_codeInputConfig_tabWidth cfg)) <$> attach (current dh) i 135 | ] 136 | v :: Dynamic t (CodeZipper TokenType) <- 137 | flip fromMaybe (pure <$> cfg._codeInputConfig_value) $ 138 | foldDyn ($) (_codeInputConfig_initialValue cfg) $ 139 | mergeWith 140 | (.) 141 | [ valueChangedByCaller 142 | , valueChangedByUI 143 | ] 144 | click <- mouseDown V.BLeft 145 | 146 | -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg) 147 | let 148 | toCursorAttrs :: V.Attr -> V.Attr 149 | toCursorAttrs attr = V.withStyle attr V.reverseVideo 150 | rowInputDyn :: Dynamic t (Int, CodeZipper TokenType, Bool) 151 | rowInputDyn = (,,) <$> dw <*> v <*> f 152 | toDisplayLines :: V.Attr -> (Int, CodeZipper TokenType, Bool) -> DisplayLines V.Attr 153 | toDisplayLines attr (w, s, x) = 154 | let c = if cfg._codeInputConfig_showCursor then (`V.withStyle` V.reverseVideo) else id 155 | in displayCodeLines w attr c s 156 | attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn) 157 | let rows :: Dynamic t (DisplayLines V.Attr) 158 | rows = 159 | ffor2 attrDyn rowInputDyn toDisplayLines 160 | <&> #_displayLines_spans 161 | %~ fst . foldr go ([], reverse $ _codeInputConfig_virtualLines cfg) . zip [0 ..] 162 | where 163 | go :: (Int, [Span V.Attr]) -> ([[Span V.Attr]], [(Int, [Span V.Attr])]) -> ([[Span V.Attr]], [(Int, [Span V.Attr])]) 164 | go l@(lineNum, line) (acc, (vlineNum, vline) : vlines) 165 | | lineNum <= vlineNum = go l (vline : acc, vlines) 166 | go (lineNum, line) (acc, vlines) = (line : acc, vlines) 167 | img :: Dynamic t [V.Image] 168 | img = images . _displayLines_spans <$> rows 169 | y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows 170 | let newScrollTop :: Int -> (Int, Int) -> Int 171 | newScrollTop st (h, cursorY) 172 | | cursorY < st = cursorY 173 | | cursorY >= st + h = cursorY - h + 1 174 | | otherwise = st 175 | let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y 176 | scrollTop <- hold 0 hy 177 | tellImages $ (\imgs st -> (: []) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop 178 | return $ 179 | CodeInput 180 | { _codeInput_value = CZ.toText <$> v 181 | , _codeInput_lines = length <$> img 182 | } 183 | 184 | {- | Given a width and a 'TextZipper', produce a list of display lines 185 | (i.e., lines of wrapped text) with special attributes applied to 186 | certain segments (e.g., the cursor). Additionally, produce the current 187 | y-coordinate of the cursor and a mapping from display line number to text 188 | offset 189 | -} 190 | displayCodeLinesWithAlignment 191 | :: TextAlignment 192 | -> Int 193 | -- ^ Width, used for wrapping 194 | -> V.Attr 195 | -- ^ Metadata for normal characters 196 | -> (V.Attr -> V.Attr) 197 | -- ^ Metadata for the cursor 198 | -> CodeZipper TokenType 199 | -- ^ The text input contents and cursor state 200 | -> DisplayLines V.Attr 201 | displayCodeLinesWithAlignment alignment width tag cursorTag z = 202 | DisplayLines 203 | { _displayLines_spans = 204 | mconcat 205 | [ lineToSpans <$> reverse z.linesBefore 206 | , [currentLineSpans] 207 | , lineToSpans <$> z.linesAfter 208 | ] 209 | , _displayLines_cursorPos = (cursorCol, cursorRow) 210 | , _displayLines_offsetMap = mempty 211 | } 212 | where 213 | cursorRow = length z.linesBefore 214 | cursorCol = CZ.lineWidth z.tokensBefore 215 | tokenToSpan CZ.Token{..} = highlightSpan tokenType $ Span tag tokenContent 216 | cursorTokenToSpan = tokenToSpan >>> position @1 %~ cursorTag 217 | lineToSpans line = tokenToSpan <$> (plainToken "" : line) 218 | (cursorToken, tokensAfter) = fromMaybe (plainToken " ", []) $ do 219 | (ta, tas) <- uncons z.tokensAfter 220 | let (ct, ta') = CZ.splitTokenAt 1 ta 221 | pure (ct, ta' : tas) 222 | currentLineSpans = 223 | mconcat 224 | [ lineToSpans $ reverse z.tokensBefore 225 | , [cursorTokenToSpan cursorToken] 226 | , lineToSpans tokensAfter 227 | ] 228 | 229 | nonEmptyToken :: Token -> Token 230 | nonEmptyToken t 231 | | Text.null t.tokenContent = t{CZ.tokenContent = " "} 232 | | otherwise = t 233 | 234 | highlightSpan :: TokenType -> Span V.Attr -> Span V.Attr 235 | highlightSpan = (position @1 %~) . tokenAttr @DefaultDark 236 | 237 | tokenAttr :: forall base16. Base16 base16 => TokenType -> V.Attr -> V.Attr 238 | tokenAttr KeywordTok = flip V.withForeColor (base0E @base16) 239 | tokenAttr DataTypeTok = flip V.withForeColor (base0A @base16) 240 | tokenAttr DecValTok = flip V.withForeColor (base09 @base16) 241 | tokenAttr BaseNTok = flip V.withForeColor (base09 @base16) 242 | tokenAttr FloatTok = flip V.withForeColor (base09 @base16) 243 | tokenAttr ConstantTok = flip V.withForeColor (base09 @base16) 244 | tokenAttr CharTok = flip V.withForeColor (base08 @base16) 245 | tokenAttr SpecialCharTok = flip V.withForeColor (base0F @base16) 246 | tokenAttr StringTok = flip V.withForeColor (base0B @base16) 247 | tokenAttr VerbatimStringTok = flip V.withForeColor (base0B @base16) 248 | tokenAttr SpecialStringTok = flip V.withForeColor (base0B @base16) 249 | tokenAttr ImportTok = flip V.withForeColor (base0D @base16) 250 | tokenAttr CommentTok = flip V.withForeColor (base03 @base16) . flip V.withStyle V.italic 251 | tokenAttr DocumentationTok = flip V.withForeColor (base08 @base16) 252 | tokenAttr AnnotationTok = flip V.withForeColor (base0F @base16) 253 | tokenAttr CommentVarTok = flip V.withForeColor (base03 @base16) . flip V.withStyle V.italic 254 | tokenAttr OtherTok = flip V.withForeColor (base0A @base16) 255 | tokenAttr FunctionTok = flip V.withForeColor (base0D @base16) 256 | tokenAttr VariableTok = flip V.withForeColor (base08 @base16) 257 | tokenAttr ControlFlowTok = flip V.withForeColor (base0E @base16) 258 | tokenAttr OperatorTok = flip V.withForeColor (base05 @base16) 259 | tokenAttr BuiltInTok = flip V.withForeColor (base0D @base16) 260 | tokenAttr ExtensionTok = flip V.withForeColor (base05 @base16) 261 | tokenAttr PreprocessorTok = flip V.withForeColor (base0A @base16) 262 | tokenAttr AttributeTok = flip V.withForeColor (base0A @base16) 263 | tokenAttr RegionMarkerTok = flip V.withForeColor (base05 @base16) 264 | tokenAttr InformationTok = flip V.withForeColor (base05 @base16) 265 | tokenAttr WarningTok = flip V.withForeColor (base08 @base16) 266 | tokenAttr AlertTok = flip V.withForeColor (base00 @base16) 267 | tokenAttr ErrorTok = flip V.withForeColor (base00 @base16) 268 | tokenAttr NormalTok = flip V.withForeColor (base05 @base16) 269 | 270 | class Base16 base16 where 271 | base00 :: V.Color 272 | base01 :: V.Color 273 | base02 :: V.Color 274 | base03 :: V.Color 275 | base04 :: V.Color 276 | base05 :: V.Color 277 | base06 :: V.Color 278 | base07 :: V.Color 279 | base08 :: V.Color 280 | base09 :: V.Color 281 | base0A :: V.Color 282 | base0B :: V.Color 283 | base0C :: V.Color 284 | base0D :: V.Color 285 | base0E :: V.Color 286 | base0F :: V.Color 287 | 288 | data DefaultDark 289 | 290 | instance Base16 DefaultDark where 291 | base00 = V.linearColor @Word8 0x18 0x18 0x18 292 | base01 = V.linearColor @Word8 0x28 0x28 0x28 293 | base02 = V.linearColor @Word8 0x38 0x38 0x38 294 | base03 = V.linearColor @Word8 0x58 0x58 0x58 295 | base04 = V.linearColor @Word8 0xB8 0xB8 0xB8 296 | base05 = V.linearColor @Word8 0xD8 0xD8 0xD8 297 | base06 = V.linearColor @Word8 0xE8 0xE8 0xE8 298 | base07 = V.linearColor @Word8 0xF8 0xF8 0xF8 299 | base08 = V.linearColor @Word8 0xAB 0x46 0x42 300 | base09 = V.linearColor @Word8 0xDC 0x96 0x56 301 | base0A = V.linearColor @Word8 0xF7 0xCA 0x88 302 | base0B = V.linearColor @Word8 0xA1 0xB5 0x6C 303 | base0C = V.linearColor @Word8 0x86 0xC1 0xB9 304 | base0D = V.linearColor @Word8 0x7C 0xAF 0xC2 305 | base0E = V.linearColor @Word8 0xBA 0x8B 0xAF 306 | base0F = V.linearColor @Word8 0xA1 0x69 0x46 307 | 308 | {- | Given a width and a 'TextZipper', produce a list of display lines 309 | (i.e., lines of wrapped text) with special attributes applied to 310 | certain segments (e.g., the cursor). Additionally, produce the current 311 | y-coordinate of the cursor and a mapping from display line number to text 312 | offset 313 | -} 314 | displayCodeLines 315 | :: Int 316 | -- ^ Width, used for wrapping 317 | -> V.Attr 318 | -- ^ Metadata for normal characters 319 | -> (V.Attr -> V.Attr) 320 | -- ^ Metadata for the cursor 321 | -> CodeZipper TokenType 322 | -- ^ The text input contents and cursor state 323 | -> DisplayLines V.Attr 324 | displayCodeLines = displayCodeLinesWithAlignment TextAlignment_Left 325 | 326 | -- | Default vty event handler for text inputs 327 | updateCodeZipper 328 | :: Int 329 | -- ^ Tab width 330 | -> Int 331 | -- ^ Page size 332 | -> V.Event 333 | -- ^ The vty event to handle 334 | -> CodeZipper TokenType 335 | -- ^ The zipper to modify 336 | -> CodeZipper TokenType 337 | updateCodeZipper tabWidth pageSize ev = case ev of 338 | -- Special characters 339 | V.EvKey (V.KChar '\t') [] -> CZ.insertChar '\t' 340 | V.EvKey V.KEnter [] -> CZ.insertChar '\n' 341 | -- Regular characters 342 | V.EvKey (V.KChar k) [] -> CZ.insertChar k 343 | -- Deletion buttons 344 | V.EvKey V.KBS [] -> CZ.deleteLeft 345 | V.EvKey V.KDel [] -> CZ.deleteRight 346 | -- Arrow keys 347 | V.EvKey V.KLeft [] -> CZ.left 348 | V.EvKey V.KRight [] -> CZ.right 349 | V.EvKey V.KUp [] -> CZ.up 350 | V.EvKey V.KDown [] -> CZ.down 351 | V.EvKey V.KHome [] -> CZ.home 352 | V.EvKey V.KEnd [] -> CZ.end 353 | V.EvKey V.KPageUp [] -> CZ.upN pageSize 354 | V.EvKey V.KPageDown [] -> CZ.downN pageSize 355 | _ -> id 356 | -------------------------------------------------------------------------------- /dosh/test/Data/Sequence/ZipperSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Data.Sequence.ZipperSpec where 5 | 6 | import Control.Applicative ((<|>)) 7 | import Control.Monad (unless) 8 | import Data.List (foldl') 9 | import Data.Maybe (listToMaybe) 10 | import Data.Ord (clamp) 11 | import Data.Sequence qualified as Seq 12 | import Data.Sequence.Zipper hiding (length) 13 | import Data.Sequence.Zipper qualified as SZ 14 | import GHC.Exts (IsList (..)) 15 | import Test.Hspec hiding (after, before) 16 | import Test.QuickCheck 17 | import Prelude 18 | 19 | instance Arbitrary t => Arbitrary (SeqZipper t) where 20 | arbitrary :: Gen (SeqZipper t) 21 | arbitrary = do 22 | before <- arbitrary 23 | after <- arbitrary 24 | pure SeqZipper{..} 25 | 26 | shouldBeEquivalentTo :: (Eq t, Show t) => SeqZipper t -> SeqZipper t -> Expectation 27 | shouldBeEquivalentTo a b = toList a `shouldBe` toList b 28 | 29 | isList :: forall t. (Eq t, Show t) => SeqZipper t -> Expectation 30 | isList z = fromList (toList z) `shouldBeEquivalentTo` z 31 | 32 | isMonoid :: (Eq t, Show t) => SeqZipper t -> SeqZipper t -> SeqZipper t -> Expectation 33 | isMonoid a b c = (a <> b) <> c `shouldBe` a <> (b <> c) 34 | 35 | listMonoidHomomorphism :: (Eq t, Show t) => SeqZipper t -> SeqZipper t -> Expectation 36 | listMonoidHomomorphism a b = toList (a <> b) `shouldBe` toList a <> toList b 37 | 38 | data Move 39 | = Forward 40 | | Back 41 | | Home 42 | | End 43 | | ForwardWhile Predicate 44 | | BackWhile Predicate 45 | deriving stock (Show, Eq) 46 | 47 | data Predicate 48 | = NotEqualZero 49 | | Even 50 | deriving stock (Show, Eq, Bounded, Enum) 51 | 52 | predicate :: Integral t => Predicate -> (t -> Bool) 53 | predicate NotEqualZero = (/= 0) 54 | predicate Even = even 55 | 56 | instance Arbitrary Move where 57 | arbitrary = elements $ Forward : Back : Home : End : ([ForwardWhile, BackWhile] <*> [minBound .. maxBound]) 58 | 59 | type MoveSequence = [Move] 60 | 61 | performMove :: (Integral t) => Move -> SeqZipper t -> SeqZipper t 62 | performMove Forward = forward 63 | performMove Back = back 64 | performMove Home = home 65 | performMove End = end 66 | performMove (ForwardWhile (predicate -> p)) = forwardWhile p 67 | performMove (BackWhile (predicate -> p)) = backWhile p 68 | 69 | performMoves :: (Integral t) => SeqZipper t -> MoveSequence -> SeqZipper t 70 | performMoves = foldl' (flip performMove) 71 | 72 | unchangedByMovement :: (Integral t, Show t) => SeqZipper t -> MoveSequence -> Expectation 73 | unchangedByMovement zipper moves = performMoves zipper moves `shouldBeEquivalentTo` zipper 74 | 75 | itMoves :: (Integral t, Show t) => Move -> SeqZipper t -> Expectation 76 | itMoves m zipper = do 77 | newPosition `shouldBe` expectedNewPosition 78 | case m of 79 | Forward -> current newZipper `shouldBe` listToMaybe (Prelude.drop 1 forwardList) 80 | Back -> current newZipper `shouldBe` listToMaybe backwardList <|> current zipper 81 | Home -> current newZipper `shouldBe` listToMaybe (toList zipper) 82 | End -> current newZipper `shouldBe` Nothing 83 | ForwardWhile (predicate -> p) -> current newZipper `shouldSatisfy` maybe True (not . p) 84 | BackWhile (predicate -> p) -> unless (null $ before newZipper) $ back newZipper `shouldSatisfy` maybe False (not . p) . current 85 | where 86 | position = Seq.length (before zipper) 87 | newZipper = performMove m zipper 88 | newPosition = Seq.length (before newZipper) 89 | expectedNewPosition = clamp (0, SZ.length zipper) $ case m of 90 | Forward -> position + 1 91 | Back -> position - 1 92 | Home -> 0 93 | End -> maxBound 94 | ForwardWhile (predicate -> p) -> position + length (takeWhile p forwardList) 95 | BackWhile (predicate -> p) -> position - length (takeWhile p backwardList) 96 | forwardList = toList $ after zipper 97 | backwardList = reverse $ toList $ before zipper 98 | 99 | spec :: Spec 100 | spec = do 101 | it "is a list" $ property $ isList @Int 102 | it "is a monoid" $ property $ isMonoid @Int 103 | it "list is a monoid homomorphism" $ property $ listMonoidHomomorphism @Int 104 | it "is unchanged by movement" $ property $ unchangedByMovement @Int 105 | it "correctly handles movement" $ property $ itMoves @Int 106 | -------------------------------------------------------------------------------- /dosh/test/Data/Text/CodeZipperSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Data.Text.CodeZipperSpec where 5 | 6 | import Control.Arrow ((>>>)) 7 | import Data.Char (isSpace) 8 | import Data.Function ((&)) 9 | import Data.List (uncons) 10 | import Data.List.Extra (groupOn) 11 | import Data.Ord (clamp) 12 | import Data.Text (Text) 13 | import Data.Text qualified as Text 14 | import Data.Text.CodeZipper 15 | import Test.Hspec 16 | import Test.Hspec.Expectations.Extra 17 | import Test.QuickCheck 18 | import Test.QuickCheck.Utf8 19 | import Prelude hiding (Left, Right) 20 | 21 | data Printable = Graphic | Whitespace 22 | deriving stock (Eq, Show) 23 | 24 | type PrintableToken = Token Printable 25 | 26 | instance Arbitrary PrintableToken where 27 | arbitrary = oneof [arbitraryGraphic, arbitraryWhitespace] 28 | where 29 | arbitraryGraphic = do 30 | tokenContent <- Text.pack <$> listOf1 (elements ['a' .. 'z']) 31 | pure Token{tokenType = Graphic, ..} 32 | arbitraryWhitespace = do 33 | tokenContent <- Text.pack <$> listOf1 (elements [' ', '\t']) 34 | pure Token{tokenType = Whitespace, ..} 35 | 36 | type PrintableLine = SourceLine Printable 37 | 38 | instance Pretty Printable where 39 | plain = fmap onSpace . Text.split (== '\n') 40 | where 41 | onSpace "" = [] 42 | onSpace t = case Text.break isSpace t of 43 | ("", rt) -> onGraph rt 44 | (t', rt) -> Token Graphic t' : onGraph rt 45 | onGraph "" = [] 46 | onGraph t = case Text.break (not . isSpace) t of 47 | ("", rt) -> onSpace rt 48 | (t', rt) -> Token Whitespace t' : onSpace rt 49 | pretty _ = Just . plain 50 | 51 | instance Arbitrary Text where 52 | arbitrary = genValidUtf8 53 | 54 | instance (Arbitrary (Token t), Pretty t, Eq t) => Arbitrary (CodeZipper t) where 55 | arbitrary = oneof [fromTokens, fromText] 56 | where 57 | fromTokens, fromText :: Gen (CodeZipper t) 58 | fromTokens = do 59 | linesBefore <- scale (`div` 2) $ listOf arbitraryLine 60 | linesAfter <- scale (`div` 2) $ listOf arbitraryLine 61 | tokensBefore <- arbitraryLine 62 | tokensAfter <- arbitraryLine 63 | pure CodeZipper{language = "", ..} 64 | fromText = plainZipper <$> arbitrary <*> arbitrary 65 | arbitraryLine :: Gen (SourceLine t) 66 | arbitraryLine = scale (`div` 4) $ normaliseToks <$> listOf arbitrary 67 | 68 | data Move = Up | Down | Left | Right | Home | End | Top | Bottom 69 | deriving stock (Bounded, Enum, Eq, Show) 70 | 71 | move :: Eq t => Move -> CodeZipper t -> CodeZipper t 72 | move Up = up 73 | move Down = down 74 | move Left = left 75 | move Right = right 76 | move Home = home 77 | move End = end 78 | move Top = top 79 | move Bottom = bottom 80 | 81 | instance Arbitrary Move where arbitrary = elements [minBound .. maxBound] 82 | 83 | type MoveSequence = [Move] 84 | 85 | isomorphicText :: (Eq t, Show t, Pretty t) => CodeZipper t -> Expectation 86 | isomorphicText cz = do 87 | let t = toText cz 88 | tb = textBefore cz 89 | ta = textAfter cz 90 | tb <> ta `shouldBe` t 91 | plainZipper t "" `isEquivalentTo` cz 92 | plainZipper "" t `isEquivalentTo` cz 93 | plainZipper tb ta `isEquivalentTo` cz 94 | 95 | isNormalised :: (Eq t, Show t) => CodeZipper t -> Expectation 96 | isNormalised cz = allLines cz `shouldSatisfy` all normalised 97 | 98 | normalised :: Eq t => SourceLine t -> Bool 99 | normalised = groupOn tokenType >>> fmap length >>> all (<= 1) 100 | 101 | goHome :: (Eq t, Show t) => CodeZipper t -> Expectation 102 | goHome cz = do 103 | let cz' = home cz 104 | cz'.tokensBefore `shouldBe` mempty 105 | cz'.tokensAfter `shouldSatisfy` normalised 106 | cz'.tokensAfter `shouldStartWith` reverse tokensBeforeWithCurrent 107 | cz'.linesBefore `shouldBe` cz.linesBefore 108 | cz'.linesAfter `shouldBe` cz.linesAfter 109 | home cz' `shouldBe` cz' 110 | where 111 | tokensBeforeWithCurrent = case currentToken cz of 112 | Nothing -> cz.tokensBefore 113 | Just t -> t : drop 1 cz.tokensBefore 114 | 115 | goTop :: (Eq t, Show t) => CodeZipper t -> Expectation 116 | goTop cz = do 117 | let cz' = top cz 118 | cz'.linesBefore `shouldBe` mempty 119 | cz'.linesAfter `shouldBe` maybe [] snd (uncons (allLines cz)) 120 | top cz' `shouldBe` cz' 121 | 122 | goMove :: (Eq t) => Move -> CodeZipper t -> Expectation 123 | goMove m cz = do 124 | position (move m cz) `shouldBe` expectedNewPosition 125 | where 126 | position :: CodeZipper t -> (Int, Int) 127 | position z = (col z, row z) 128 | (x, y) = position cz 129 | expectedNewPosition = xyClamp $ case m of 130 | Up -> (x, y - 1) 131 | Down -> (x, y + 1) 132 | Left -> (x - 1, y) 133 | Right -> (x + 1, y) 134 | Top -> (x, 0) 135 | Bottom -> (x, maxBound) 136 | Home -> (0, y) 137 | End -> (maxBound, y) 138 | numberOfLines = length $ allLines cz 139 | rowClamp = clamp (0, numberOfLines - 1) 140 | colClamp n = clamp (0, lineWidth $ allLines cz !! n) 141 | xyClamp (x', y') = let cy = rowClamp y'; cx = colClamp cy x' in (cx, cy) 142 | 143 | unchangedByMovement :: (Eq t, Show t) => Move -> CodeZipper t -> Expectation 144 | unchangedByMovement m cz = do 145 | move m cz `isEquivalentTo` cz 146 | 147 | insertText :: (Eq t, Pretty t) => CodeZipper t -> Text -> Expectation 148 | insertText cz t = do 149 | let cz' = insert t cz 150 | toText cz' `shouldContainText` t 151 | textBefore cz' `shouldBe` (textBefore cz <> t) 152 | textAfter cz' `shouldBe` textAfter cz 153 | 154 | showZipper :: (Show t) => CodeZipper t -> String 155 | showZipper cz = unlines [show cz, show [textBefore cz, textAfter cz]] 156 | 157 | spec :: Spec 158 | spec = do 159 | it "does not contain adjacent tokens of the same type" $ property $ isNormalised @Printable 160 | it "is isomorphic on fromText / toText" $ property $ isomorphicText @Printable 161 | it "correctly handles home" $ property $ goHome @Printable 162 | it "correctly handles top" $ property $ goTop @Printable 163 | it "correctly handles movement" $ property $ goMove @Printable 164 | it "is unchanged by movement" $ property $ unchangedByMovement @Printable 165 | it "inserts text correctly" $ property $ insertText @Printable 166 | it "correctly handles empty lines" $ property $ do 167 | let cz :: CodeZipper Printable 168 | cz = mempty{linesBefore = [[Token Graphic "a"]], linesAfter = [[Token Graphic "b"]]} 169 | toText cz `shouldBe` "a\n\nb" 170 | 171 | isEquivalentTo :: (Eq t, Show t) => CodeZipper t -> CodeZipper t -> Expectation 172 | a `isEquivalentTo` b = do 173 | (a & home & top) `shouldBe` (b & home & top) 174 | -------------------------------------------------------------------------------- /dosh/test/Dosh/GHC/EvaluatorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Dosh.GHC.EvaluatorSpec where 5 | 6 | import Data.Text.Encoding qualified as Text 7 | import Development.IDE.GHC.Compat (Ghc) 8 | import Dosh.GHC.Evaluator qualified as GHC 9 | import Dosh.GHC.ParserSpec 10 | import Dosh.GHC.Server qualified as GHC 11 | import Dosh.Prelude hiding (elements) 12 | import Dosh.Util 13 | import Test.Hspec 14 | import Test.QuickCheck 15 | 16 | runGhcSession :: Ghc () -> IO (ByteString, ByteString, [SomeException]) 17 | runGhcSession action = do 18 | GHC.testServer $ do 19 | action 20 | GHC.evaluate "mapM_ hFlush [stdout, stderr]" 21 | 22 | quietly :: Property -> IO () 23 | quietly = 24 | quickCheckWithResult (stdArgs{chatty = False}) >=> \case 25 | Success{} -> pure () 26 | Failure{output} -> expectationFailure output 27 | GaveUp{output} -> expectationFailure output 28 | NoExpectedFailure{output} -> expectationFailure output 29 | 30 | evalValidChunks :: SourceChunk -> Expectation 31 | evalValidChunks chunk = 32 | withTimeout (1_000_000 + 100_000 * length chunk.srcs) $ 33 | runGhcSession (GHC.evaluate $ tshow chunk) `shouldReturn` (expectedOutput, "", []) 34 | where 35 | expectedOutput = mconcat [Text.encodeUtf8 o | ExpressionSource _ o <- chunk.srcs] 36 | 37 | spec :: Spec 38 | spec = it "correctly evaluates chunks" $ quietly $ property evalValidChunks 39 | -------------------------------------------------------------------------------- /dosh/test/Dosh/GHC/LexerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Dosh.GHC.LexerSpec where 4 | 5 | import Data.Text qualified as Text 6 | import Dosh.GHC.Lexer 7 | import Dosh.Prelude hiding (elements) 8 | import Test.Hspec 9 | import Test.Hspec.Expectations.Extra 10 | import Test.QuickCheck 11 | 12 | atLine :: Text -> Int -> Chunk 13 | atLine = flip $ chunkFromText "" 14 | 15 | shouldStartOnLine :: RealSrcSpan -> Int -> Expectation 16 | loc `shouldStartOnLine` l = startLine loc `shouldBe` l 17 | 18 | startLine :: RealSrcSpan -> Int 19 | startLine = srcLocLine . realSrcSpanStart 20 | 21 | endLine :: RealSrcSpan -> Int 22 | endLine = srcLocLine . realSrcSpanEnd 23 | 24 | locate :: Text -> Expectation 25 | locate (flip atLine 1 -> L loc code) = do 26 | srcSpanFile loc `shouldBe` "" 27 | srcLocLine start `shouldBe` 1 28 | srcLocCol start `shouldBe` 1 29 | srcLocLine end `shouldBe` length codeLines 30 | srcLocCol end `shouldBe` max 1 (Text.length (last codeLines)) 31 | where 32 | start = realSrcSpanStart loc 33 | end = realSrcSpanEnd loc 34 | codeLines = Text.splitOn "\n" code 35 | 36 | chunksAreNotAdjacent :: Text -> Expectation 37 | chunksAreNotAdjacent (flip atLine 1 -> c) = do 38 | let chunks = splitChunks c 39 | forM_ (zip chunks $ tail chunks) $ \(L loc1 _, L loc2 _) -> do 40 | loc2 `shouldStartOnLine` (endLine loc1 + 1) 41 | 42 | expressionsAreAdjacent :: Text -> Expectation 43 | expressionsAreAdjacent (flip atLine 1 -> c) = do 44 | let exprs = splitExpressions c 45 | forM_ (zip exprs $ tail exprs) $ \(L loc1 expr1, L loc2 _) -> do 46 | loc2 `shouldStartOnLine` (endLine loc1 + 1) 47 | expr1 `shouldNotEndWithText` "\n" 48 | 49 | instance Arbitrary Text where 50 | arbitrary = Text.pack <$> listOf (elements "xxx \n") 51 | 52 | spec :: Spec 53 | spec = do 54 | it "correctly locates code" $ property locate 55 | it "does not produce adjacent chunks" $ property chunksAreNotAdjacent 56 | it "produces adjacent expressions" $ property expressionsAreAdjacent 57 | -------------------------------------------------------------------------------- /dosh/test/Dosh/GHC/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Dosh.GHC.ParserSpec where 4 | 5 | import Data.List (intercalate) 6 | import Data.List.Extra (nub) 7 | import Data.Text qualified as Text 8 | import Dosh.GHC.Lexer 9 | import Dosh.GHC.LexerSpec 10 | import Dosh.GHC.Parser 11 | import Dosh.GHC.Server (withGhc) 12 | import Dosh.Prelude hiding (elements) 13 | import Dosh.Util 14 | import Test.Hspec 15 | import Test.QuickCheck 16 | 17 | data ChunkType 18 | = Module 19 | | Expression 20 | | Declaration 21 | deriving stock (Generic, Eq, Show) 22 | 23 | data Source 24 | = PragmaSource Text Text 25 | | ImportSource Text 26 | | DeclarationSource Text 27 | | ExpressionSource Text Text 28 | deriving stock (Generic, Eq) 29 | 30 | instance Show Source where 31 | show (PragmaSource x y) = Text.unpack $ "{-# " <> x <> " " <> y <> " #-}" 32 | show (ImportSource x) = Text.unpack $ "import " <> x 33 | show (DeclarationSource x) = Text.unpack x 34 | show (ExpressionSource x _) = Text.unpack x 35 | 36 | arbitraryPragma :: Gen Source 37 | arbitraryPragma = PragmaSource "LANGUAGE" <$> elements extensions 38 | where 39 | extensions :: [Text] 40 | extensions = foldr (\e acc -> e : ("No" <> e) : acc) [] ["OverloadedStrings", "OverloadedLabels"] 41 | 42 | arbitraryImport :: Gen Source 43 | arbitraryImport = ImportSource <$> elements ["Data.Default", "Data.Text"] 44 | 45 | arbitraryDeclaration :: Gen Source 46 | arbitraryDeclaration = 47 | pure $ 48 | DeclarationSource $ 49 | Text.intercalate 50 | "\n" 51 | [ "square :: Int -> Int" 52 | , "square x = x^2" 53 | ] 54 | 55 | arbitraryExpression :: Gen Source 56 | arbitraryExpression = 57 | uncurry ExpressionSource 58 | <$> elements 59 | [ ("True", "True\n") 60 | , 61 | ( Text.intercalate 62 | "\n" 63 | [ "fromIntegral $" 64 | , " let x = 1" 65 | , " y = 2" 66 | , " in x + y" 67 | ] 68 | , "3\n" 69 | ) 70 | , ("putStrLn \"Hello!\"", "Hello!\n") 71 | ] 72 | 73 | instance Arbitrary Source where 74 | arbitrary = 75 | oneof 76 | [ arbitraryPragma 77 | , arbitraryImport 78 | , arbitraryDeclaration 79 | , arbitraryExpression 80 | ] 81 | 82 | data SourceChunk 83 | = ModuleSourceChunk {srcs :: [Source]} 84 | | DeclarationSourceChunk {srcs :: [Source]} 85 | | ExpressionSourceChunk {srcs :: [Source]} 86 | deriving stock (Eq) 87 | 88 | arbitraryModuleChunk :: Gen SourceChunk 89 | arbitraryModuleChunk = do 90 | pragmas <- listOf arbitraryPragma 91 | decls <- listOf arbitraryDeclaration 92 | pure $ ModuleSourceChunk $ pragmas <> [DeclarationSource "module Foo.Bar where"] <> decls 93 | 94 | arbitraryDeclarationChunk :: Gen SourceChunk 95 | arbitraryDeclarationChunk = do 96 | decls <- nub <$> listOf1 arbitraryDeclaration 97 | pure $ DeclarationSourceChunk decls 98 | 99 | arbitraryExpressionChunk :: Gen SourceChunk 100 | arbitraryExpressionChunk = do 101 | exprs <- listOf1 arbitraryExpression 102 | pure $ ExpressionSourceChunk exprs 103 | 104 | instance Arbitrary SourceChunk where 105 | arbitrary = oneof [{-arbitraryModuleChunk, -} arbitraryDeclarationChunk, arbitraryExpressionChunk] 106 | 107 | instance Show SourceChunk where 108 | show (ModuleSourceChunk inputs) = intercalate "\n\n" $ show <$> inputs 109 | show (DeclarationSourceChunk inputs) = intercalate "\n" $ show <$> inputs 110 | show (ExpressionSourceChunk inputs) = intercalate "\n" $ show <$> inputs 111 | 112 | newtype SourceCode = SourceCode {chunks :: [SourceChunk]} 113 | 114 | instance Show SourceCode where 115 | show SourceCode{..} = intercalate "\n\n" $ show <$> chunks 116 | 117 | instance Arbitrary SourceCode where 118 | arbitrary = SourceCode <$> arbitrary 119 | 120 | instance Eq SomeException where 121 | a == b = tshow a == tshow b 122 | 123 | parseChunks :: SourceCode -> Expectation 124 | parseChunks c@(flip atLine 1 . tshow -> code) = do 125 | Right parsedChunks <- withGhc $ mapM parseChunk $ splitChunks code 126 | length parsedChunks `shouldBe` max 1 (length c.chunks) 127 | zipWithM_ compareChunks parsedChunks c.chunks 128 | where 129 | compareChunks :: ParsedChunk -> SourceChunk -> Expectation 130 | compareChunks (describeParsed -> parsed) (describeSource -> source) = parsed `shouldBe` source 131 | describeSource ModuleSourceChunk{} = Module 132 | describeSource DeclarationSourceChunk{} = Declaration 133 | describeSource ExpressionSourceChunk{} = Expression 134 | describeParsed ModuleChunk{} = Module 135 | describeParsed DeclarationChunk{} = Declaration 136 | describeParsed ExpressionChunk{} = Expression 137 | 138 | spec :: Spec 139 | spec = do 140 | it "correctly parses chunks" $ property parseChunks 141 | -------------------------------------------------------------------------------- /dosh/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-prepositive-qualified-module #-} 2 | -------------------------------------------------------------------------------- /dosh/test/Test/Hspec/Expectations/Extra.hs: -------------------------------------------------------------------------------- 1 | module Test.Hspec.Expectations.Extra where 2 | 3 | import Control.Monad (unless) 4 | import Data.List (isPrefixOf, isSuffixOf) 5 | import Data.Text (Text) 6 | import Data.Text qualified as Text 7 | import Test.Hspec 8 | import Prelude 9 | 10 | expectTrue :: HasCallStack => String -> Bool -> Expectation 11 | expectTrue msg b = unless b (expectationFailure msg) 12 | 13 | compareWith :: (HasCallStack, Show a) => (a -> a -> Bool) -> String -> a -> a -> Expectation 14 | compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result) 15 | where 16 | errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected 17 | 18 | shouldContainText :: Text -> Text -> Expectation 19 | a `shouldContainText` b = Text.unpack a `shouldContain` Text.unpack b 20 | 21 | shouldStartWithText :: Text -> Text -> Expectation 22 | a `shouldStartWithText` b = Text.unpack a `shouldStartWith` Text.unpack b 23 | 24 | shouldEndWithText :: Text -> Text -> Expectation 25 | a `shouldEndWithText` b = Text.unpack a `shouldEndWith` Text.unpack b 26 | 27 | shouldNotStartWith :: (Eq a, Show a) => [a] -> [a] -> Expectation 28 | shouldNotStartWith = compareWith ((not .) . isPrefixOf) "should not start with" 29 | 30 | shouldNotEndWith :: (Eq a, Show a) => [a] -> [a] -> Expectation 31 | shouldNotEndWith = compareWith ((not .) . isSuffixOf) "should not end with" 32 | 33 | shouldNotStartWithText :: Text -> Text -> Expectation 34 | a `shouldNotStartWithText` b = Text.unpack a `shouldNotStartWith` Text.unpack b 35 | 36 | shouldNotEndWithText :: Text -> Text -> Expectation 37 | a `shouldNotEndWithText` b = Text.unpack a `shouldNotEndWith` Text.unpack b 38 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1673956053, 7 | "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "inputs": { 21 | "systems": "systems" 22 | }, 23 | "locked": { 24 | "lastModified": 1685518550, 25 | "narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=", 26 | "owner": "numtide", 27 | "repo": "flake-utils", 28 | "rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "numtide", 33 | "repo": "flake-utils", 34 | "type": "github" 35 | } 36 | }, 37 | "nix-filter": { 38 | "locked": { 39 | "lastModified": 1681154353, 40 | "narHash": "sha256-MCJ5FHOlbfQRFwN0brqPbCunLEVw05D/3sRVoNVt2tI=", 41 | "owner": "numtide", 42 | "repo": "nix-filter", 43 | "rev": "f529f42792ade8e32c4be274af6b6d60857fbee7", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "numtide", 48 | "repo": "nix-filter", 49 | "type": "github" 50 | } 51 | }, 52 | "nixpkgs": { 53 | "locked": { 54 | "lastModified": 1686488075, 55 | "narHash": "sha256-2otSBt2hbeD+5yY25NF3RhWx7l5SDt1aeU3cJ/9My4M=", 56 | "owner": "nixos", 57 | "repo": "nixpkgs", 58 | "rev": "9401a0c780b49faf6c28adf55764f230301d0dce", 59 | "type": "github" 60 | }, 61 | "original": { 62 | "owner": "nixos", 63 | "ref": "nixpkgs-unstable", 64 | "repo": "nixpkgs", 65 | "type": "github" 66 | } 67 | }, 68 | "root": { 69 | "inputs": { 70 | "flake-compat": "flake-compat", 71 | "flake-utils": "flake-utils", 72 | "nix-filter": "nix-filter", 73 | "nixpkgs": "nixpkgs" 74 | } 75 | }, 76 | "systems": { 77 | "locked": { 78 | "lastModified": 1681028828, 79 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 80 | "owner": "nix-systems", 81 | "repo": "default", 82 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 83 | "type": "github" 84 | }, 85 | "original": { 86 | "owner": "nix-systems", 87 | "repo": "default", 88 | "type": "github" 89 | } 90 | } 91 | }, 92 | "root": "root", 93 | "version": 7 94 | } 95 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "dosh: the power of Haskell in your terminal!"; 3 | 4 | nixConfig = { 5 | extra-substituters = "https://dosh.cachix.org"; 6 | extra-trusted-public-keys = "dosh.cachix.org-1:wRNFshU1IQW71/P0ueRqOdPqzsff/eGNl2MNKpsZy/o="; 7 | }; 8 | 9 | inputs = { 10 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 11 | flake-utils.url = "github:numtide/flake-utils"; 12 | nix-filter.url = "github:numtide/nix-filter"; 13 | flake-compat = { 14 | url = "github:edolstra/flake-compat"; 15 | flake = false; 16 | }; 17 | }; 18 | 19 | outputs = inputs: inputs.flake-utils.lib.eachDefaultSystem 20 | (system: 21 | with builtins; 22 | let 23 | pkgs = inputs.nixpkgs.legacyPackages.${system}; 24 | lib = inputs.nixpkgs.lib; 25 | src = pname: inputs.nix-filter.lib { 26 | root = "${./.}/${pname}"; 27 | include = [ 28 | "app" 29 | "src" 30 | "test" 31 | "${pname}.cabal" 32 | "CHANGELOG.md" 33 | "LICENCE" 34 | ]; 35 | }; 36 | haskellPackagesOverride = ps: ps.override { 37 | overrides = self: super: 38 | with pkgs.haskell.lib; 39 | let ghcVersionAtLeast = lib.versionAtLeast ps.ghc.version; in 40 | builtins.trace "GHC version: ${ps.ghc.version}" 41 | ({ 42 | dosh-prelude = self.callCabal2nix "dosh-prelude" (src "dosh-prelude") { }; 43 | dosh = self.callCabal2nix "dosh" (src "dosh") { }; 44 | lsp-client = self.callCabal2nix "lsp-client" (src "lsp-client") { }; 45 | reflex-process = doJailbreak super.reflex-process; 46 | reflex-vty = markUnbroken super.reflex-vty; 47 | haskell-language-server = lib.pipe super.haskell-language-server [ 48 | (drv: drv.override { hls-ormolu-plugin = null; }) 49 | (drv: disableCabalFlag drv "ormolu") 50 | ]; 51 | } // lib.optionalAttrs (ghcVersionAtLeast "9.4") { 52 | ghc-syntax-highlighter = super.ghc-syntax-highlighter_0_0_9_0; 53 | mmorph = doJailbreak super.mmorph; 54 | reflex = doJailbreak super.reflex_0_9_0_0; 55 | string-qq = doJailbreak super.string-qq; 56 | } // lib.optionalAttrs (ghcVersionAtLeast "9.6") { 57 | commutative-semigroups = doJailbreak super.commutative-semigroups; 58 | ed25519 = doJailbreak super.ed25519; 59 | ghc-trace-events = doJailbreak super.ghc-trace-events; 60 | hie-compat = doJailbreak super.hie-compat; 61 | indexed-traversable = doJailbreak super.indexed-traversable; 62 | }); 63 | }; 64 | outputsFor = 65 | { haskellPackages 66 | , name 67 | , pname ? "" 68 | , ... 69 | }: 70 | let ps = haskellPackagesOverride haskellPackages; in 71 | { 72 | packages.${name} = ps.${pname} or ps; 73 | devShells.${name} = ps.shellFor { 74 | packages = ps: with ps; [ dosh lsp-client ]; 75 | withHoogle = true; 76 | nativeBuildInputs = with ps; [ 77 | cabal-fmt 78 | cabal-install 79 | fourmolu 80 | haskell-language-server 81 | pkgs.cachix 82 | pkgs.nixpkgs-fmt 83 | ]; 84 | }; 85 | formatter = pkgs.nixpkgs-fmt; 86 | }; 87 | in 88 | with lib; 89 | foldl' (acc: conf: recursiveUpdate acc (outputsFor conf)) { } 90 | (mapAttrsToList (name: haskellPackages: { inherit name haskellPackages; }) pkgs.haskell.packages ++ [ 91 | { 92 | inherit (pkgs) haskellPackages; 93 | name = "defaultGhc"; 94 | } 95 | { 96 | pname = "dosh"; 97 | inherit (pkgs) haskellPackages; 98 | name = "default"; 99 | } 100 | ]) 101 | ); 102 | } 103 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 4 2 | function-arrows: leading 3 | comma-style: leading 4 | import-export-style: leading 5 | indent-wheres: false 6 | record-brace-space: false 7 | newlines-between-decls: 1 8 | haddock-style: multi-line 9 | let-style: auto 10 | in-style: right-align 11 | respectful: false 12 | fixities: [] 13 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /lsp-client/lsp-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: lsp-client 3 | version: 0.0.1 4 | synopsis: Haskell library for Language Server Protocol clients 5 | homepage: https://github.com/ners/dosh 6 | license: GPL-3.0-or-later 7 | license-file: LICENCE 8 | author: ners 9 | maintainer: ners@gmx.ch 10 | category: System 11 | build-type: Simple 12 | 13 | common common 14 | default-language: GHC2021 15 | ghc-options: 16 | -Weverything 17 | -Wno-unsafe 18 | -Wno-missing-safe-haskell-mode 19 | -Wno-missing-export-lists 20 | -Wno-missing-import-lists 21 | -Wno-missing-kind-signatures 22 | -Wno-all-missed-specialisations 23 | default-extensions: 24 | ApplicativeDo 25 | DataKinds 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DeriveGeneric 29 | DerivingStrategies 30 | DerivingVia 31 | ExplicitNamespaces 32 | NoImplicitPrelude 33 | OverloadedLabels 34 | OverloadedRecordDot 35 | OverloadedStrings 36 | RecordWildCards 37 | RecursiveDo 38 | TypeFamilies 39 | ViewPatterns 40 | build-depends: 41 | aeson, 42 | base, 43 | bytestring, 44 | lens, 45 | lsp-types, 46 | unliftio, 47 | 48 | library 49 | import: common 50 | hs-source-dirs: src 51 | build-depends: 52 | Diff, 53 | Glob, 54 | aeson-pretty, 55 | co-log-core, 56 | data-default, 57 | dependent-map, 58 | directory, 59 | filepath, 60 | generic-lens, 61 | hashable, 62 | lsp, 63 | mtl, 64 | stm, 65 | text, 66 | text-rope, 67 | unordered-containers, 68 | if os(windows) 69 | build-depends: Win32 70 | else 71 | build-depends: unix 72 | exposed-modules: 73 | Language.LSP.Client, 74 | Language.LSP.Client.Compat, 75 | Language.LSP.Client.Decoding, 76 | Language.LSP.Client.Encoding, 77 | Language.LSP.Client.Exceptions, 78 | Language.LSP.Client.Session 79 | 80 | test-suite spec 81 | import: common 82 | ghc-options: -threaded -prof 83 | type: exitcode-stdio-1.0 84 | hs-source-dirs: test 85 | main-is: Spec.hs 86 | build-depends: 87 | QuickCheck, 88 | extra, 89 | hspec, 90 | lsp-client, 91 | process, 92 | other-modules: 93 | Language.LSP.ClientSpec 94 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client.hs: -------------------------------------------------------------------------------- 1 | module Language.LSP.Client where 2 | 3 | import Control.Concurrent.STM 4 | import Control.Monad (forever) 5 | import Control.Monad.IO.Class (MonadIO (liftIO)) 6 | import Control.Monad.Reader (asks, runReaderT) 7 | import Data.ByteString.Lazy qualified as LazyByteString 8 | import Data.Dependent.Map qualified as DMap 9 | import Data.Either (fromLeft) 10 | import Data.Generics.Labels () 11 | import Language.LSP.Client.Decoding 12 | import Language.LSP.Client.Encoding (encode) 13 | import Language.LSP.Client.Session 14 | import Language.LSP.Types (From, Method, MethodType, SMethod (..)) 15 | import Language.LSP.Types qualified as LSP 16 | import Language.LSP.VFS (initVFS) 17 | import System.IO (Handle, stdin, stdout) 18 | import UnliftIO (concurrently_, race) 19 | import Prelude 20 | 21 | runSession :: Session () -> IO () 22 | runSession = runSessionWithHandles stdin stdout 23 | 24 | data SMethodType (t :: MethodType) where 25 | Notification :: SMethodType 'LSP.Notification 26 | Request :: SMethodType 'LSP.Request 27 | 28 | methodType :: forall (f :: From) (t :: MethodType) (m :: Method f t). SMethod m -> SMethodType t 29 | methodType SInitialize = Request 30 | methodType SInitialized = Notification 31 | methodType SShutdown = Request 32 | methodType SExit = Notification 33 | methodType SWorkspaceDidChangeWorkspaceFolders = Notification 34 | methodType SWorkspaceDidChangeConfiguration = Notification 35 | methodType SWorkspaceDidChangeWatchedFiles = Notification 36 | methodType SWorkspaceSymbol = Request 37 | methodType SWorkspaceExecuteCommand = Request 38 | methodType STextDocumentDidOpen = Notification 39 | methodType STextDocumentDidChange = Notification 40 | methodType STextDocumentWillSave = Notification 41 | methodType STextDocumentWillSaveWaitUntil = Request 42 | methodType STextDocumentDidSave = Notification 43 | methodType STextDocumentDidClose = Notification 44 | methodType STextDocumentCompletion = Request 45 | methodType SCompletionItemResolve = Request 46 | methodType STextDocumentHover = Request 47 | methodType STextDocumentSignatureHelp = Request 48 | methodType STextDocumentDeclaration = Request 49 | methodType STextDocumentDefinition = Request 50 | methodType STextDocumentTypeDefinition = Request 51 | methodType STextDocumentImplementation = Request 52 | methodType STextDocumentReferences = Request 53 | methodType STextDocumentDocumentHighlight = Request 54 | methodType STextDocumentDocumentSymbol = Request 55 | methodType STextDocumentCodeAction = Request 56 | methodType STextDocumentCodeLens = Request 57 | methodType SCodeLensResolve = Request 58 | methodType STextDocumentDocumentLink = Request 59 | methodType SDocumentLinkResolve = Request 60 | methodType STextDocumentDocumentColor = Request 61 | methodType STextDocumentColorPresentation = Request 62 | methodType STextDocumentFormatting = Request 63 | methodType STextDocumentRangeFormatting = Request 64 | methodType STextDocumentOnTypeFormatting = Request 65 | methodType STextDocumentRename = Request 66 | methodType STextDocumentPrepareRename = Request 67 | methodType STextDocumentFoldingRange = Request 68 | methodType STextDocumentSelectionRange = Request 69 | methodType STextDocumentPrepareCallHierarchy = Request 70 | methodType SCallHierarchyIncomingCalls = Request 71 | methodType SCallHierarchyOutgoingCalls = Request 72 | methodType STextDocumentSemanticTokens = Request 73 | methodType STextDocumentSemanticTokensFull = Request 74 | methodType STextDocumentSemanticTokensFullDelta = Request 75 | methodType STextDocumentSemanticTokensRange = Request 76 | methodType SWindowShowMessage = Notification 77 | methodType SWindowShowMessageRequest = Request 78 | methodType SWindowShowDocument = Request 79 | methodType SWindowLogMessage = Notification 80 | methodType SWindowWorkDoneProgressCancel = Notification 81 | methodType SWindowWorkDoneProgressCreate = Request 82 | methodType SProgress = Notification 83 | methodType STelemetryEvent = Notification 84 | methodType SClientRegisterCapability = Request 85 | methodType SClientUnregisterCapability = Request 86 | methodType SWorkspaceWorkspaceFolders = Request 87 | methodType SWorkspaceConfiguration = Request 88 | methodType SWorkspaceApplyEdit = Request 89 | methodType SWorkspaceSemanticTokensRefresh = Request 90 | methodType STextDocumentPublishDiagnostics = Notification 91 | methodType SCancelRequest = Notification 92 | methodType (SCustomMethod _) = undefined 93 | 94 | runSessionWithHandles :: Handle -> Handle -> Session a -> IO a 95 | runSessionWithHandles input output action = initVFS $ \vfs -> do 96 | initialState <- defaultSessionState vfs 97 | flip runReaderT initialState $ do 98 | actionResult <- race action $ do 99 | let send = do 100 | message <- asks outgoing >>= liftIO . atomically . readTQueue 101 | liftIO $ LazyByteString.hPut output $ encode message 102 | let receive = do 103 | serverBytes <- liftIO $ getNextMessage input 104 | (serverMessage, requestCallback) <- 105 | asks pendingRequests 106 | >>= liftIO . atomically . flip stateTVar (decodeFromServerMsg serverBytes) 107 | handleServerMessage serverMessage 108 | liftIO requestCallback 109 | case serverMessage of 110 | LSP.FromServerMess smethod msg -> case methodType smethod of 111 | Notification -> do 112 | handlers :: NotificationMap <- asks notificationHandlers >>= liftIO . readTVarIO 113 | let NotificationCallback cb = DMap.findWithDefault (NotificationCallback (const $ pure ())) smethod handlers 114 | liftIO $ cb msg 115 | _ -> pure () 116 | _ -> pure () 117 | concurrently_ (forever send) (forever receive) 118 | pure $ fromLeft (error "send/receive thread should not exit!") actionResult 119 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Language.LSP.Client.Compat where 4 | 5 | import Language.LSP.Types 6 | import Prelude 7 | 8 | #ifdef mingw32_HOST_OS 9 | import System.Win32.Process qualified 10 | #else 11 | import System.Posix.Process qualified 12 | #endif 13 | 14 | getCurrentProcessID :: IO Int 15 | #ifdef mingw32_HOST_OS 16 | getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessID 17 | #else 18 | getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID 19 | #endif 20 | 21 | lspClientInfo :: ClientInfo 22 | lspClientInfo = ClientInfo "lsp-client" (Just CURRENT_PACKAGE_VERSION) 23 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client/Decoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeInType #-} 3 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | 6 | module Language.LSP.Client.Decoding where 7 | 8 | import Control.Exception (catch, throw) 9 | import Control.Monad (liftM2) 10 | import Data.Aeson (Result (Error, Success), Value, decode) 11 | import Data.Aeson.Types (parse) 12 | import Data.ByteString.Lazy (LazyByteString) 13 | import Data.ByteString.Lazy.Char8 qualified as LazyByteString 14 | import Data.Dependent.Map (DMap) 15 | import Data.Dependent.Map qualified as DMap 16 | import Data.Functor 17 | import Data.Functor.Const 18 | import Data.Functor.Product (Product (Pair)) 19 | import Data.IxMap (IxMap) 20 | import Data.IxMap qualified as IxMap 21 | import Data.Maybe (fromJust, fromMaybe) 22 | import Language.LSP.Client.Exceptions 23 | import Language.LSP.Types 24 | import System.IO (Handle, hGetLine) 25 | import System.IO.Error (isEOFError) 26 | import Prelude hiding (id) 27 | 28 | {- | Fetches the next message bytes based on 29 | the Content-Length header 30 | -} 31 | getNextMessage :: Handle -> IO LazyByteString 32 | getNextMessage h = do 33 | headers <- getHeaders h 34 | case read . init <$> lookup "Content-Length" headers of 35 | Nothing -> throw NoContentLengthHeader 36 | Just size -> LazyByteString.hGet h size 37 | 38 | getHeaders :: Handle -> IO [(String, String)] 39 | getHeaders h = do 40 | l <- catch (hGetLine h) eofHandler 41 | let (name, val) = span (/= ':') l 42 | if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h 43 | where 44 | eofHandler :: IOError -> a 45 | eofHandler e 46 | | isEOFError e = throw UnexpectedServerTermination 47 | | otherwise = throw e 48 | 49 | type RequestMap = IxMap LspId RequestCallback 50 | 51 | emptyRequestMap :: RequestMap 52 | emptyRequestMap = IxMap.emptyIxMap 53 | 54 | data RequestCallback (m :: Method 'FromClient 'Request) = RequestCallback 55 | { requestCallback :: ResponseMessage m -> IO () 56 | , requestMethod :: SMethod m 57 | } 58 | 59 | type NotificationMap = DMap SMethod NotificationCallback 60 | 61 | emptyNotificationMap :: NotificationMap 62 | emptyNotificationMap = mempty 63 | 64 | newtype NotificationCallback (m :: Method 'FromServer 'Notification) = NotificationCallback 65 | { notificationCallback :: Message m -> IO () 66 | } 67 | 68 | instance Semigroup (NotificationCallback m) where 69 | (NotificationCallback c1) <> (NotificationCallback c2) = NotificationCallback $ liftM2 (*>) c1 c2 70 | 71 | instance Monoid (NotificationCallback m) where 72 | mempty = NotificationCallback (const $ pure ()) 73 | 74 | updateRequestMap :: LspId m -> RequestCallback m -> RequestMap -> RequestMap 75 | updateRequestMap = ((fromMaybe (error "updateRequestMap: duplicate key registration") .) .) . IxMap.insertIxMap 76 | 77 | updateNotificationMap :: SMethod m -> NotificationCallback m -> NotificationMap -> NotificationMap 78 | updateNotificationMap = DMap.insertWith' (<>) 79 | 80 | -- getRequestMap :: [FromClientMessage] -> RequestMap 81 | -- getRequestMap = foldl' helper emptyIxMap 82 | -- where 83 | -- helper :: RequestMap -> FromClientMessage -> RequestMap 84 | -- helper acc msg = case msg of 85 | -- FromClientMess m mess -> case splitClientMethod m of 86 | -- IsClientNot -> acc 87 | -- IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m 88 | -- IsClientEither -> case mess of 89 | -- NotMess _ -> acc 90 | -- ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m 91 | -- _ -> acc 92 | 93 | decodeFromServerMsg :: LazyByteString -> RequestMap -> ((FromServerMessage, IO ()), RequestMap) 94 | decodeFromServerMsg bytes reqMap = unP $ parse p obj 95 | where 96 | obj = fromJust $ decode bytes :: Value 97 | p = parseServerMessage $ \(lid :: LspId m) -> 98 | let (maybeCallback, newMap) = IxMap.pickFromIxMap lid reqMap 99 | in maybeCallback <&> \c -> (c.requestMethod, Pair c (Const newMap)) 100 | -- case maybeCallback of 101 | -- Nothing -> Nothing 102 | -- Just m -> Just (m, Pair m (Const newMap)) 103 | unP (Success (FromServerMess m msg)) = ((FromServerMess m msg, pure ()), reqMap) 104 | unP (Success (FromServerRsp (Pair c (Const newMap)) msg)) = ((FromServerRsp c.requestMethod msg, c.requestCallback msg), newMap) 105 | unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e 106 | 107 | {- 108 | WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" 109 | WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" 110 | CustomServerMethod _ 111 | | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes 112 | | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes 113 | | otherwise -> NotCustomServer $ fromJust $ decode bytes 114 | 115 | Error e -> error e 116 | -} 117 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client/Encoding.hs: -------------------------------------------------------------------------------- 1 | module Language.LSP.Client.Encoding where 2 | 3 | import Data.Aeson (ToJSON) 4 | import Data.Aeson qualified as Aeson 5 | import Data.ByteString.Lazy (LazyByteString) 6 | import Data.ByteString.Lazy.Char8 qualified as LazyByteString 7 | import Prelude 8 | 9 | addHeader :: LazyByteString -> LazyByteString 10 | addHeader content = 11 | mconcat 12 | [ "Content-Length: " 13 | , LazyByteString.pack $ show $ LazyByteString.length content 14 | , "\r\n" 15 | , "\r\n" 16 | , content 17 | ] 18 | 19 | encode :: ToJSON a => a -> LazyByteString 20 | encode = addHeader . Aeson.encode 21 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client/Exceptions.hs: -------------------------------------------------------------------------------- 1 | module Language.LSP.Client.Exceptions where 2 | 3 | import Control.Exception (Exception) 4 | import Data.Aeson (Value, encode) 5 | import Data.Aeson.Encode.Pretty (encodePretty) 6 | import Data.Algorithm.Diff (getGroupedDiff) 7 | import Data.Algorithm.DiffOutput (ppDiff) 8 | import Data.ByteString.Lazy.Char8 qualified as LazyByteString 9 | import Data.List (nub) 10 | import Language.LSP.Types 11 | ( FromServerMessage 12 | , ResponseError 13 | , SomeLspId 14 | ) 15 | import Prelude 16 | 17 | -- | An exception that can be thrown during a 'Language.LSP.Client.Session' 18 | data SessionException 19 | = Timeout (Maybe FromServerMessage) 20 | | NoContentLengthHeader 21 | | UnexpectedMessage String FromServerMessage 22 | | ReplayOutOfOrder FromServerMessage [FromServerMessage] 23 | | UnexpectedDiagnostics 24 | | IncorrectApplyEditRequest String 25 | | UnexpectedResponseError SomeLspId ResponseError 26 | | UnexpectedServerTermination 27 | | IllegalInitSequenceMessage FromServerMessage 28 | | MessageSendError Value IOError 29 | deriving stock (Eq) 30 | 31 | instance Exception SessionException 32 | 33 | instance Show SessionException where 34 | show (Timeout lastMsg) = 35 | "Timed out waiting to receive a message from the server." 36 | ++ case lastMsg of 37 | Just msg -> "\nLast message received:\n" ++ LazyByteString.unpack (encodePretty msg) 38 | Nothing -> mempty 39 | show NoContentLengthHeader = "Couldn't read Content-Length header from the server." 40 | show (UnexpectedMessage expected lastMsg) = 41 | "Received an unexpected message from the server:\n" 42 | ++ "Was parsing: " 43 | ++ expected 44 | ++ "\n" 45 | ++ "But the last message received was:\n" 46 | ++ LazyByteString.unpack (encodePretty lastMsg) 47 | show (ReplayOutOfOrder received expected) = 48 | let expected' = nub expected 49 | getJsonDiff :: FromServerMessage -> [String] 50 | getJsonDiff = lines . LazyByteString.unpack . encodePretty 51 | showExp e = 52 | LazyByteString.unpack (encodePretty e) 53 | ++ "\nDiff:\n" 54 | ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff e)) 55 | in "Replay is out of order:\n" 56 | ++ 57 | -- Print json so its a bit easier to update the session logs 58 | "Received from server:\n" 59 | ++ LazyByteString.unpack (encodePretty received) 60 | ++ "\n" 61 | ++ "Raw from server:\n" 62 | ++ LazyByteString.unpack (encode received) 63 | ++ "\n" 64 | ++ "Expected one of:\n" 65 | ++ unlines (map showExp expected') 66 | show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." 67 | show (IncorrectApplyEditRequest msgStr) = 68 | "ApplyEditRequest didn't contain document, instead received:\n" 69 | ++ msgStr 70 | show (UnexpectedResponseError lid e) = 71 | "Received an expected error in a response for id " 72 | ++ show lid 73 | ++ ":\n" 74 | ++ show e 75 | show UnexpectedServerTermination = "Language server unexpectedly terminated" 76 | show (IllegalInitSequenceMessage msg) = 77 | "Received an illegal message between the initialize request and response:\n" 78 | ++ LazyByteString.unpack (encodePretty msg) 79 | show (MessageSendError msg e) = 80 | "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ LazyByteString.unpack (encodePretty msg) 81 | 82 | -- | A predicate that matches on any 'SessionException' 83 | anySessionException :: SessionException -> Bool 84 | anySessionException = const True 85 | -------------------------------------------------------------------------------- /lsp-client/src/Language/LSP/Client/Session.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Language.LSP.Client.Session where 5 | 6 | import Colog.Core (LogAction (..), Severity (..), WithSeverity (..)) 7 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 8 | import Control.Concurrent.STM 9 | import Control.Exception (throw) 10 | import Control.Lens hiding (Empty, List) 11 | import Control.Monad (unless, when) 12 | import Control.Monad.IO.Class (MonadIO (liftIO)) 13 | import Control.Monad.Reader (ReaderT, asks) 14 | import Control.Monad.State (StateT, execState) 15 | import Data.Default (def) 16 | import Data.Foldable (foldl', foldr', forM_, toList) 17 | import Data.Function (on) 18 | import Data.Functor (void) 19 | import Data.Generics.Labels () 20 | import Data.HashMap.Strict (HashMap) 21 | import Data.HashMap.Strict qualified as HashMap 22 | import Data.HashSet (HashSet) 23 | import Data.HashSet qualified as HashSet 24 | import Data.Hashable (Hashable) 25 | import Data.List (groupBy, sortBy) 26 | import Data.Maybe (fromJust, fromMaybe, mapMaybe) 27 | import Data.Text (Text) 28 | import Data.Text qualified as Text 29 | import Data.Text.IO qualified as Text 30 | import Data.Text.Utf16.Rope (Rope) 31 | import GHC.Generics (Generic) 32 | import Language.LSP.Client.Compat (getCurrentProcessID, lspClientInfo) 33 | import Language.LSP.Client.Decoding 34 | import Language.LSP.Client.Exceptions (SessionException (UnexpectedResponseError)) 35 | import Language.LSP.Types 36 | import Language.LSP.Types.Capabilities (ClientCapabilities, fullCaps) 37 | import Language.LSP.Types.Lens hiding (applyEdit, capabilities, executeCommand, id, message, rename, to) 38 | import Language.LSP.Types.Lens qualified as LSP 39 | import Language.LSP.VFS 40 | ( VFS 41 | , VfsLog 42 | , VirtualFile (..) 43 | , changeFromClientVFS 44 | , changeFromServerVFS 45 | , closeVFS 46 | , lsp_version 47 | , openVFS 48 | , vfsMap 49 | , virtualFileVersion 50 | ) 51 | import System.Directory (canonicalizePath) 52 | import System.FilePath (isAbsolute, ()) 53 | import System.FilePath.Glob qualified as Glob 54 | import Prelude 55 | 56 | deriving stock instance Generic ProgressToken 57 | 58 | deriving anyclass instance Hashable ProgressToken 59 | 60 | data SessionState = SessionState 61 | { initialized :: TMVar InitializeResult 62 | , pendingRequests :: TVar RequestMap 63 | , notificationHandlers :: TVar NotificationMap 64 | , lastRequestId :: TVar Int32 65 | , serverCapabilities :: TVar (HashMap Text SomeRegistration) 66 | -- ^ The capabilities that the server has dynamically registered with us so 67 | -- far 68 | , clientCapabilities :: ClientCapabilities 69 | , progressTokens :: TVar (HashSet ProgressToken) 70 | , outgoing :: TQueue FromClientMessage 71 | -- ^ Messages that have been serialised but not yet written to the output handle 72 | , vfs :: TVar VFS 73 | -- ^ Virtual, in-memory file system of the files known to the LSP 74 | , rootDir :: FilePath 75 | } 76 | 77 | defaultSessionState :: VFS -> IO SessionState 78 | defaultSessionState vfs' = do 79 | initialized <- newEmptyTMVarIO 80 | pendingRequests <- newTVarIO emptyRequestMap 81 | notificationHandlers <- newTVarIO emptyNotificationMap 82 | lastRequestId <- newTVarIO 0 83 | serverCapabilities <- newTVarIO mempty 84 | progressTokens <- newTVarIO mempty 85 | outgoing <- newTQueueIO 86 | vfs <- newTVarIO vfs' 87 | pure 88 | SessionState 89 | { rootDir = "." 90 | , clientCapabilities = def 91 | , .. 92 | } 93 | 94 | type Session = ReaderT SessionState IO 95 | 96 | -- extract Uri out from DocumentChange 97 | -- didn't put this in `lsp-types` because TH was getting in the way 98 | documentChangeUri :: DocumentChange -> Uri 99 | documentChangeUri (InL x) = x ^. textDocument . uri 100 | documentChangeUri (InR (InL x)) = x ^. uri 101 | documentChangeUri (InR (InR (InL x))) = x ^. oldUri 102 | documentChangeUri (InR (InR (InR x))) = x ^. uri 103 | 104 | handleServerMessage :: FromServerMessage -> Session () 105 | handleServerMessage (FromServerMess SProgress req) = do 106 | let update = asks progressTokens >>= liftIO . flip modifyTVarIO (HashSet.insert $ req ^. params . token) 107 | case req ^. params . value of 108 | Begin{} -> update 109 | End{} -> update 110 | Report{} -> pure () 111 | handleServerMessage (FromServerMess SClientRegisterCapability req) = do 112 | let List newRegs = req ^. params . registrations <&> \sr@(SomeRegistration r) -> (r ^. LSP.id, sr) 113 | asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs)) 114 | handleServerMessage (FromServerMess SClientUnregisterCapability req) = do 115 | let List unRegs = req ^. params . unregisterations <&> (^. LSP.id) 116 | asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs) 117 | handleServerMessage (FromServerMess SWorkspaceApplyEdit r) = do 118 | -- First, prefer the versioned documentChanges field 119 | allChangeParams <- case r ^. params . edit . documentChanges of 120 | Just (List cs) -> do 121 | mapM_ (checkIfNeedsOpened . documentChangeUri) cs 122 | -- replace the user provided version numbers with the VFS ones + 1 123 | -- (technically we should check that the user versions match the VFS ones) 124 | cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs 125 | return $ mapMaybe getParamsFromDocumentChange cs' 126 | -- Then fall back to the changes field 127 | Nothing -> case r ^. params . edit . changes of 128 | Just cs -> do 129 | mapM_ checkIfNeedsOpened (HashMap.keys cs) 130 | concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) 131 | Nothing -> 132 | error "WorkspaceEdit contains neither documentChanges nor changes!" 133 | 134 | asks vfs >>= liftIO . flip modifyTVarIO (execState $ changeFromServerVFS logger r) 135 | 136 | let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams 137 | mergedParams = mergeParams <$> groupedParams 138 | 139 | -- TODO: Don't do this when replaying a session 140 | forM_ mergedParams (sendNotification STextDocumentDidChange) 141 | 142 | -- Update VFS to new document versions 143 | let sortedVersions = sortBy (compare `on` (^. textDocument . version)) <$> groupedParams 144 | latestVersions = (^. textDocument) . last <$> sortedVersions 145 | 146 | forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> 147 | asks vfs 148 | >>= liftIO 149 | . flip 150 | modifyTVarIO 151 | ( \vfs -> do 152 | let update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t 153 | in vfs & vfsMap . ix (toNormalizedUri uri) %~ update 154 | ) 155 | sendResponse 156 | r 157 | $ Right 158 | ApplyWorkspaceEditResponseBody 159 | { _applied = True 160 | , _failureReason = Nothing 161 | , _failedChange = Nothing 162 | } 163 | where 164 | logger :: LogAction (StateT VFS Identity) (WithSeverity VfsLog) 165 | logger = LogAction $ \(WithSeverity msg sev) -> case sev of Error -> error $ show msg; _ -> pure () 166 | checkIfNeedsOpened uri = do 167 | isOpen <- asks vfs >>= liftIO . readTVarIO <&> has (vfsMap . ix (toNormalizedUri uri)) 168 | 169 | -- if its not open, open it 170 | unless isOpen $ do 171 | contents <- maybe (pure "") (liftIO . Text.readFile) (uriToFilePath uri) 172 | sendNotification 173 | STextDocumentDidOpen 174 | DidOpenTextDocumentParams 175 | { _textDocument = 176 | TextDocumentItem 177 | { _uri = uri 178 | , _languageId = "" 179 | , _version = 0 180 | , _text = contents 181 | } 182 | } 183 | 184 | getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams 185 | getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do 186 | DidChangeTextDocumentParams docId (List $ editToChangeEvent <$> edits) 187 | 188 | editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent 189 | editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) 190 | editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) 191 | 192 | getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams 193 | getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit 194 | getParamsFromDocumentChange _ = Nothing 195 | 196 | bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = head <$> textDocumentVersions uri 197 | 198 | -- For a uri returns an infinite list of versions [n,n+1,n+2,...] 199 | -- where n is the current version 200 | textDocumentVersions :: Uri -> Session [VersionedTextDocumentIdentifier] 201 | textDocumentVersions uri = do 202 | vfs <- asks vfs >>= liftIO . readTVarIO 203 | let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version 204 | pure $ VersionedTextDocumentIdentifier uri . Just <$> [curVer + 1 ..] 205 | 206 | textDocumentEdits uri edits = do 207 | vers <- textDocumentVersions uri 208 | pure $ zipWith (\v e -> TextDocumentEdit v (List [InL e])) vers edits 209 | 210 | getChangeParams uri (List edits) = fmap getParamsFromTextDocumentEdit <$> textDocumentEdits uri (reverse edits) 211 | 212 | mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams 213 | mergeParams params = 214 | let events = concat $ toList $ toList . (^. contentChanges) <$> params 215 | in DidChangeTextDocumentParams (head params ^. textDocument) (List events) 216 | handleServerMessage (FromServerMess SWindowWorkDoneProgressCreate req) = sendResponse req $ Right Empty 217 | handleServerMessage _ = pure () 218 | 219 | overTVar :: (a -> a) -> TVar a -> STM a 220 | overTVar f var = stateTVar var (\x -> (f x, f x)) 221 | 222 | overTVarIO :: (a -> a) -> TVar a -> IO a 223 | overTVarIO = (atomically .) . overTVar 224 | 225 | modifyTVarIO :: TVar a -> (a -> a) -> IO () 226 | modifyTVarIO = (atomically .) . modifyTVar 227 | 228 | writeTVarIO :: TVar a -> a -> IO () 229 | writeTVarIO = (atomically .) . writeTVar 230 | 231 | -- | Sends a request to the server, with a callback that fires when the response arrives. 232 | sendRequest 233 | :: forall (m :: Method 'FromClient 'Request) 234 | . Message m ~ RequestMessage m 235 | => SMethod m 236 | -> MessageParams m 237 | -> (ResponseMessage m -> IO ()) 238 | -> Session (LspId m) 239 | sendRequest requestMethod params requestCallback = do 240 | reqId <- asks lastRequestId >>= liftIO . overTVarIO (+ 1) <&> IdInt 241 | asks pendingRequests >>= liftIO . flip modifyTVarIO (updateRequestMap reqId RequestCallback{..}) 242 | sendMessage $ fromClientReq $ RequestMessage "2.0" reqId requestMethod params 243 | pure reqId 244 | 245 | sendResponse 246 | :: forall (m :: Method 'FromServer 'Request) 247 | . RequestMessage m 248 | -> Either ResponseError (ResponseResult m) 249 | -> Session () 250 | sendResponse req = 251 | sendMessage 252 | . FromClientRsp (req ^. LSP.method) 253 | . ResponseMessage (req ^. jsonrpc) (Just $ req ^. LSP.id) 254 | 255 | -- | Sends a request to the server and waits for its response. 256 | request 257 | :: forall (m :: Method 'FromClient 'Request) 258 | . Message m ~ RequestMessage m 259 | => SMethod m 260 | -> MessageParams m 261 | -> Session (ResponseMessage m) 262 | request method params = do 263 | done <- liftIO newEmptyMVar 264 | void $ sendRequest method params $ putMVar done 265 | liftIO $ takeMVar done 266 | 267 | {- | Checks the response for errors and throws an exception if needed. 268 | Returns the result if successful. 269 | -} 270 | getResponseResult :: ResponseMessage m -> ResponseResult m 271 | getResponseResult response = either err id $ response ^. result 272 | where 273 | lid = SomeLspId $ fromJust $ response ^. LSP.id 274 | err = throw . UnexpectedResponseError lid 275 | 276 | -- | Sends a notification to the server. Update the VFS as needed 277 | sendNotification 278 | :: forall (m :: Method 'FromClient 'Notification) 279 | . Message m ~ NotificationMessage m 280 | => SMethod m 281 | -> MessageParams m 282 | -> Session () 283 | sendNotification m params = do 284 | let n = NotificationMessage "2.0" m params 285 | vfs <- asks vfs 286 | case m of 287 | STextDocumentDidOpen -> liftIO $ modifyTVarIO vfs (execState $ openVFS mempty n) 288 | STextDocumentDidClose -> liftIO $ modifyTVarIO vfs (execState $ closeVFS mempty n) 289 | STextDocumentDidChange -> liftIO $ modifyTVarIO vfs (execState $ changeFromClientVFS mempty n) 290 | _ -> pure () 291 | sendMessage $ fromClientNot n 292 | 293 | receiveNotification 294 | :: forall (m :: Method 'FromServer 'Notification) 295 | . SMethod m 296 | -> (Message m -> IO ()) 297 | -> Session () 298 | receiveNotification method notificationCallback = 299 | asks notificationHandlers 300 | >>= liftIO 301 | . flip 302 | modifyTVarIO 303 | ( updateNotificationMap method NotificationCallback{..} 304 | ) 305 | 306 | sendMessage :: FromClientMessage -> Session () 307 | sendMessage msg = asks outgoing >>= liftIO . atomically . (`writeTQueue` msg) 308 | 309 | initialize :: Session () 310 | initialize = do 311 | pid <- liftIO getCurrentProcessID 312 | response <- 313 | request 314 | SInitialize 315 | InitializeParams 316 | { _workDoneToken = Nothing 317 | , _processId = Just $ fromIntegral pid 318 | , _clientInfo = Just lspClientInfo 319 | , _rootPath = Nothing 320 | , _rootUri = Nothing 321 | , _initializationOptions = Nothing 322 | , _capabilities = fullCaps 323 | , _trace = Just TraceOff 324 | , _workspaceFolders = Nothing 325 | } 326 | asks initialized >>= liftIO . atomically . flip putTMVar (getResponseResult response) 327 | sendNotification SInitialized $ Just InitializedParams 328 | 329 | {- | /Creates/ a new text document. This is different from 'openDoc' 330 | as it sends a workspace/didChangeWatchedFiles notification letting the server 331 | know that a file was created within the workspace, __provided that the server 332 | has registered for it__, and the file matches any patterns the server 333 | registered for. 334 | It /does not/ actually create a file on disk, but is useful for convincing 335 | the server that one does exist. 336 | -} 337 | createDoc 338 | :: FilePath 339 | -- ^ The path to the document to open, __relative to the root directory__. 340 | -> Text 341 | -- ^ The text document's language identifier, e.g. @"haskell"@. 342 | -> Text 343 | -- ^ The content of the text document to create. 344 | -> Session TextDocumentIdentifier 345 | -- ^ The identifier of the document just created. 346 | createDoc file language contents = do 347 | serverCaps <- asks serverCapabilities >>= liftIO . readTVarIO 348 | clientCaps <- asks clientCapabilities 349 | rootDir <- asks rootDir 350 | absFile <- liftIO $ canonicalizePath (rootDir file) 351 | let pred :: SomeRegistration -> [Registration 'WorkspaceDidChangeWatchedFiles] 352 | pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] 353 | pred _ = mempty 354 | regs :: [Registration 'WorkspaceDidChangeWatchedFiles] 355 | regs = concatMap pred $ HashMap.elems serverCaps 356 | watchHits :: FileSystemWatcher -> Bool 357 | watchHits (FileSystemWatcher pattern kind) = 358 | -- If WatchKind is excluded, defaults to all true as per spec 359 | fileMatches (Text.unpack pattern) && maybe True (view watchCreate) kind 360 | 361 | fileMatches pattern = Glob.match (Glob.compile pattern) (if isAbsolute pattern then absFile else file) 362 | 363 | regHits :: Registration 'WorkspaceDidChangeWatchedFiles -> Bool 364 | regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers) 365 | 366 | clientCapsSupports = 367 | clientCaps 368 | ^? workspace 369 | . _Just 370 | . didChangeWatchedFiles 371 | . _Just 372 | . dynamicRegistration 373 | . _Just 374 | == Just True 375 | shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs 376 | 377 | when shouldSend $ 378 | sendNotification SWorkspaceDidChangeWatchedFiles $ 379 | DidChangeWatchedFilesParams $ 380 | List [FileEvent (filePathToUri (rootDir file)) FcCreated] 381 | openDoc' file language contents 382 | 383 | {- | Opens a text document that /exists on disk/, and sends a 384 | textDocument/didOpen notification to the server. 385 | -} 386 | openDoc :: FilePath -> Text -> Session TextDocumentIdentifier 387 | openDoc file language = do 388 | rootDir <- asks rootDir 389 | let fp = rootDir file 390 | contents <- liftIO $ Text.readFile fp 391 | openDoc' file language contents 392 | 393 | {- | This is a variant of `openDoc` that takes the file content as an argument. 394 | Use this is the file exists /outside/ of the current workspace. 395 | -} 396 | openDoc' :: FilePath -> Text -> Text -> Session TextDocumentIdentifier 397 | openDoc' file language contents = do 398 | rootDir <- asks rootDir 399 | let fp = rootDir file 400 | uri = filePathToUri fp 401 | item = TextDocumentItem uri language 0 contents 402 | sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item) 403 | pure $ TextDocumentIdentifier uri 404 | 405 | -- | Closes a text document and sends a textDocument/didOpen notification to the server. 406 | closeDoc :: TextDocumentIdentifier -> Session () 407 | closeDoc docId = do 408 | let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) 409 | sendNotification STextDocumentDidClose params 410 | 411 | -- | Changes a text document and sends a textDocument/didOpen notification to the server. 412 | changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () 413 | changeDoc docId changes = do 414 | verDoc <- getVersionedDoc docId 415 | let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) 416 | sendNotification STextDocumentDidChange params 417 | 418 | -- | Gets the Uri for the file corrected to the session directory. 419 | getDocUri :: FilePath -> Session Uri 420 | getDocUri file = do 421 | rootDir <- asks rootDir 422 | let fp = rootDir file 423 | return $ filePathToUri fp 424 | 425 | -- | The current text contents of a document. 426 | documentContents :: TextDocumentIdentifier -> Session (Maybe Rope) 427 | documentContents (TextDocumentIdentifier uri) = do 428 | vfs <- asks vfs >>= liftIO . readTVarIO 429 | pure $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to _file_text 430 | 431 | -- | Adds the current version to the document, as tracked by the session. 432 | getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier 433 | getVersionedDoc (TextDocumentIdentifier uri) = do 434 | vfs <- asks vfs >>= liftIO . readTVarIO 435 | let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion 436 | pure $ VersionedTextDocumentIdentifier uri ver 437 | -------------------------------------------------------------------------------- /lsp-client/test/Language/LSP/ClientSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.LSP.ClientSpec where 2 | 3 | import Control.Arrow ((>>>)) 4 | import Control.Exception 5 | import Control.Lens ((^.)) 6 | import Control.Monad 7 | import Control.Monad.Extra (whenMaybeM, whileJustM, whileM) 8 | import Data.Aeson ((.:)) 9 | import Data.Aeson qualified as Aeson 10 | import Data.Aeson.Types (parseMaybe) 11 | import Data.ByteString (ByteString, hGetSome) 12 | import Data.ByteString.Builder.Extra (defaultChunkSize) 13 | import Data.ByteString.Lazy qualified as LazyByteString 14 | import Data.Coerce (coerce) 15 | import Data.Maybe (fromJust) 16 | import Data.Tuple.Extra (thd3) 17 | import Language.LSP.Client 18 | import Language.LSP.Client.Decoding (getNextMessage) 19 | import Language.LSP.Client.Encoding (encode) 20 | import Language.LSP.Client.Session 21 | import Language.LSP.Client.Session qualified as LSP 22 | import Language.LSP.Types 23 | import Language.LSP.Types qualified as LSP 24 | import Language.LSP.Types.Lens qualified as LSP 25 | import System.IO 26 | import System.Process (createPipe) 27 | import Test.Hspec hiding (shouldReturn) 28 | import Test.Hspec qualified as Hspec 29 | import Test.Hspec.QuickCheck 30 | import Test.QuickCheck 31 | import UnliftIO (MonadIO (..), MonadUnliftIO, fromEither, newTVarIO, race, readTVarIO) 32 | import UnliftIO.Concurrent 33 | import Prelude hiding (log) 34 | 35 | shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () 36 | shouldReturn a expected = a >>= liftIO . flip Hspec.shouldBe expected 37 | 38 | withTimeout :: forall m a. MonadUnliftIO m => Int -> m a -> m a 39 | withTimeout delay a = fromEither =<< race timeout a 40 | where 41 | timeout = do 42 | threadDelay delay 43 | pure $ AssertionFailed "Timeout exceeded" 44 | 45 | diagnostic :: Int -> Diagnostic 46 | diagnostic i = 47 | Diagnostic 48 | { _range = 49 | Range 50 | { _start = Position{_line = 0, _character = 0} 51 | , _end = Position{_line = 0, _character = 0} 52 | } 53 | , _severity = Nothing 54 | , _code = Just $ InL $ fromIntegral i 55 | , _source = Nothing 56 | , _message = "" 57 | , _tags = Nothing 58 | , _relatedInformation = Nothing 59 | } 60 | 61 | -- | LSP server that does not read input, and sends dummy diagnostics once per second 62 | diagServer :: IO (Handle, Handle, ThreadId) 63 | diagServer = do 64 | (inRead, inWrite) <- createPipe 65 | hSetBuffering inRead LineBuffering 66 | hSetBuffering inWrite LineBuffering 67 | (outRead, outWrite) <- createPipe 68 | hSetBuffering outRead LineBuffering 69 | hSetBuffering outWrite LineBuffering 70 | threadId <- forkIO $ forM_ [1 ..] $ \i -> do 71 | threadDelay 1_000 72 | let message = 73 | NotificationMessage 74 | "2.0" 75 | STextDocumentPublishDiagnostics 76 | PublishDiagnosticsParams 77 | { _uri = Uri "" 78 | , _version = Nothing 79 | , _diagnostics = List [diagnostic i] 80 | } 81 | LazyByteString.hPut outWrite $ encode message 82 | pure (inWrite, outRead, threadId) 83 | 84 | -- | LSP server that accepts requests and answers them with a delay 85 | reqServer :: IO (Handle, Handle, ThreadId) 86 | reqServer = do 87 | (inRead, inWrite) <- createPipe 88 | hSetBuffering inRead LineBuffering 89 | hSetBuffering inWrite LineBuffering 90 | (outRead, outWrite) <- createPipe 91 | hSetBuffering outRead LineBuffering 92 | hSetBuffering outWrite LineBuffering 93 | lock <- newMVar () 94 | threadId <- forkIO $ forever $ do 95 | bytes <- liftIO $ getNextMessage inRead 96 | let obj = fromJust $ Aeson.decode bytes 97 | idMaybe = parseMaybe (.: "id") obj 98 | message :: ResponseMessage 'Shutdown 99 | message = ResponseMessage "2.0" idMaybe (Right Empty) 100 | forkIO $ do 101 | threadDelay 1_000 102 | takeMVar lock 103 | LazyByteString.hPut outWrite $ encode message 104 | putMVar lock () 105 | pure (inWrite, outRead, threadId) 106 | 107 | -- | LSP server that reads messages, and does nothing else 108 | notifServer :: IO (Handle, Handle, ThreadId) 109 | notifServer = do 110 | (inRead, inWrite) <- createPipe 111 | hSetBuffering inRead LineBuffering 112 | hSetBuffering inWrite LineBuffering 113 | (outRead, _) <- createPipe 114 | hSetBuffering outRead LineBuffering 115 | threadId <- forkIO $ forever $ do 116 | liftIO $ getNextMessage inRead 117 | pure (inWrite, outRead, threadId) 118 | 119 | -- | LSP client that waits for queries 120 | client :: Handle -> Handle -> IO (Session () -> IO (), ThreadId) 121 | client serverInput serverOutput = do 122 | i <- newEmptyMVar 123 | o <- newEmptyMVar 124 | threadId <- forkIO $ runSessionWithHandles serverOutput serverInput $ forever $ do 125 | a <- takeMVar i 126 | a >>= putMVar o 127 | pure (putMVar i >>> (*> readMVar o), threadId) 128 | 129 | getAvailableContents :: Handle -> IO ByteString 130 | getAvailableContents h = whileJustM $ whenMaybeM (hReady h) (hGetSome h defaultChunkSize) 131 | 132 | spec :: Spec 133 | spec = do 134 | prop "concurrently handles actions and server messages" $ again $ do 135 | bracket 136 | diagServer 137 | (killThread . thd3) 138 | $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do 139 | diagnostics <- newTVarIO @_ @[Diagnostic] [] 140 | let getDiagnostics = readTVarIO diagnostics 141 | setDiagnostics = writeTVarIO diagnostics 142 | receiveNotification LSP.STextDocumentPublishDiagnostics $ \msg -> 143 | setDiagnostics $ coerce $ msg ^. LSP.params . LSP.diagnostics 144 | -- We allow up to 0.1 s to receive the first batch of diagnostics 145 | withTimeout 100_000 $ whileM $ do 146 | threadDelay 1_000 147 | null <$> getDiagnostics 148 | [d1] <- getDiagnostics 149 | -- We allow up to 0.1 s to receive the next batch of diagnostics 150 | withTimeout 100_000 $ whileM $ do 151 | threadDelay 1_000 152 | [d2] <- getDiagnostics 153 | pure $ d2._code == d1._code 154 | prop "answers requests correctly" $ again $ do 155 | bracket 156 | reqServer 157 | (killThread . thd3) 158 | $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do 159 | req1Done <- newEmptyMVar 160 | req1Id <- sendRequest SShutdown Empty (putMVar req1Done . (._id)) 161 | req2Done <- newEmptyMVar 162 | req2Id <- sendRequest SShutdown Empty (putMVar req2Done . (._id)) 163 | withTimeout 100_000 $ takeMVar req1Done `shouldReturn` Just req1Id 164 | withTimeout 100_000 $ takeMVar req2Done `shouldReturn` Just req2Id 165 | prop "opens and changes virtual documents correctly" $ do 166 | bracket 167 | notifServer 168 | (killThread . thd3) 169 | $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do 170 | doc <- LSP.createDoc "TestFile.hs" "haskell" "" 171 | LSP.documentContents doc `shouldReturn` Just "" 172 | changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "foo\n\nbar"] 173 | LSP.documentContents doc `shouldReturn` Just "foo\n\nbar" 174 | closeDoc doc 175 | LSP.documentContents doc `shouldReturn` Nothing 176 | -------------------------------------------------------------------------------- /lsp-client/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-prepositive-qualified-module #-} 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import 2 | ( 3 | let lock = builtins.fromJSON (builtins.readFile ./flake.lock); in 4 | fetchTarball { 5 | url = "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; 6 | sha256 = lock.nodes.flake-compat.locked.narHash; 7 | } 8 | ) 9 | { src = ./.; } 10 | ).shellNix 11 | --------------------------------------------------------------------------------