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

-- | Shared utility functions

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

import Control.Exception      (Exception (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Bifunctor         (first)
import Data.Either            (lefts)
import Data.Foldable          (toList)
import Data.List.NonEmpty     (NonEmpty (..))
import Data.String            (IsString)
import Data.Text              (Text)
import Dhall.Parser           (Header (..), ParseError)
import Dhall.Pretty           (Ann, CharacterSet)
import Dhall.Src              (Src)
import Dhall.Syntax           (Expr, Import)
import Prettyprinter          (Doc, Pretty)

import qualified Control.Exception
import qualified Data.Text
import qualified Data.Text.IO
import qualified Dhall.Parser
import qualified Dhall.Pretty
import qualified Prettyprinter                 as Pretty
import qualified Prettyprinter.Render.Terminal as Pretty.Terminal
import qualified Prettyprinter.Render.Text     as Pretty.Text
import qualified System.Console.ANSI           as ANSI
import qualified System.IO                     as IO

-- | Utility function to cut out the interior of a large text block
snip :: Text -> Text
snip :: Text -> Text
snip Text
text
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ls forall a. Ord a => a -> a -> Bool
<= Int
numberOfLinesOfContext forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1 = Text
text
    | Bool
otherwise =
         if Text -> Char
Data.Text.last Text
text forall a. Eq a => a -> a -> Bool
== Char
'\n' then Text
preview else Text -> Text
Data.Text.init Text
preview
  where
    numberOfLinesOfContext :: Int
numberOfLinesOfContext = Int
20

    ls :: [Text]
ls = Text -> [Text]
Data.Text.lines Text
text

    header :: [Text]
header = forall a. Int -> [a] -> [a]
take Int
numberOfLinesOfContext [Text]
ls

    footer :: [Text]
footer = forall a. Int -> [a] -> [a]
takeEnd Int
numberOfLinesOfContext [Text]
ls

    excerpt :: [Text]
excerpt = forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> Text -> Bool
Data.Text.any (forall a. Eq a => a -> a -> Bool
/= Char
' ')) ([Text]
header forall a. Semigroup a => a -> a -> a
<> [Text]
footer)

    leadingSpaces :: Text -> Int
leadingSpaces =
        Text -> Int
Data.Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Data.Text.takeWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')

    minSpaces :: Int
minSpaces = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
leadingSpaces [Text]
excerpt)

    maxLength :: Int
maxLength = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
Data.Text.length [Text]
excerpt)

    separator :: Text
separator =
            Int -> Text -> Text
Data.Text.replicate Int
minSpaces Text
" "
        forall a. Semigroup a => a -> a -> a
<>  Int -> Text -> Text
Data.Text.replicate (Int
maxLength forall a. Num a => a -> a -> a
- Int
minSpaces) Text
"="

    preview :: Text
preview =
            [Text] -> Text
Data.Text.unlines [Text]
header
        forall a. Semigroup a => a -> a -> a
<>  Int -> Text -> Text
Data.Text.take Int
80 Text
separator forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        forall a. Semigroup a => a -> a -> a
<>  [Text] -> Text
Data.Text.unlines [Text]
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 :: forall a. Doc Ann -> Doc a
snipDoc Doc Ann
doc = forall ann. Doc ann -> Doc ann
Pretty.align (forall a ann. Pretty a => a -> Doc ann
Pretty.pretty (Text -> Text
snip Text
text))
  where
    stream :: SimpleDocStream Ann
stream = forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
doc

    ansiStream :: SimpleDocStream AnsiStyle
ansiStream = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle SimpleDocStream Ann
stream

    text :: Text
text = SimpleDocStream AnsiStyle -> Text
Pretty.Terminal.renderStrict SimpleDocStream AnsiStyle
ansiStream

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

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

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

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

    let name :: String
name =
            case InputOrTextFromStdin
input of
                Input_ (InputFile String
file) -> String
file
                Input_ Input
StandardInput    -> String
"(input)"
                StdinText String
inputName Text
_   -> String
inputName

    let result :: Either ParseError a
