Fix non-exhaustive pattern match in dhall lint

dhall/dhall.cabal

@@ -374,7 +374,7 @@ Library
       Other-Modules:
         Dhall.Import.HTTP
 
-    GHC-Options: -Wall
+    GHC-Options: -Wall -fwarn-incomplete-uni-patterns
     Default-Language: Haskell2010
 
 Executable dhall

dhall/src/Dhall.hs

@@ -12,6 +12,8 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE TupleSections              #-}
 
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
 {-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
     how to use the language, the compiler, and this library
 -}

dhall/src/Dhall/Core.hs

@@ -828,14 +828,15 @@ shift d (V x₀ n₀) (Let (Binding x₁ mA₀ a₀ :| []) b₀) =
 
     b₁  =       shift d (V x₀ n₁)   b₀
 shift d (V x₀ n₀) (Let (Binding x₁ mA₀ a₀ :| (l₀ : ls₀)) b₀) =
-    Let (Binding x₁ mA₁ a₁ :| (l₁ : ls₁)) b₁
+    case shift d (V x₀ n₁) (Let (l₀ :| ls₀) b₀) of
+        Let (l₁ :| ls₁) b₁ -> Let (Binding x₁ mA₁ a₁ :| (l₁ : ls₁)) b₁
+        e                  -> Let (Binding x₁ mA₁ a₁ :|       []  ) e
   where
     n₁ = if x₀ == x₁ then n₀ + 1 else n₀
 
     mA₁ = fmap (shift d (V x₀ n₀)) mA₀
     a₁  =       shift d (V x₀ n₀)   a₀
 
-    Let (l₁ :| ls₁) b₁ = shift d (V x₀ n₁) (Let (l₀ :| ls₀) b₀)
 shift d v (Annot a b) = Annot a' b'
   where
     a' = shift d v a
@@ -1005,7 +1006,9 @@ subst (V x₀ n₀) e₀ (Let (Binding x₁ mA₀ a₀ :| []) b₀) =
 
     b₁  =       subst (V x₀ n₁) e₁   b₀
 subst (V x₀ n₀) e₀ (Let (Binding x₁ mA₀ a₀ :| (l₀ : ls₀)) b₀) =
-    Let (Binding x₁ mA₁ a₁ :| (l₁ : ls₁)) b₁
+    case subst (V x₀ n₁) e₁ (Let (l₀ :| ls₀) b₀) of
+        Let (l₁ :| ls₁) b₁ -> Let (Binding x₁ mA₁ a₁ :| (l₁ : ls₁)) b₁
+        e                  -> Let (Binding x₁ mA₁ a₁ :|       []  ) e
   where
     n₁ = if x₀ == x₁ then n₀ + 1 else n₀
 
@@ -1014,7 +1017,6 @@ subst (V x₀ n₀) e₀ (Let (Binding x₁ mA₀ a₀ :| (l₀ : ls₀)) b₀)
     mA₁ = fmap (subst (V x₀ n₀) e₀) mA₀
     a₁  =       subst (V x₀ n₀) e₀   a₀
 
-    Let (l₁ :| ls₁) b₁ = subst (V x₀ n₁) e₁ (Let (l₀ :| ls₀) b₀)
 subst x e (Annot a b) = Annot a' b'
   where
     a' = subst x e a
@@ -1201,12 +1203,12 @@ alphaNormalize (Let (Binding "_" mA₀ a₀ :| []) b₀) =
 
     b₁  =      alphaNormalize b₀
 alphaNormalize (Let (Binding "_" mA₀ a₀ :| (l₀ : ls₀)) b₀) =
-    Let (Binding "_" mA₁ a₁ :| (l₁ : ls₁)) b₁
+    case alphaNormalize (Let (l₀ :| ls₀) b₀) of
+        Let (l₁ :| ls₁) b₁ -> Let (Binding "_" mA₁ a₁ :| (l₁ : ls₁)) b₁
+        e                  -> Let (Binding "_" mA₁ a₁ :|       []  ) e
   where
     mA₁ = fmap alphaNormalize mA₀
     a₁  =      alphaNormalize  a₀
-
-    Let (l₁ :| ls₁) b₁ = alphaNormalize (Let (l₀ :| ls₀) b₀)
 alphaNormalize (Let (Binding x mA₀ a₀ :| []) b₀) =
     Let (Binding "_" mA₁ a₁ :| []) b₄
   where
@@ -1218,16 +1220,16 @@ alphaNormalize (Let (Binding x mA₀ a₀ :| []) b₀) =
     b₃ = shift (-1) (V x 0) b₂
     b₄ = alphaNormalize b₃
 alphaNormalize (Let (Binding x mA₀ a₀ :| (l₀ : ls₀)) b₀) =
