Util.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- | Shared utility functions

module Dhall.Util
    ( snip
    , snipDoc
    , insert
    , _ERROR
    , Censor(..)
    , Input(..)
    , OutputMode(..)
    , Output(..)
    , getExpression
    , getExpressionAndHeader
    , getExpressionAndHeaderFromStdinText
    , Header(..)
    , CheckFailed(..)
    ) where

import Control.Exception (Exception(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (first)
import Data.Monoid ((<>))
import Data.String (IsString)
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty)
import Dhall.Parser (ParseError, Header(..))
import Dhall.Pretty (Ann)
import Dhall.Syntax (Expr, Import)
import Dhall.Src (Src)

import qualified Control.Exception
import qualified Data.Text
import qualified Data.Text.IO
import qualified Data.Text.Prettyprint.Doc                 as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal
import qualified Dhall.Parser
import qualified Dhall.Pretty

-- | Utility function to cut out the interior of a large text block
snip :: Text -> Text
snip text
    | length ls <= numberOfLinesOfContext * 2 + 1 = text
    | otherwise =
         if Data.Text.last text == '\n' then preview else Data.Text.init preview
  where
    numberOfLinesOfContext = 20

    ls = Data.Text.lines text

    header = take numberOfLinesOfContext ls

    footer = takeEnd numberOfLinesOfContext 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
        <>  Data.Text.take 80 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 = Dhall.Pretty.layout doc

    ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream

    text = Pretty.Terminal.renderStrict ansiStream

takeEnd :: Int -> [a] -> [a]
takeEnd n l = go (drop n l) l
  where
    go (_:xs) (_:ys) = go xs ys
    go _ r = r

-- | Function to insert an aligned pretty expression
insert :: Pretty a => a -> Doc Ann
insert expression =
    "↳ " <> Pretty.align (snipDoc (Pretty.pretty expression))

-- | Prefix used for error messages
_ERROR :: IsString string => string
_ERROR = "\ESC[1;31mError\ESC[0m"

get
    :: (String -> Text -> Either ParseError a)
    -> Censor
    -> InputOrTextFromStdin
    -> IO a
get parser censor input = do
    inText <- do
        case input of
            Input_ (InputFile file) -> Data.Text.IO.readFile file
            Input_ StandardInput    -> Data.Text.IO.getContents
            StdinText text          -> pure text

    let name =
            case input of
                Input_ (InputFile file) -> file
                Input_ StandardInput    -> "(input)"
                StdinText _             -> "(input)"

    let result = parser name inText

    let censoredResult =
            case censor of
                NoCensor -> result
                Censor   -> first Dhall.Parser.censor result

    throws censoredResult

{-| Convenience utility for converting `Either`-based exceptions to `IO`-based
    exceptions
-}
throws :: (Exception e, MonadIO io) => Either e a -> io a
throws (Left  e) = liftIO (Control.Exception.throwIO e)
throws (Right r) = return r

-- | Set to `Censor` if you want to censor error text that might include secrets
data Censor = NoCensor | Censor

-- | Path to input
data Input = StandardInput | InputFile FilePath

-- | Path to input or raw input text, necessary since we can't read STDIN twice
data InputOrTextFromStdin = Input_ Input | StdinText Text

-- | Path to output
data Output = StandardOutput | OutputFile FilePath

{-| Some command-line subcommands can either `Write` their input or `Check`
    that the input has already been modified.  This type is shared between them
    to record that choice.
-}
data OutputMode = Write | Check

-- | Exception thrown when the @--check@ flag to a command-line subcommand fails
data CheckFailed = CheckFailed { command :: Text, modified :: Text }

instance Exception CheckFailed

instance Show CheckFailed where
    show CheckFailed{..} =
         _ERROR <> ": ❰dhall " <> command_ <> " --check❱ failed\n\
        \\n\
        \You ran ❰dhall " <> command_ <> " --check❱, but the input appears to have not\n\
        \been " <> modified_ <> " before, or was changed since the last time the input\n\
        \was " <> modified_ <> ".\n"
      where
        modified_ = Data.Text.unpack modified

        command_ = Data.Text.unpack command

-- | Convenient utility for retrieving an expression
getExpression :: Censor -> Input -> IO (Expr Src Import)
getExpression censor = get Dhall.Parser.exprFromText censor . Input_

-- | Convenient utility for retrieving an expression along with its header
getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)
getExpressionAndHeader censor =
    get Dhall.Parser.exprAndHeaderFromText censor . Input_

-- | Convenient utility for retrieving an expression along with its header from
-- | text already read from STDIN (so it's not re-read)
getExpressionAndHeaderFromStdinText :: Censor -> Text -> IO (Header, Expr Src Import)
getExpressionAndHeaderFromStdinText censor =
    get Dhall.Parser.exprAndHeaderFromText censor . StdinText