result = String -> Text -> Either ParseError a
parser String
name Text
inText

    let censoredResult :: Either ParseError a
censoredResult =
            case Censor
censor of
                Censor
NoCensor -> Either ParseError a
result
                Censor
Censor   -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> ParseError
Dhall.Parser.censor Either ParseError a
result

    forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
throws Either ParseError a
censoredResult

{-| Convenience utility for converting `Either`-based exceptions to `IO`-based
    exceptions
-}
throws :: (Exception e, MonadIO io) => Either e a -> io a
throws :: forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
throws (Left  e
e) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => e -> IO a
Control.Exception.throwIO e
e)
throws (Right a
r) = forall (m :: * -> *) a. Monad m => a -> m a
return a
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 deriving (Input -> Input -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c== :: Input -> Input -> Bool
Eq)

-- | Path to input or raw input text, necessary since we can't read STDIN twice
data InputOrTextFromStdin
    = Input_ Input
    | StdinText String Text
    -- ^ @StdinText name text@ where name is a user-friendly name describing the
    -- input expression, used in parsing error messages

{-| Specifies whether or not an input's transitive dependencies should also be
    processed.  Transitive dependencies are restricted to relative file imports.
-}
data Transitivity
    = NonTransitive
    -- ^ Do not process transitive dependencies
    | Transitive
    -- ^ Process transitive dependencies in the same way

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

-- | A check failure corresponding to a single input.
-- This type is intended to be used with 'MultipleCheckFailed' for error
-- reporting.
newtype CheckFailed = CheckFailed { CheckFailed -> Input
input :: Input }

-- | Exception thrown when the @--check@ flag to a command-line subcommand fails
data MultipleCheckFailed = MultipleCheckFailed
  { MultipleCheckFailed -> Text
command :: Text
  , MultipleCheckFailed -> Text
modified :: Text
  , MultipleCheckFailed -> NonEmpty Input
inputs :: NonEmpty Input
  }

instance Exception MultipleCheckFailed

instance Show MultipleCheckFailed where
    show :: MultipleCheckFailed -> String
show MultipleCheckFailed{NonEmpty Input
Text
inputs :: NonEmpty Input
modified :: Text
command :: Text
inputs :: MultipleCheckFailed -> NonEmpty Input
modified :: MultipleCheckFailed -> Text
command :: MultipleCheckFailed -> Text
..} =
         forall string. IsString string => string
_ERROR forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall " forall a. Semigroup a => a -> a -> a
<> String
command_ forall a. Semigroup a => a -> a -> a
<> String
" --check❱ failed on:\n\
        \\n" forall a. Semigroup a => a -> a -> a
<> String
files forall a. Semigroup a => a -> a -> a
<>
        String
"\n\
        \You ran ❰dhall " forall a. Semigroup a => a -> a -> a
<> String
command_ forall a. Semigroup a => a -> a -> a
<> String
" --check❱, but the input appears to have not\n\
        \been " forall a. Semigroup a => a -> a -> a
<> String
modified_ forall a. Semigroup a => a -> a -> a
<> String
" before, or was changed since the last time the input\n\
        \was " forall a. Semigroup a => a -> a -> a
<> String
modified_ forall a. Semigroup a => a -> a -> a
<> String
".\n"
      where
        modified_ :: String
modified_ = Text -> String
Data.Text.unpack Text
modified

        command_ :: String
command_ = Text -> String
Data.Text.unpack Text
command

        files :: String
files = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Input -> String
format forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Input
inputs

        format :: Input -> String
format Input
input = case Input
input of
            Input
StandardInput -> String
"↳ (stdin)"
            InputFile String
file -> String
"↳ " forall a. Semigroup a => a -> a -> a
<> String
file

-- | Run IO for multiple inputs, then collate all the check failures before
-- throwing if there was any failure
handleMultipleChecksFailed
    :: (Foldable t, Traversable t)
    => Text
    -> Text
    -> (a -> IO (Either CheckFailed ()))
    -> t a
    -> IO ()
