From ae334dce13ab47fd20b976a17b1f296e082c7531 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 6 Jul 2018 23:48:51 +0100 Subject: [PATCH] Move about internal and external modules --- haskell-lsp-test.cabal | 57 ++++++++++------- {src => lib}/Language/Haskell/LSP/Test.hs | 0 .../Language/Haskell/LSP/Test/Machine.hs | 0 .../Language/Haskell/LSP/Test/Replay.hs | 0 lsp-test/Main.hs | 62 ++++++++++++++++++ src/Language/Haskell/LSP/Test/Script.hs | 63 +------------------ 6 files changed, 97 insertions(+), 85 deletions(-) rename {src => lib}/Language/Haskell/LSP/Test.hs (100%) rename {src => lib}/Language/Haskell/LSP/Test/Machine.hs (100%) rename {src => lib}/Language/Haskell/LSP/Test/Replay.hs (100%) create mode 100644 lsp-test/Main.hs diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index f724796..7deb60e 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -10,55 +10,46 @@ maintainer: luke_lau@icloud.com copyright: 2018 Luke Lau category: Testing build-type: Simple -cabal-version: >=1.10 +cabal-version: >=2.0 extra-source-files: README.md library - hs-source-dirs: src + hs-source-dirs: lib exposed-modules: Language.Haskell.LSP.Test , Language.Haskell.LSP.Test.Replay + , Language.Haskell.LSP.Test.Machine default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , haskell-lsp-types , haskell-lsp >= 0.3 + , haskell-lsp-test-internal , aeson - , ansi-terminal - , async , bytestring - , conduit - , conduit-parse , containers , data-default , directory , filepath , lens - , mtl , parser-combinators - , process , text - , transformers , unordered-containers , yi-rope - if os(windows) - build-depends: Win32 - else - build-depends: unix - other-modules: Language.Haskell.LSP.Test.Compat + + ghc-options: -W + +library haskell-lsp-test-internal + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Language.Haskell.LSP.Test.Compat Language.Haskell.LSP.Test.Decoding Language.Haskell.LSP.Test.Exceptions Language.Haskell.LSP.Test.Files - Language.Haskell.LSP.Test.Machine Language.Haskell.LSP.Test.Messages Language.Haskell.LSP.Test.Parsing + Language.Haskell.LSP.Test.Script Language.Haskell.LSP.Test.Server Language.Haskell.LSP.Test.Session - ghc-options: -W - -executable lsp-test - hs-source-dirs: src - main-is: Language/Haskell/LSP/Test/Script.hs - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 + build-depends: base , haskell-lsp-types , haskell-lsp >= 0.3 , aeson @@ -73,17 +64,36 @@ executable lsp-test , filepath , lens , mtl + , scientific , parser-combinators , process , text , transformers , unordered-containers - , scientific , yi-rope if os(windows) build-depends: Win32 else build-depends: unix + ghc-options: -W + + +executable lsp-test + hs-source-dirs: lsp-test + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp-types + , haskell-lsp >= 0.3 + , haskell-lsp-test-internal + , haskell-lsp-test + , aeson + , bytestring + , directory + , filepath + , text + , unordered-containers + , scientific test-suite tests type: exitcode-stdio-1.0 @@ -96,6 +106,7 @@ test-suite tests , data-default , directory , haskell-lsp-test + , haskell-lsp-test-internal , haskell-lsp , haskell-lsp-types , conduit diff --git a/src/Language/Haskell/LSP/Test.hs b/lib/Language/Haskell/LSP/Test.hs similarity index 100% rename from src/Language/Haskell/LSP/Test.hs rename to lib/Language/Haskell/LSP/Test.hs diff --git a/src/Language/Haskell/LSP/Test/Machine.hs b/lib/Language/Haskell/LSP/Test/Machine.hs similarity index 100% rename from src/Language/Haskell/LSP/Test/Machine.hs rename to lib/Language/Haskell/LSP/Test/Machine.hs diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/lib/Language/Haskell/LSP/Test/Replay.hs similarity index 100% rename from src/Language/Haskell/LSP/Test/Replay.hs rename to lib/Language/Haskell/LSP/Test/Replay.hs diff --git a/lsp-test/Main.hs b/lsp-test/Main.hs new file mode 100644 index 0000000..6dc0690 --- /dev/null +++ b/lsp-test/Main.hs @@ -0,0 +1,62 @@ +module Main where + +import Control.Monad +import Data.Aeson +import qualified Data.Text as T +import qualified Data.HashMap.Lazy as HM +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Script +import System.Environment +import System.FilePath +import System.Directory +import Language.Haskell.LSP.Test.Machine +import Language.Haskell.LSP.Test.Parsing ( toJSONMsg ) +import Language.Haskell.LSP.Messages +import qualified Language.Haskell.LSP.Types as LSP + +main = do + fileName <- head <$> getArgs + blocks <- parseScript <$> readFile fileName + print blocks + rootDir <- getCurrentDirectory + runBlocks rootDir blocks + +runBlocks :: FilePath -> [Block] -> IO () +runBlocks rootDir blocks = runMachine rootDir (map convertBlock blocks) >>= putStrLn + where + convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()]) + convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions) + + mkWait :: Wait -> FromServerMessage -> Bool + mkWait WaitAny _ = True + mkWait (WaitPred preds) x = all (`mkPred` x) preds + + mkPred :: Predicate -> (FromServerMessage -> Bool) + mkPred (Predicate accessor comparison) msg = + let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison + + comp (Just (String str)) (EqualsString expected) = str == T.pack expected + comp (Just (Number num)) (EqualsNumber expected) = num == expected + comp _ _ = False + + access :: Object -> Accessor -> Maybe Value + access obj (AccessorTerm prop) = HM.lookup (T.pack prop) obj + access obj (Accessor prop next) = + case HM.lookup (T.pack prop) obj of + Just (Object nextObj) -> access nextObj next + _ -> Nothing + + mkAction :: Action -> Session () + + mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType + + mkAction (Request identifier methodStr ps) = void $ sendRequest' (strToMethod methodStr) (paramToValue ps) + mkAction (Reply methodStr ps) = undefined -- TODO + mkAction (Notify methodStr ps) = void $ sendNotification (strToMethod methodStr) (paramToValue ps) + + strToMethod str = case fromJSON (String $ T.pack str) of + Success x -> x + Error _ -> error $ str ++ " is not a valid method" + paramToValue (ParamString str) = String str + paramToValue (ParamUri uri) = toJSON $ LSP.filePathToUri (rootDir uri) + paramToValue (ParamObject obj) = Object (HM.map paramToValue obj) \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Script.hs b/src/Language/Haskell/LSP/Test/Script.hs index f9721b0..ce44664 100644 --- a/src/Language/Haskell/LSP/Test/Script.hs +++ b/src/Language/Haskell/LSP/Test/Script.hs @@ -1,25 +1,12 @@ -module Main where +module Language.Haskell.LSP.Test.Script where import Control.Applicative ( (<|>), some ) import Control.Monad -import Data.Aeson import Data.Char import qualified Data.Text as T import qualified Data.HashMap.Lazy as HM -import Data.Maybe import Data.Scientific import Text.ParserCombinators.ReadP -import System.Environment -import System.FilePath -import System.Directory -import Language.Haskell.LSP.Test (openDoc, sendRequest', sendNotification, sendResponse) -import Language.Haskell.LSP.Test.Session -import Language.Haskell.LSP.Test.Machine -import Language.Haskell.LSP.Test.Parsing (toJSONMsg) -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.TH.MessageFuncs -import qualified Language.Haskell.LSP.Types as LSP -import Debug.Trace data Block = Block String Wait [Action] deriving Show @@ -175,51 +162,3 @@ parseScript str = skipSpaces eof return blocks \ No newline at end of file - -main = do - fileName <- head <$> getArgs - blocks <- parseScript <$> readFile fileName - print blocks - rootDir <- getCurrentDirectory - runBlocks rootDir blocks - - -runBlocks :: FilePath -> [Block] -> IO () -runBlocks rootDir blocks = runMachine rootDir (map convertBlock blocks) >>= putStrLn - where - convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()]) - convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions) - - mkWait :: Wait -> FromServerMessage -> Bool - mkWait WaitAny _ = True - mkWait (WaitPred preds) x = all (`mkPred` x) preds - - mkPred :: Predicate -> (FromServerMessage -> Bool) - mkPred (Predicate accessor comparison) msg = - let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison - - comp (Just (String str)) (EqualsString expected) = str == T.pack expected - comp (Just (Number num)) (EqualsNumber expected) = num == expected - comp _ _ = False - - access :: Object -> Accessor -> Maybe Value - access obj (AccessorTerm prop) = traceShowId $ HM.lookup (T.pack prop) obj - access obj (Accessor prop next) = - case HM.lookup (T.pack prop) obj of - Just (Object nextObj) -> access nextObj next - _ -> Nothing - - mkAction :: Action -> Session () - - mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType - - mkAction (Request identifier methodStr ps) = void $ sendRequest' (strToMethod methodStr) (paramToValue ps) - mkAction (Reply methodStr ps) = undefined -- TODO - mkAction (Notify methodStr ps) = void $ sendNotification (strToMethod methodStr) (paramToValue ps) - - strToMethod str = case fromJSON (String $ T.pack str) of - Success x -> x - Error _ -> error $ str ++ " is not a valid method" - paramToValue (ParamString str) = String str - paramToValue (ParamUri uri) = toJSON $ LSP.filePathToUri (rootDir uri) - paramToValue (ParamObject obj) = Object (HM.map paramToValue obj) -- 2.30.2