-    Let (Binding "_" mA₁ a₁ :| (l₁ : ls₁)) b₄
+    case alphaNormalize (Let (l₀ :| ls₀) b₃) of
+        Let (l₁ :| ls₁) b₄ -> Let (Binding "_" mA₁ a₁ :| (l₁ : ls₁)) b₄
+        e                  -> Let (Binding "_" mA₁ a₁ :|       []  ) e
   where
     mA₁ = fmap alphaNormalize mA₀
     a₁  =      alphaNormalize a₀
 
     b₁ = shift 1 (V "_" 0) b₀
     b₂ = subst (V x 0) (Var (V "_" 0)) b₁
     b₃ = shift (-1) (V x 0) b₂
-
-    Let (l₁ :| ls₁) b₄ = alphaNormalize (Let (l₀ :| ls₀) b₃)
 alphaNormalize (Annot t₀ _T₀) =
     Annot t₁ _T₁
   where

dhall/src/Dhall/Lint.hs

@@ -56,15 +56,17 @@ lint expression = loop (Dhall.Core.denote expression)
 
         d' = loop d
     loop (Let (Binding a b c :| (l : ls)) d)
-        | not (V a 0 `Dhall.Core.freeIn` Let (l' :| ls') d') =
-            Let (l' :| ls') d'
+        | not (V a 0 `Dhall.Core.freeIn` e) =
+            e
         | otherwise =
-            Let (Binding a b' c' :| (l' : ls'))  d'
+            case e of
+                Let (l' :| ls') d' -> Let (Binding a b' c' :| (l' : ls'))  d'
+                _                  -> Let (Binding a b' c' :| []) e
       where
         b' = fmap loop b
         c' =      loop c
 
-        Let (l' :| ls') d' = loop (Let (l :| ls) d)
+        e = loop (Let (l :| ls) d)
 
     loop (Annot a b) =
         Annot a' b'

dhall/src/Dhall/Repl.hs

@@ -14,7 +14,7 @@ import Control.Exception ( SomeException(SomeException), displayException, throw
 import Control.Monad.IO.Class ( MonadIO, liftIO )
 import Control.Monad.State.Class ( MonadState, get, modify )
 import Control.Monad.State.Strict ( evalStateT )
-import Data.List ( elemIndex, isPrefixOf, nub )
+import Data.List ( isPrefixOf, nub )
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Semigroup ((<>))
 import Dhall.Binary (StandardVersion(..))
@@ -202,20 +202,15 @@ typeCheck expression = do
 -- Separate the equal sign to be its own word in order to simplify parsing
 -- This is intended to be used with the options that require assignment
 separateEqual :: [String] -> [String]
-separateEqual [] = []
-separateEqual (x:xs)
-  -- Handle the case where there is no space between the var and "="
-  | Just i <- elemIndex '=' x
-  = let (a, _:b) = splitAt i x
-    in  a : "=" : b : xs
-
-  -- Handle the case where there is no space between the "=" and the expression
-  | ('=':y):ys <- xs
-  = x : "=" : y : ys
-
-  | otherwise
-  = x : xs
-
+separateEqual [] =
+    []
+separateEqual (str₀ : ('=' : str₁) : strs) =
+    str₀ : "=" : str₁ : strs
+separateEqual (str : strs)
+    | (str₀, '=' : str₁) <- break (== '=') str =
+        str₀ : "=" : str₁ : strs
+    | otherwise =
+        str : strs
 
 addBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m ()
 addBinding (k : "=" : srcs) = do
@@ -318,12 +313,10 @@ completeFunc reversedPrev word
   = listCompletion . fmap fst <$> liftIO getEnvironment
 
   -- Complete record fields and union alternatives
-  | '.' `elem` word
+  | var : subFields <- Text.split (== '.') (Text.pack word)
   = do
     Env { envBindings } <- get
 
-    let var:subFields = Text.split (== '.') (Text.pack word)
-
     case Dhall.Context.lookup var 0 envBindings of
 
       Nothing -> pure []

dhall/tests/Dhall/Test/Lint.hs

@@ -22,6 +22,9 @@ tests =
         [ should
             "correctly handle multi-let expressions"
             "success/multilet"
+        , should
+            "not fail when an inner expression removes all `let` bindings"
+            "success/regression0"
         ]
 
 should :: Text -> Text -> TestTree

dhall/tests/lint/success/regression0A.dhall

@@ -0,0 +1,7 @@
+    let replicate = https://prelude.dhall-lang.org/List/replicate
+
+in  let Config = { name : Text, age : Natural }
+
+in  let Configs = List Config
+
+in  replicate 10 Text "!"

dhall/tests/lint/success/regression0B.dhall

@@ -0,0 +1,3 @@
+let replicate = https://prelude.dhall-lang.org/List/replicate
+
+in  replicate 10 Text "!"