Truncate the displayed source code when it exceeds 7 lines (#589)

Fixes #573

Example output:

```
$ dhall --explain <<< './test.dhall'


↳ ./test.dhall

y : < Foo0 :
        Type
    | Foo1 :
    ========
    | Foo9 :
        {}
    >


Error: You can only append ❰List❱s with matching element types

- Natural
+ { … : … }

Explanation: You can append two ❰List❱s using the ❰#❱ operator, like this:


    ┌────────────────────┐
    │ [1, 2, 3] # [4, 5] │
    └────────────────────┘


... but you cannot append two ❰List❱s if they have different element types.
For example, the following expression is not valid:


       These elements have type ❰Natural❱
       ⇩
    ┌───────────────────────────┐
    │ [1, 2, 3] # [True, False] │  Invalid: the element types don't match
    └───────────────────────────┘
                  ⇧
                  These elements have type ❰Bool❱


────────────────────────────────────────────────────────────────────────────────

You tried to append a ❰List❱ thas has elements of type:

↳ Natural


... with another ❰List❱ that has elements of type:

↳ { a :
      Natural
  , b :
  ===========
  , g :
      Natural
  }


... and those two types do not match

────────────────────────────────────────────────────────────────────────────────

            [ 1
            , 1
            , 1
            =============
                  , g = 7
                  } ]


/Users/gabriel/proj/dhall/test.dhall:13:13
```

dhall.cabal

@@ -234,6 +234,7 @@ Library
         Dhall.Parser.Combinators,
         Dhall.Parser.Token,
         Dhall.Import.Types,
+        Dhall.Util,
         Paths_dhall
     if flag(with-http)
       Other-Modules:

src/Dhall/Parser/Combinators.hs

@@ -26,6 +26,7 @@ import qualified Data.List
 import qualified Data.Sequence
 import qualified Data.Set
 import qualified Data.Text
+import qualified Dhall.Util
 import qualified Control.Monad.Fail
 import qualified Text.Megaparsec
 import qualified Text.Megaparsec.Char
@@ -50,9 +51,13 @@ laxSrcEq (Src p q _) (Src p' q' _) = eq p  p' && eq q q'
 
 instance Pretty Src where
     pretty (Src begin _ text) =
-            pretty text <> "\n"
+            pretty (Dhall.Util.snip (prefix <> text))
         <>  "\n"
         <>  pretty (Text.Megaparsec.sourcePosPretty begin)
+      where
+        prefix = Data.Text.replicate (n - 1) " "
+          where
+            n = Text.Megaparsec.unPos (Text.Megaparsec.sourceColumn begin)
 
 {-| A `Parser` that is almost identical to
     @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style

src/Dhall/Tutorial.hs

@@ -531,7 +531,7 @@ import Dhall
 -- - Natural
 -- + Bool
 -- ...
--- True
+--     True
 -- ...
 -- (input):1:5
 -- ...

src/Dhall/TypeCheck.hs

@@ -47,6 +47,7 @@ import qualified Dhall.Context
 import qualified Dhall.Core
 import qualified Dhall.Diff
 import qualified Dhall.Pretty.Internal
+import qualified Dhall.Util
 
 traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f ()
 traverseWithIndex_ k xs =
@@ -898,7 +899,8 @@ _NOT :: Doc ann
 _NOT = "\ESC[1mnot\ESC[0m"
 
 insert :: Pretty a => a -> Doc Ann
-insert expression = "↳ " <> Pretty.align (Pretty.pretty expression)
+insert expression =
+    "↳ " <> Pretty.align (Dhall.Util.snipDoc (Pretty.pretty expression))
 
 prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann
 prettyDiff exprL exprR = Dhall.Diff.diffNormalized exprL exprR
@@ -3646,7 +3648,8 @@ instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where
             <>  source
             )
       where
-        prettyKV (key, val) = pretty key <> " : " <> pretty val
+        prettyKV (key, val) =
+            pretty key <> " : " <> Dhall.Util.snipDoc (pretty val)
 
         prettyContext =
                 Pretty.vsep
@@ -3683,7 +3686,8 @@ instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where
             <>  source
             )
       where
-        prettyKV (key, val) = pretty key <> " : " <> pretty val
+        prettyKV (key, val) =
+            pretty key <> " : " <> Dhall.Util.snipDoc (pretty val)
 
         prettyContext =
                 Pretty.vsep

src/Dhall/Util.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Shared utility functions
+
+module Dhall.Util
+    ( snip
+    , snipDoc
+    ) where
+
+import Data.Text (Text)
+import Data.Text.Prettyprint.Doc (Doc)
+import Dhall.Pretty (Ann)
+
+import qualified Data.Text
+import qualified Data.Text.Prettyprint.Doc             as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
+import qualified Dhall.Pretty
+
+-- | Utility function to cut out the interior of a large text block
+snip :: Text -> Text
+snip text
+    | length ls <= 7 = text
+    | otherwise =
+         if Data.Text.last text == '\n' then preview else Data.Text.init preview
+  where
+    ls = Data.Text.lines text
+
+    header = take 3 ls
+
+    footer = takeEnd 3 ls
+
+    excerpt = filter (Data.Text.any (/= ' ')) (header <> footer)
+
+    leadingSpaces =
+        Data.Text.length . Data.Text.takeWhile (== ' ')
+
+    minSpaces = minimum (map leadingSpaces excerpt)
+
+    maxLength = maximum (map Data.Text.length excerpt)
+
+    separator =
+            Data.Text.replicate minSpaces " "
+        <>  Data.Text.replicate (maxLength - minSpaces) "="
+
+    preview =
+            Data.Text.unlines header
+        <>  separator <> "\n"
+        <>  Data.Text.unlines footer
+
+{-| Like `snip`, but for `Doc`s
+
+    Note that this has to be opinionated and render ANSI color codes, but that
+    should be fine because we don't use this in a non-interactive context
+-}
+snipDoc :: Doc Ann -> Doc a
+snipDoc doc = Pretty.align (Pretty.pretty (snip text))
+  where
+    stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts doc
+
+    ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream
+
+    text = Pretty.renderStrict ansiStream
+
+takeEnd :: Int -> [a] -> [a]
+takeEnd n l = go (drop n l) l
+  where
+    go (_:xs) (_:ys) = go xs ys
+    go _ r = r