handleMultipleChecksFailed :: forall (t :: * -> *) a.
(Foldable t, Traversable t) =>
Text -> Text -> (a -> IO (Either CheckFailed ())) -> t a -> IO ()
handleMultipleChecksFailed Text
command Text
modified a -> IO (Either CheckFailed ())
f t a
xs = forall {t :: * -> *} {b}.
Foldable t =>
t (Either CheckFailed b) -> IO ()
post forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> IO (Either CheckFailed ())
f t a
xs
  where
    post :: t (Either CheckFailed b) -> IO ()
post t (Either CheckFailed b)
results =
        case forall a b. [Either a b] -> [a]
lefts (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Either CheckFailed b)
results) of
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            CheckFailed
cf:[CheckFailed]
cfs -> forall e a. Exception e => e -> IO a
Control.Exception.throwIO forall a b. (a -> b) -> a -> b
$ MultipleCheckFailed
                { Text
command :: Text
command :: Text
command
                , Text
modified :: Text
modified :: Text
modified
                , inputs :: NonEmpty Input
inputs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CheckFailed -> Input
input (CheckFailed
cfforall a. a -> [a] -> NonEmpty a
:|[CheckFailed]
cfs)
                }

-- | Convenient utility for retrieving an expression
getExpression :: Censor -> Input -> IO (Expr Src Import)
getExpression :: Censor -> Input -> IO (Expr Src Import)
getExpression Censor
censor = forall a.
(String -> Text -> Either ParseError a)
-> Censor -> InputOrTextFromStdin -> IO a
get String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText Censor
censor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> InputOrTextFromStdin
Input_

-- | Convenient utility for retrieving an expression along with its header
getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)
getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)
getExpressionAndHeader Censor
censor =
    forall a.
(String -> Text -> Either ParseError a)
-> Censor -> InputOrTextFromStdin -> IO a
get String -> Text -> Either ParseError (Header, Expr Src Import)
Dhall.Parser.exprAndHeaderFromText Censor
censor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> InputOrTextFromStdin
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 -> String -> Text -> IO (Header, Expr Src Import)
getExpressionAndHeaderFromStdinText :: Censor -> String -> Text -> IO (Header, Expr Src Import)
getExpressionAndHeaderFromStdinText Censor
censor String
inputName =
    forall a.
(String -> Text -> Either ParseError a)
-> Censor -> InputOrTextFromStdin -> IO a
get String -> Text -> Either ParseError (Header, Expr Src Import)
Dhall.Parser.exprAndHeaderFromText Censor
censor forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> InputOrTextFromStdin
StdinText String
inputName

{-| Convenient utility to output an expression either to a file
    or to stdout.
-}
renderExpression :: Pretty a => CharacterSet -> Bool -> Maybe FilePath -> Expr Src a -> IO ()
renderExpression :: forall a.
Pretty a =>
CharacterSet -> Bool -> Maybe String -> Expr Src a -> IO ()
renderExpression CharacterSet
characterSet Bool
plain Maybe String
output Expr Src a
expression = do
    let document :: Doc Ann
document = forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src a
expression

    let stream :: SimpleDocStream Ann
stream = forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
document

    case Maybe String
output of
        Maybe String
Nothing -> do
            Bool
supportsANSI <- Handle -> IO Bool
ANSI.hSupportsANSI Handle
IO.stdout

            let ansiStream :: SimpleDocStream AnsiStyle
ansiStream =
                    if Bool
supportsANSI Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
plain
                    then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle SimpleDocStream Ann
stream
                    else forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
Pretty.unAnnotateS SimpleDocStream Ann
stream

            Handle -> SimpleDocStream AnsiStyle -> IO ()
Pretty.Terminal.renderIO Handle
IO.stdout SimpleDocStream AnsiStyle
ansiStream

            Text -> IO ()
Data.Text.IO.putStrLn Text
""

        Just String
file_ ->
            forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
file_ IOMode
IO.WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
                forall ann. Handle -> SimpleDocStream ann -> IO ()
Pretty.Text.renderIO Handle
h SimpleDocStream Ann
stream

                Handle -> Text -> IO ()
Data.Text.IO.hPutStrLn Handle
h Text
""