src/Language/Haskell/LSP/Test/Machine.hs

   1 {-# LANGUAGE KindSignatures #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
   4 module Language.Haskell.LSP.Test.Machine where
   5
   6 import Control.Monad.Catch
   7 import Data.Default
   8 import Language.Haskell.LSP.Test
   9 import qualified Language.Haskell.LSP.Types as L
  10 import Hedgehog
  11 import qualified Hedgehog.Gen as Gen
  12 import qualified Hedgehog.Range as Range
  13 import Control.Monad.IO.Class
  14 import Control.Monad.Trans.Class
  15 import Debug.Trace
  16
  17 data ModelState (v :: * -> *) = TDocClose | TDocOpen | TDocWaited
  18   deriving (Eq, Ord, Show)
  19
  20 data OpenDoc (v :: * -> *) = OpenDoc
  21   deriving (Eq, Show)
  22
  23 instance HTraversable OpenDoc where
  24   htraverse _ OpenDoc = pure OpenDoc
  25
  26 s_openDoc_init :: (Monad n) => Command n PropertySession ModelState
  27 s_openDoc_init =
  28   let gen TDocClose = Just $ pure OpenDoc
  29       gen _      = Nothing
  30       execute OpenDoc = openDoc "Format.hs" "haskell"
  31   in Command gen execute [
  32       Require $ \s OpenDoc -> s == TDocClose
  33     , Update $ \_s OpenDoc o -> TDocOpen
  34     , Ensure $ \before after OpenDoc o -> do
  35         before === TDocClose
  36         let L.TextDocumentIdentifier uri = o
  37         uri === L.Uri "file:///Users/luke/Source/haskell-lsp-test/test/data/Format.hs"
  38         after === TDocOpen
  39     ]
  40
  41 data WaitDiags (v :: * -> *) = WaitDiags
  42   deriving (Eq, Show)
  43
  44 instance HTraversable WaitDiags where
  45   htraverse _ WaitDiags = pure WaitDiags
  46
  47 s_diagnostics :: Monad n => Command n PropertySession ModelState
  48 s_diagnostics =
  49   let gen TDocOpen = Just $ pure WaitDiags
  50       gen _        = Nothing
  51       execute WaitDiags = waitForDiagnostics
  52   in Command gen execute [
  53       Require $ \s WaitDiags -> s == TDocOpen
  54     , Update $ \s WaitDiags o -> TDocWaited
  55     , Ensure $ \before after WaitDiags o -> o === []
  56     ]
  57
  58 data CloseDoc (v :: * -> *) = CloseDoc
  59   deriving (Eq, Show)
  60
  61 instance HTraversable CloseDoc where
  62   htraverse _ CloseDoc = pure CloseDoc
  63
  64 s_closeDoc :: Monad n => Command n PropertySession ModelState
  65 s_closeDoc =
  66   let gen TDocOpen   = Just $ pure CloseDoc
  67       gen TDocWaited = Just $ pure CloseDoc
  68       gen _        = Nothing
  69       execute CloseDoc = closeDoc (L.TextDocumentIdentifier (L.Uri "file:///Users/luke/Source/haskell-lsp-test/test/data/Format.hs"))
  70   in Command gen execute [
  71       Require $ \s CloseDoc -> s == TDocOpen || s == TDocWaited
  72     , Update $ \_s CloseDoc o -> TDocClose
  73     ]
  74
  75 type PropertySession = SessionT (PropertyT IO)
  76
  77 instance MonadThrow m => MonadCatch (SessionT m) where
  78   catch f h = f
  79
  80 instance MonadTest PropertySession where
  81   liftTest = lift . liftTest
  82
  83 initialState :: ModelState v
  84 initialState = TDocClose
  85
  86 prop_doc :: Property
  87 prop_doc = property $ do
  88   actions <- forAll $
  89     Gen.sequential (Range.constant 1 100) initialState
  90       [ s_openDoc_init
  91       , s_diagnostics
  92       , s_closeDoc
  93       ]
  94   runSessionWithConfig (def { logMessages = True }) "hie --lsp" def "test/data" $
  95     executeSequential initialState actions
  96