From 7e9728f0e934637786dfc80fac8128991a3ea35c Mon Sep 17 00:00:00 2001 From: Frederik Ramcke Date: Fri, 19 Jul 2019 17:24:11 +0000 Subject: [PATCH] dhall-lsp-server: Freezing imports (#1123) * Implement dhall.freezeImport and dhall.freezeAllImports * Remove old (broken) test suite * Rename `relativePosition` to `subtractPosition` as suggested by @Gabriel439 * Add doctest for `subtractPosition` as suggested by @Gabriel439 * Simplify getImportHashPosition As spotted by @Gabriel439 * Use `forM` instead of `mapM` for prettier code As suggested by @Gabriel439 --- dhall-lsp-server/dhall-lsp-server.cabal | 60 +++------ dhall-lsp-server/doctest/Main.hs | 24 ++++ .../src/Dhall/LSP/Backend/Dhall.hs | 10 ++ .../src/Dhall/LSP/Backend/Diagnostics.hs | 13 +- .../src/Dhall/LSP/Backend/Freezing.hs | 57 ++++++++ .../src/Dhall/LSP/Backend/Parsing.hs | 17 ++- dhall-lsp-server/src/Dhall/LSP/Handlers.hs | 77 ++++++++++- dhall-lsp-server/src/Dhall/LSP/Server.hs | 4 +- .../test/Backend/Dhall/DiagnosticsSpec.hs | 127 ------------------ dhall-lsp-server/test/Driver.hs | 1 - dhall/src/Dhall/Parser/Expression.hs | 25 ++-- 11 files changed, 226 insertions(+), 189 deletions(-) create mode 100644 dhall-lsp-server/doctest/Main.hs create mode 100644 dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs delete mode 100644 dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs delete mode 100644 dhall-lsp-server/test/Driver.hs diff --git a/dhall-lsp-server/dhall-lsp-server.cabal b/dhall-lsp-server/dhall-lsp-server.cabal index e7e5038..8d6f012 100644 --- a/dhall-lsp-server/dhall-lsp-server.cabal +++ b/dhall-lsp-server/dhall-lsp-server.cabal @@ -22,6 +22,7 @@ library exposed-modules: Dhall.LSP.Backend.Dhall Dhall.LSP.Backend.Diagnostics + Dhall.LSP.Backend.Freezing Dhall.LSP.Backend.Formatting Dhall.LSP.Backend.Linting Dhall.LSP.Backend.Parsing @@ -105,45 +106,20 @@ executable dhall-lsp-server if impl(eta) buildable: False -test-suite dhall-lsp-server-test - type: exitcode-stdio-1.0 - main-is: Driver.hs - other-modules: - Paths_dhall_lsp_server - Backend.Dhall.DiagnosticsSpec - - hs-source-dirs: - test - default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - build-tool-depends: - tasty-discover:tasty-discover - build-depends: - aeson - , base >=4.7 && <5 - , containers - , data-default - , dhall - , dhall-lsp-server - , filepath - , haskell-lsp - , hslogger - , lens - , lens-family-core - , megaparsec - , mtl - , optparse-applicative - , prettyprinter - , sorted-list - , stm - , tasty - , tasty-discover - , tasty-hspec - , tasty-quickcheck - , text - , transformers - , unordered-containers - , yi-rope - default-language: Haskell2010 - if impl(eta) - buildable: False +Test-Suite doctest + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: doctest + Main-Is: Main.hs + GHC-Options: -Wall + Build-Depends: + base , + directory , + filepath < 1.5 , + doctest >= 0.7.0 && < 0.17 + Other-Extensions: OverloadedStrings RecordWildCards + Default-Language: Haskell2010 + -- `doctest` doesn't work with `MIN_VERSION` macros before GHC 8 + -- + -- See: https://ghc.haskell.org/trac/ghc/ticket/10970 + if impl(ghc < 8.0) + Buildable: False diff --git a/dhall-lsp-server/doctest/Main.hs b/dhall-lsp-server/doctest/Main.hs new file mode 100644 index 0000000..c778ed2 --- /dev/null +++ b/dhall-lsp-server/doctest/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import Data.Monoid ((<>)) +import System.FilePath (()) + +import qualified GHC.IO.Encoding +import qualified System.Directory +import qualified System.IO +import qualified Test.DocTest + +main :: IO () +main = do + + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + pwd <- System.Directory.getCurrentDirectory + prefix <- System.Directory.makeAbsolute pwd + + Test.DocTest.doctest + [ "--fast" + , "-XOverloadedStrings" + , "-XRecordWildCards" + , "-i" <> (prefix "src") + , prefix "src/Dhall/LSP/Backend/Diagnostics.hs" + ] diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs index 0c9f573..0c4772c 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs @@ -2,6 +2,7 @@ module Dhall.LSP.Backend.Dhall ( FileIdentifier, fileIdentifierFromFilePath, fileIdentifierFromURI, + hashNormalToCode, WellTyped, fromWellTyped, Normal, @@ -21,6 +22,7 @@ import Dhall.Parser (Src) import Dhall.TypeCheck (X) import Dhall.Core (Expr) +import qualified Dhall.Binary as Dhall import qualified Dhall.Core as Dhall import qualified Dhall.Import as Dhall import qualified Dhall.Parser as Dhall @@ -158,3 +160,11 @@ typecheck expr = case Dhall.typeOf expr of -- | Normalise a well-typed expression. normalize :: WellTyped -> Normal normalize (WellTyped expr) = Normal $ Dhall.normalize expr + +-- | Given a normal expression compute the hash (using the default standard +-- version) of its alpha-normal form. Returns the hash in the format used in +-- Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded). +hashNormalToCode :: Normal -> Text +hashNormalToCode (Normal expr) = + Dhall.hashExpressionToCode Dhall.defaultStandardVersion alphaNormal + where alphaNormal = Dhall.alphaNormalize expr diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs index 1da5549..ae8c7f3 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs @@ -12,6 +12,7 @@ module Dhall.LSP.Backend.Diagnostics , positionToOffset , Range(..) , rangeFromDhall + , subtractPosition ) where @@ -119,6 +120,15 @@ positionToMegaparsec (line, col) = Megaparsec.SourcePos "" (Megaparsec.mkPos $ max 0 line + 1) (Megaparsec.mkPos $ max 0 col + 1) +addRelativePosition :: Position -> Position -> Position +addRelativePosition (x1, y1) (0, dy2) = (x1, y1 + dy2) +addRelativePosition (x1, _) (dx2, y2) = (x1 + dx2, y2) + +-- | prop> addRelativePosition pos (subtractPosition pos pos') == pos' +subtractPosition :: Position -> Position -> Position +subtractPosition (x1, y1) (x2, y2) | x1 == x2 = (0, y2 - y1) + | otherwise = (x2 - x1, y2) + -- | Convert a source range from Dhalls @Src@ format. The returned range is -- "tight", that is, does not contain any trailing whitespace. rangeFromDhall :: Src -> Range @@ -126,8 +136,7 @@ rangeFromDhall (Src left _right text) = Range (x1,y1) (x2,y2) where (x1,y1) = positionFromMegaparsec left (dx2,dy2) = offsetToPosition text . Text.length $ Text.stripEnd text - (x2,y2) | dx2 == 0 = (x1, y1 + dy2) - | otherwise = (x1 + dx2, dy2) + (x2,y2) = addRelativePosition (x1,y1) (dx2,dy2) -- Convert a (line,column) position into the corresponding character offset -- and back, such that the two are inverses of eachother. diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs new file mode 100644 index 0000000..29cbb07 --- /dev/null +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs @@ -0,0 +1,57 @@ +module Dhall.LSP.Backend.Freezing ( + computeSemanticHash, + getAllImportsWithHashPositions, + getImportHashPosition, + stripHash +) where + +import Dhall.Parser (Src(..)) +import Dhall.Core (Expr(..), Import(..), ImportHashed(..), subExpressions) + +import Control.Lens (universeOf) +import Data.Text (Text) +import qualified Data.Text as Text + +import Dhall.LSP.Backend.Dhall (FileIdentifier, Cache, DhallError, typecheck, + normalize, hashNormalToCode, load) +import Dhall.LSP.Backend.Diagnostics (Range(..), rangeFromDhall, + positionFromMegaparsec, positionToOffset, subtractPosition) +import Dhall.LSP.Backend.Parsing (getImportHash) + +-- | Given an expression (potentially still containing imports) compute its +-- 'semantic' hash in the textual representation used to freeze Dhall imports. +computeSemanticHash :: FileIdentifier -> Expr Src Import -> Cache -> + IO (Either DhallError (Cache, Text)) +computeSemanticHash fileid expr cache = do + loaded <- load fileid expr cache + case loaded of + Left err -> return (Left err) + Right (cache', expr') -> case typecheck expr' of + Left err -> return (Left err) + Right (wt,_) -> do + return (Right (cache', hashNormalToCode (normalize wt))) + +stripHash :: Import -> Import +stripHash (Import (ImportHashed _ importType) mode) = + Import (ImportHashed Nothing importType) mode + +getImportHashPosition :: Src -> Maybe Range +getImportHashPosition src@(Src left _ text) = do + Src left' right' _ <- getImportHash src + let p0 = positionFromMegaparsec left + + -- sanitise the starting point + let p1 = positionFromMegaparsec left' + off1 = positionToOffset text (subtractPosition p0 p1) + Range _ left'' = rangeFromDhall (Src left left' (Text.take off1 text)) + + -- sanitise the end point + let Range _ right'' = rangeFromDhall (Src left right' text) + + return (Range left'' right'') + +getAllImportsWithHashPositions :: Expr Src Import -> [(Import, Range)] +getAllImportsWithHashPositions expr = + [ (i, range) | + Note src (Embed i) <- universeOf subExpressions expr, + Just range <- [getImportHashPosition src] ] diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs index e7e1b76..23d19f5 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs @@ -1,5 +1,6 @@ module Dhall.LSP.Backend.Parsing - ( getLetInner + ( getImportHash + , getLetInner , getLetAnnot , getLetIdentifier , getLamIdentifier @@ -102,6 +103,20 @@ getForallIdentifier src@(Src left _ text) = _ <- Megaparsec.takeRest return (Src begin end tokens) +-- | Given an Src of a import expression return the Src containing the hash +-- annotation. If the import does not have a hash annotation return a 0-length +-- Src where we can insert one. +getImportHash :: Src -> Maybe Src +getImportHash (Src left _ text) = + Megaparsec.parseMaybe (unParser parseImportHashPosition) text + where parseImportHashPosition = do + setSourcePos left + _ <- importType_ + begin <- getSourcePos + (tokens, _) <- Megaparsec.match $ optional importHash_ + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) setSourcePos :: SourcePos -> Parser () setSourcePos src = Megaparsec.updateParserState diff --git a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs index 592abcb..d4becc0 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs @@ -8,7 +8,7 @@ import qualified Language.Haskell.LSP.VFS as LSP import qualified Data.Aeson as J import qualified Yi.Rope as Rope -import Dhall.Core (Expr, pretty, Import(..), ImportHashed(..), ImportType(..), headers) +import Dhall.Core (Expr(Note, Embed), pretty, Import(..), ImportHashed(..), ImportType(..), headers) import Dhall.Import (localToPath) import Dhall.Parser (Src(..)) import Dhall.TypeCheck (X) @@ -18,14 +18,16 @@ import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck, import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain, rangeFromDhall, diagnose, embedsWithRanges) import Dhall.LSP.Backend.Formatting (formatExprWithHeader) +import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition, + stripHash, getAllImportsWithHashPositions) import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint) -import Dhall.LSP.Backend.Typing (typeAt, annotateLet) +import Dhall.LSP.Backend.Typing (typeAt, annotateLet, exprAt) import Dhall.LSP.State import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Control.Lens ((^.), use, uses, assign, modifying) -import Control.Monad (guard) +import Control.Monad (guard, forM) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Except (throwE, catchE, runExceptT) import Control.Monad.Trans.State.Strict (execStateT) @@ -297,6 +299,8 @@ executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM () executeCommandHandler request | command == "dhall.server.lint" = executeLintAndFormat request | command == "dhall.server.annotateLet" = executeAnnotateLet request + | command == "dhall.server.freezeImport" = executeFreezeImport request + | command == "dhall.server.freezeAllImports" = executeFreezeAllImports request | otherwise = throwE (Warning, "Command '" <> command <> "' not known; ignored.") where command = request ^. J.params . J.command @@ -358,6 +362,73 @@ executeAnnotateLet request = do (J.ApplyWorkspaceEditParams edit) +executeFreezeAllImports :: J.ExecuteCommandRequest -> HandlerM () +executeFreezeAllImports request = do + uri <- getCommandArguments request + + fileIdentifier <- fileIdentifierFromUri uri + txt <- readUri uri + expr <- case parse txt of + Right e -> return e + Left _ -> throwE (Warning, "Could not freeze imports; did not parse.") + + let importRanges = getAllImportsWithHashPositions expr + edits <- forM importRanges $ \(import_, Range (x1, y1) (x2, y2)) -> do + cache <- use importCache + let importExpr = Embed (stripHash import_) + + hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + (cache', hash) <- case hashResult of + Right (c, t) -> return (c, t) + Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") + assign importCache cache' + + let range = J.Range (J.Position x1 y1) (J.Position x2 y2) + return (J.TextEdit range (" " <> hash)) + + let workspaceEdit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List edits))) Nothing + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams workspaceEdit) + + +executeFreezeImport :: J.ExecuteCommandRequest -> HandlerM () +executeFreezeImport request = do + args :: J.TextDocumentPositionParams <- getCommandArguments request + let uri = args ^. J.textDocument . J.uri + line = args ^. J.position . J.line + col = args ^. J.position . J.character + + txt <- readUri uri + expr <- case parse txt of + Right e -> return e + Left _ -> throwE (Warning, "Could not freeze import; did not parse.") + + (src, import_) + <- case exprAt (line, col) expr of + Just (Note src (Embed i)) -> return (src, i) + _ -> throwE (Warning, "You weren't pointing at an import!") + + Range (x1, y1) (x2, y2) <- case getImportHashPosition src of + Just range -> return range + Nothing -> throwE (Error, "Failed to re-parse import!") + + fileIdentifier <- fileIdentifierFromUri uri + cache <- use importCache + let importExpr = Embed (stripHash import_) + + hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + (cache', hash) <- case hashResult of + Right (c, t) -> return (c, t) + Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") + assign importCache cache' + + let range = J.Range (J.Position x1 y1) (J.Position x2 y2) + edit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List [J.TextEdit range (" " <> hash)]))) Nothing + + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams edit) -- handler that doesn't do anything. Useful for example to make haskell-lsp shut diff --git a/dhall-lsp-server/src/Dhall/LSP/Server.hs b/dhall-lsp-server/src/Dhall/LSP/Server.hs index 75f8e6f..2eeff0d 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Server.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Server.hs @@ -72,7 +72,9 @@ lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions -- around this peculiarity. Just (J.ExecuteCommandOptions (J.List ["dhall.server.lint", - "dhall.server.annotateLet"])) + "dhall.server.annotateLet", + "dhall.server.freezeImport", + "dhall.server.freezeAllImports"])) , LSP.Core.documentLinkProvider = Just (J.DocumentLinkOptions { _resolveProvider = Just False }) } diff --git a/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs b/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs deleted file mode 100644 index e542c6e..0000000 --- a/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -module Backend.Dhall.DiagnosticsSpec where - -import Test.Tasty.Hspec - - -import Language.Haskell.LSP.Types( - Diagnostic(..) - , Range(..) - , DiagnosticSeverity(..) - , Position(..) - ) - -import Data.Foldable (traverse_) -import Dhall.LSP.Handlers.Diagnostics (compilerDiagnostics) - -import qualified Data.Text -import qualified Data.Text.IO - -import qualified GHC.IO.Encoding -import qualified System.IO - - -spec_prelude :: Spec -spec_prelude = do - - runIO $ GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 - - describe "Backend.Dhall.Diagnostics" $ do - - it "should produce an empty diagnostics for an empty file" $ do - rs <- compilerDiagnostics "./empty.txt" "" - rs `shouldBe` ([]) - - it "should produce an empty diagnostics for a correct file (sanity check)" $ do - traverse_ (\x -> x `shouldReturn` []) (getDiagnostics <$> successImports) - - it "should produce correct diagnostics for various missing imports" $ do - getDiagnostics "../dhall/dhall-lang/tests/import/failure/missing.dhall" `shouldReturn` - (mkDiagnostics "\nError: No valid imports" (0,0) (1,0)) - getDiagnostics "../dhall/dhall-lang/tests/import/failure/alternativeEnv.dhall" `shouldReturn` - (mkDiagnostics ("\nError: Failed to resolve imports. Error list:\n\n\n\8627 env:UNSET1 as Text\n\n" <> - "Error: Missing environment variable\n\n\8627 UNSET1\n\n\n\8627 env:UNSET2\n\n" <> - "Error: Missing environment variable\n\n\8627 UNSET2\n\n\n\8627 env:UNSET3\n\n" <> - "Error: Missing environment variable\n\n\8627 UNSET3\n") (0,0) (1,0)) - getDiagnostics "../dhall/dhall-lang/tests/import/failure/alternativeEnvMissing.dhall" `shouldReturn` - (mkDiagnostics "\n\8627 env:UNSET\n\nError: Missing environment variable\n\n\8627 UNSET" (0,0) (1,0)) - getDiagnostics "../dhall/dhall-lang/tests/import/failure/cycle.dhall" `shouldReturn` - (mkDiagnostics ("\n\8627 ./../dhall/dhall-lang/tests/import/data/cycle.dhall\n" <> - " \8627 ./../dhall/dhall-lang/tests/import/failure/cycle.dhall\n\n" <> - "Cyclic import: ../data/cycle.dhall") (0,0) (1,0)) - getDiagnostics "../dhall/dhall-lang/tests/import/failure/referentiallyInsane.dhall" `shouldReturn` - (mkDiagnostics ("\n\8627 https://raw.githubusercontent.com/dhall-lang/dhall-lang/master" <> - "/tests/import/data/referentiallyOpaque.dhall\n\n" <> - "Referentially opaque import: env:HOME as Text") (19,0) (20,0)) - - it "should produce correct diagnostic for various parser errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/boundBuiltins.dhall" `shouldReturn` - (mkDiagnostics "expecting label or whitespace\n" (5,8) (5,9)) - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/doubleBoundsNeg.dhall" `shouldReturn` - (mkDiagnostics "double out of bounds\n" (0,0) (0,1)) - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/doubleBoundsPos.dhall" `shouldReturn` - (mkDiagnostics "double out of bounds\n" (0,0) (0,1)) - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/importAccess.dhall" `shouldReturn` - (mkDiagnostics ("unexpected '.'\nexpecting \"!=\", \"&&\", \"++\", \"->\", \"//\", \"//\\\\\", " <> - "\"/\\\", \"==\", \"as\", \"sha256:\", \"||\", \"\8594\", \"\8743\", \"\10835\", " <> - "\"\11005\", '#', '*', '+', ':', '?', end of input, or whitespace\n") (0,13) (0,14)) - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/incompleteIf.dhall" `shouldReturn` - (mkDiagnostics "unexpected end of input\nexpecting expression or whitespace\n" (10,0) (10,1)) - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/mandatoryNewline.dhall" `shouldReturn` - (mkDiagnostics "unexpected \"AB\"\nexpecting crlf newline or newline\n" (1,2) (1,4)) - - {-- - getDiagnostics "../dhall/dhall-lang/tests/parser/failure/missingSpace.dhall" `shouldReturn` - (mkDiagnostics ("\n\8627 ./../dhall/dhall-lang/tests/parser/failure/example.dhall\n\n" <> - "Error: Missing file /Users/edevi86/lab/haskell/dhall-haskell/dhall-l" <> - "sp-server/../dhall/dhall-lang/tests/parser/failure/example.dhall") (1,0) (1,15)) - --} - it "should produce correct diagnostic for various typecheck errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/combineMixedRecords.dhall" `shouldReturn` - (mkDiagnostics "Record mismatch" (0,0) (1,0)) - it "should produce correct diagnostic for various typecheck errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/duplicateFields.dhall" `shouldReturn` - (mkDiagnostics "duplicate field: a\n" (0,15) (0,16)) - it "should produce correct diagnostic for various typecheck errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/hurkensParadox.dhall" `shouldReturn` - (mkDiagnostics "\10096Sort\10097 has no type, kind, or sort" (6,4) (49,0)) - it "should produce correct diagnostic for various typecheck errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/mixedUnions.dhall" `shouldReturn` - (mkDiagnostics "Alternative annotation mismatch" (0,0) (1,0)) - it "should produce correct diagnostic for various typecheck errors" $ do - getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/preferMixedRecords.dhall" `shouldReturn` - (mkDiagnostics "Record mismatch" (0,0) (1,0)) - - -getDiagnostics :: FilePath -> IO [Diagnostic] -getDiagnostics path = do - text <- Data.Text.IO.readFile path - compilerDiagnostics path text - -successImports :: [String] -successImports = [ "../dhall/dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall" - , "../dhall/dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall" - , "../dhall/dhall-lang/tests/import/success/alternativeNaturalA.dhall" - , "../dhall/dhall-lang/tests/import/success/asTextA.dhall" - , "../dhall/dhall-lang/tests/import/success/fieldOrderA.dhall" - , "../dhall/dhall-lang/tests/import/success/alternativeEnvNaturalB.dhall" - , "../dhall/dhall-lang/tests/import/success/alternativeEnvSimpleB.dhall" - , "../dhall/dhall-lang/tests/import/success/alternativeNaturalB.dhall" - , "../dhall/dhall-lang/tests/import/success/asTextB.dhall" - , "../dhall/dhall-lang/tests/import/success/fieldOrderB.dhall"] - -mkDiagnostics :: Data.Text.Text - -> (Int, Int) - -> (Int, Int) - -> [Diagnostic] -mkDiagnostics msg (sl, sc) (el, ec) = [ - Diagnostic { - _range = Range { - _start = Position {_line = sl, _character = sc} - , _end = Position {_line = el, _character = ec} - } - , _severity = Just DsError - , _code = Nothing - , _source = Just "dhall-lsp-server" - , _message = msg - , _relatedInformation = Nothing - }] diff --git a/dhall-lsp-server/test/Driver.hs b/dhall-lsp-server/test/Driver.hs deleted file mode 100644 index d67ec9a..0000000 --- a/dhall-lsp-server/test/Driver.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} \ No newline at end of file diff --git a/dhall/src/Dhall/Parser/Expression.hs b/dhall/src/Dhall/Parser/Expression.hs index 166a6ff..3504eb4 100644 --- a/dhall/src/Dhall/Parser/Expression.hs +++ b/dhall/src/Dhall/Parser/Expression.hs @@ -757,23 +757,24 @@ importType_ = do choice [ local, http, env, missing ] +importHash_ :: Parser (Crypto.Hash.Digest Crypto.Hash.SHA256) +importHash_ = do + _ <- Text.Parser.Char.text "sha256:" + text <- count 64 (satisfy hexdig "hex digit") + whitespace + let strictBytes16 = Data.Text.Encoding.encodeUtf8 text + strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of + Left string -> fail string + Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) + case Crypto.Hash.digestFromByteString strictBytes of + Nothing -> fail "Invalid sha256 hash" + Just h -> pure h + importHashed_ :: Parser ImportHashed importHashed_ = do importType <- importType_ hash <- optional importHash_ return (ImportHashed {..}) - where - importHash_ = do - _ <- Text.Parser.Char.text "sha256:" - text <- count 64 (satisfy hexdig "hex digit") - whitespace - let strictBytes16 = Data.Text.Encoding.encodeUtf8 text - strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of - Left string -> fail string - Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) - case Crypto.Hash.digestFromByteString strictBytes of - Nothing -> fail "Invalid sha256 hash" - Just h -> pure h import_ :: Parser Import import_ = (do