diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +1.19.1 + + +* BUG FIX: Fix serious `dhall lint` bug + * `dhall lint` would sometimes remove `let` expressions that were still + in use + * See: https://github.com/dhall-lang/dhall-haskell/pull/703 +* BUG FIX: Fix import caching efficiency bug + * Some imports were being wastefully fetched multiple times + * See: https://github.com/dhall-lang/dhall-haskell/pull/702 +* Feature: Generate dot graph to visualize import graph + * Use the `dhall resolve --dot` command + * See: https://github.com/dhall-lang/dhall-haskell/pull/698 + * See: https://github.com/dhall-lang/dhall-haskell/pull/713 +* Improve HTTP error messages + * See: https://github.com/dhall-lang/dhall-haskell/pull/710 + 1.19.0 * Supports version 4.0.0 of the language standard @@ -22,6 +39,9 @@ * This changes the `Let` constructor to now support storing multiple bindings per `let` expression * See: https://github.com/dhall-lang/dhall-haskell/pull/675 +* Access constructors as if they were fields of the union type + * In other words: `< Left : Bool | Right : Natural >.Left` + * See: https://github.com/dhall-lang/dhall-haskell/pull/657 * Support GHC 8.6 * See: https://github.com/dhall-lang/dhall-haskell/pull/669 * Add support for quoted path components diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.19.0 +Version: 1.19.1 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.0.1 @@ -33,6 +33,7 @@ tests/import/data/foo/bar/*.dhall tests/import/failure/*.dhall tests/import/success/*.dhall + tests/lint/success/*.dhall tests/normalization/success/*.dhall tests/normalization/success/haskell-tutorial/access/*.dhall tests/normalization/success/haskell-tutorial/combineTypes/*.dhall @@ -304,6 +305,7 @@ cryptonite >= 0.23 && < 1.0 , Diff >= 0.2 && < 0.4 , directory >= 1.2.2.0 && < 1.4 , + dotgen >= 0.4.2 && < 0.5 , exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , haskeline >= 0.7.2.1 && < 0.8 , @@ -326,6 +328,7 @@ vector >= 0.11.0.0 && < 0.13 if flag(with-http) Build-Depends: + http-types >= 0.7.0 && < 0.13, http-client >= 0.4.30 && < 0.6 , http-client-tls >= 0.2.0 && < 0.4 if !impl(ghc >= 8.0) @@ -383,6 +386,7 @@ Other-Modules: Format Import + Lint Normalization Parser QuickCheck diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -165,6 +165,7 @@ import Dhall.Import.HTTP #endif import Dhall.Import.Types +import Text.Dot ((.->.), userNodeId) import Dhall.Parser (Parser(..), ParseError(..), Src(..)) import Dhall.TypeCheck (X(..)) @@ -566,7 +567,7 @@ liftIO (Directory.setPermissions directory private) cacheDirectory <- getCacheDirectory - + assertDirectory cacheDirectory let dhallDirectory = cacheDirectory "dhall" @@ -732,8 +733,18 @@ then throwMissingImport (Imported imports (Cycle import_)) else do case Map.lookup here _cache of - Just expr -> return expr - Nothing -> do + Just (hereNode, expr) -> do + zoom dot . State.modify $ \getDot -> do + parentNode <- getDot + + -- Add edge between parent and here + parentNode .->. hereNode + + -- Return parent NodeId + pure parentNode + + pure expr + Nothing -> do -- Here we have to match and unwrap the @MissingImports@ -- in a separate handler, otherwise we'd have it wrapped -- in another @Imported@ when parsing a @missing@, because @@ -745,14 +756,15 @@ :: (MonadCatch m) => MissingImports -> StateT (Status m) m (Expr Src Import) - handler₀ e@(MissingImports []) = throwM e - handler₀ (MissingImports [e]) = - throwMissingImport (Imported imports' e) - handler₀ (MissingImports es) = throwM - (MissingImports - (fmap - (\e -> (toException (Imported imports' e))) - es)) + handler₀ (MissingImports es) = + throwM + (MissingImports + (map + (\e -> toException (Imported imports' e)) + es + ) + ) + handler₁ :: (MonadCatch m) => SomeException @@ -766,10 +778,30 @@ expr' <- loadDynamic `catches` [ Handler handler₀, Handler handler₁ ] + let hereNodeId = userNodeId _nextNodeId + + -- Increment the next node id + zoom nextNodeId $ State.modify succ + + -- Make current node the dot graph + zoom dot . State.put $ importNode hereNodeId here + zoom stack (State.put imports') expr'' <- loadWith expr' zoom stack (State.put imports) + zoom dot . State.modify $ \getSubDot -> do + parentNode <- _dot + + -- Get current node back from sub-graph + hereNode <- getSubDot + + -- Add edge between parent and here + parentNode .->. hereNode + + -- Return parent NodeId + pure parentNode + _cacher here expr'' -- Type-check expressions here for three separate reasons: @@ -785,7 +817,7 @@ expr''' <- case Dhall.TypeCheck.typeWith _startingContext expr'' of Left err -> throwM (Imported imports' err) Right _ -> return (Dhall.Core.normalizeWith (getReifiedNormalizer _normalizer) expr'') - zoom cache (State.put $! Map.insert here expr''' _cache) + zoom cache (State.modify' (Map.insert here (hereNodeId, expr'''))) return expr''' case hash (importHashed import_) of diff --git a/src/Dhall/Import/HTTP.hs b/src/Dhall/Import/HTTP.hs --- a/src/Dhall/Import/HTTP.hs +++ b/src/Dhall/Import/HTTP.hs @@ -4,7 +4,6 @@ module Dhall.Import.HTTP where -import Control.Exception (throwIO) import Control.Monad (join) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State.Strict (StateT) @@ -14,6 +13,7 @@ import Data.Semigroup ((<>)) import Lens.Family.State.Strict (zoom) +import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Text as Text import qualified Data.Text.Lazy @@ -30,6 +30,7 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP +import qualified Network.HTTP.Types.Status mkPrettyHttpException :: HttpException -> PrettyHttpException mkPrettyHttpException ex = @@ -44,18 +45,30 @@ <> "↳ " <> show r renderPrettyHttpException (HttpExceptionRequest _ e) = case e of - ConnectionFailure e' -> + ConnectionFailure _ -> "\n" - <> "\ESC[1;31mError\ESC[0m: Wrong host\n" - <> "\n" - <> "↳ " <> show e' + <> "\ESC[1;31mError\ESC[0m: Remote host not found\n" InvalidDestinationHost host -> "\n" - <> "\ESC[1;31mError\ESC[0m: Invalid host name\n" + <> "\ESC[1;31mError\ESC[0m: Invalid remote host name\n" <> "\n" - <> "↳ " <> show host + <> "↳ " <> show host <> "\n" ResponseTimeout -> - "\ESC[1;31mError\ESC[0m: The host took too long to respond\n" + "\n" + <> "\ESC[1;31mError\ESC[0m: The remote host took too long to respond\n" + StatusCodeException response _ + | statusCode == 404 -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Remote file not found\n" + | otherwise -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Unexpected HTTP status code:\n" + <> "\n" + <> "↳ " <> show statusCode <> "\n" + where + statusCode = + Network.HTTP.Types.Status.statusCode + (HTTP.responseStatus response) e' -> "\n" <> show e' #else renderPrettyHttpException e = case e of @@ -108,10 +121,16 @@ Nothing -> request Just headers -> request { HTTP.requestHeaders = headers } - response <- liftIO (HTTP.httpLbs requestWithHeaders m) + let io = HTTP.httpLbs requestWithHeaders m + let handler e = do + let _ = e :: HttpException + Control.Exception.throwIO (mkPrettyHttpException e) + + response <- liftIO (Control.Exception.handle handler io) + let bytes = HTTP.responseBody response case Data.Text.Lazy.Encoding.decodeUtf8' bytes of - Left err -> liftIO (throwIO err) + Left err -> liftIO (Control.Exception.throwIO err) Right text -> return (url, Data.Text.Lazy.toStrict text) diff --git a/src/Dhall/Import/Types.hs b/src/Dhall/Import/Types.hs --- a/src/Dhall/Import/Types.hs +++ b/src/Dhall/Import/Types.hs @@ -22,11 +22,13 @@ , ImportMode (..) , ImportType (..) , ReifiedNormalizer(..) + , pretty ) import Dhall.Parser (Src) import Dhall.TypeCheck (X) import Lens.Family (LensLike') import System.FilePath (isRelative, splitDirectories) +import Text.Dot (Dot, NodeId, userNode, userNodeId) import qualified Dhall.Binary import qualified Dhall.Context @@ -39,10 +41,16 @@ -- ^ Stack of `Import`s that we've imported along the way to get to the -- current point - , _cache :: Map Import (Expr Src X) - -- ^ Cache of imported expressions in order to avoid importing the same - -- expression twice with different values + , _dot :: Dot NodeId + -- ^ Graph of all the imports visited so far + , _nextNodeId :: Int + -- ^ Next node id to be used for the dot graph generation + + , _cache :: Map Import (NodeId, Expr Src X) + -- ^ Cache of imported expressions with their node id in order to avoid + -- importing the same expression twice with different values + , _manager :: Maybe Dynamic -- ^ Cache for the HTTP `Manager` so that we only acquire it once @@ -67,6 +75,10 @@ where _stack = pure rootImport + _dot = importNode (userNodeId 0) rootImport + + _nextNodeId = 1 + _cache = Map.empty _manager = Nothing @@ -94,10 +106,26 @@ , importMode = Code } +importNode :: NodeId -> Import -> Dot NodeId +importNode nodeId i = do + userNode + nodeId + [ ("label", Data.Text.unpack $ pretty i) + , ("shape", "box") + , ("style", "rounded") + ] + pure nodeId + stack :: Functor f => LensLike' f (Status m) (NonEmpty Import) stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) -cache :: Functor f => LensLike' f (Status m) (Map Import (Expr Src X)) +dot :: Functor f => LensLike' f (Status m) (Dot NodeId) +dot k s = fmap (\x -> s { _dot = x }) (k (_dot s)) + +nextNodeId :: Functor f => LensLike' f (Status m) Int +nextNodeId k s = fmap (\x -> s { _nextNodeId = x }) (k (_nextNodeId s)) + +cache :: Functor f => LensLike' f (Status m) (Map Import (NodeId, Expr Src X)) cache k s = fmap (\x -> s { _cache = x }) (k (_cache s)) manager :: Functor f => LensLike' f (Status m) (Maybe Dynamic) diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -55,7 +55,7 @@ d' = loop d loop (Let (Binding a b c :| (l : ls)) d) - | not (V a 0 `Dhall.Core.freeIn` d') = + | not (V a 0 `Dhall.Core.freeIn` Let (l' :| ls') d') = Let (l' :| ls') d' | otherwise = Let (Binding a b' c' :| (l' : ls')) d' diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -3,6 +3,7 @@ -} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -51,6 +52,7 @@ import qualified Dhall.Freeze import qualified Dhall.Hash import qualified Dhall.Import +import qualified Dhall.Import.Types import qualified Dhall.Lint import qualified Dhall.Parser import qualified Dhall.Pretty @@ -61,6 +63,7 @@ import qualified Paths_dhall as Meta import qualified System.Console.ANSI import qualified System.IO +import qualified Text.Dot -- | Top-level program options data Options = Options @@ -75,7 +78,7 @@ data Mode = Default { annotate :: Bool } | Version - | Resolve + | Resolve { dot :: Bool } | Type | Normalize | Repl @@ -125,7 +128,7 @@ <|> subcommand "resolve" "Resolve an expression's imports" - (pure Resolve) + (Resolve <$> parseDot) <|> subcommand "type" "Infer an expression's type" @@ -177,6 +180,13 @@ Options.Applicative.switch (Options.Applicative.long "annotate") + parseDot = + Options.Applicative.switch + ( Options.Applicative.long "dot" + <> Options.Applicative.help + "Output import dependency graph in dot format" + ) + parseInplace = Options.Applicative.strOption ( Options.Applicative.long "inplace" @@ -283,12 +293,16 @@ render System.IO.stdout annotatedExpression - Resolve -> do + Resolve dot -> do expression <- getExpression - resolvedExpression <- State.evalStateT (Dhall.Import.loadWith expression) status + (resolvedExpression, Dhall.Import.Types.Status { _dot }) <- + State.runStateT (Dhall.Import.loadWith expression) status - render System.IO.stdout resolvedExpression + if dot + then putStr . ("strict " <>) . Text.Dot.showDot $ + Text.Dot.attribute ("rankdir", "LR") >> _dot + else render System.IO.stdout resolvedExpression Normalize -> do expression <- getExpression diff --git a/tests/Lint.hs b/tests/Lint.hs new file mode 100644 --- /dev/null +++ b/tests/Lint.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Lint where + +import Data.Monoid (mempty, (<>)) +import Data.Text (Text) +import Test.Tasty (TestTree) + +import qualified Control.Exception +import qualified Data.Text +import qualified Data.Text.IO +import qualified Dhall.Core +import qualified Dhall.Import +import qualified Dhall.Lint +import qualified Dhall.Parser +import qualified Test.Tasty +import qualified Test.Tasty.HUnit + +lintTests :: TestTree +lintTests = + Test.Tasty.testGroup "format tests" + [ should + "correctly handle multi-let expressions" + "success/multilet" + ] + +should :: Text -> Text -> TestTree +should name basename = + Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do + let inputFile = + Data.Text.unpack ("./tests/lint/" <> basename <> "A.dhall") + let outputFile = + Data.Text.unpack ("./tests/lint/" <> basename <> "B.dhall") + + inputText <- Data.Text.IO.readFile inputFile + + parsedInput <- case Dhall.Parser.exprFromText mempty inputText of + Left exception -> Control.Exception.throwIO exception + Right expression -> return expression + + let lintedInput = Dhall.Lint.lint parsedInput + + actualExpression <- Dhall.Import.load lintedInput + + outputText <- Data.Text.IO.readFile outputFile + + parsedOutput <- case Dhall.Parser.exprFromText mempty outputText of + Left exception -> Control.Exception.throwIO exception + Right expression -> return expression + + resolvedOutput <- Dhall.Import.load parsedOutput + + let expectedExpression = Dhall.Core.denote resolvedOutput + + let message = + "The linted expression did not match the expected output" + + Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,5 +1,6 @@ module Main where +import Lint (lintTests) import Normalization (normalizationTests) import Parser (parserTests) import Regression (regressionTests) @@ -25,6 +26,7 @@ , typecheckTests , importTests , quickcheckTests + , lintTests ] main :: IO () diff --git a/tests/lint/success/multiletA.dhall b/tests/lint/success/multiletA.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/multiletA.dhall @@ -0,0 +1,35 @@ +-- example0.dhall + +let Person + : Type + = ∀(Person : Type) + → ∀(MakePerson : { children : List Person, name : Text } → Person) + → Person + +let example + : Person + = λ(Person : Type) + → λ(MakePerson : { children : List Person, name : Text } → Person) + → MakePerson + { children = + [ MakePerson { children = [] : List Person, name = "Mary" } + , MakePerson { children = [] : List Person, name = "Jane" } + ] + , name = + "John" + } + +let everybody + : Person → List Text + = let concat = http://prelude.dhall-lang.org/List/concat + + in λ(x : Person) + → x + (List Text) + ( λ(p : { children : List (List Text), name : Text }) + → [ p.name ] # concat Text p.children + ) + +let result : List Text = everybody example + +in result diff --git a/tests/lint/success/multiletB.dhall b/tests/lint/success/multiletB.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/multiletB.dhall @@ -0,0 +1,35 @@ +-- example0.dhall + +let Person + : Type + = ∀(Person : Type) + → ∀(MakePerson : { children : List Person, name : Text } → Person) + → Person + +let example + : Person + = λ(Person : Type) + → λ(MakePerson : { children : List Person, name : Text } → Person) + → MakePerson + { children = + [ MakePerson { children = [] : List Person, name = "Mary" } + , MakePerson { children = [] : List Person, name = "Jane" } + ] + , name = + "John" + } + +let everybody + : Person → List Text + = let concat = http://prelude.dhall-lang.org/List/concat + + in λ(x : Person) + → x + (List Text) + ( λ(p : { children : List (List Text), name : Text }) + → [ p.name ] # concat Text p.children + ) + +let result : List Text = everybody example + +in result