dhall 1.19.0 → 1.19.1

raw patch · 11 files changed

+280/−33 lines, 11 filesdep +dotgendep +http-typesdep ~tastyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dotgen, http-types

Dependency ranges changed: tasty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• dhall.cabal +5/−1
• src/Dhall/Import.hs +44/−12
• src/Dhall/Import/HTTP.hs +29/−10
• src/Dhall/Import/Types.hs +32/−4
• src/Dhall/Lint.hs +1/−1
• src/Dhall/Main.hs +19/−5
• tests/Lint.hs +58/−0
• tests/Tests.hs +2/−0
• tests/lint/success/multiletA.dhall +35/−0
• tests/lint/success/multiletB.dhall +35/−0

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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'

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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