{-# 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
    | [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
numberOfLinesOfContext Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 = Text
text
    | Bool
otherwise =
         if Text -> Char
Data.Text.last Text
text Char -> Char -> Bool
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 = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
numberOfLinesOfContext [Text]
ls

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

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

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

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

    maxLength :: Int
maxLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Text -> Int) -> [Text] -> [Int]
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
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Int -> Text -> Text
Data.Text.replicate (Int
maxLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minSpaces) Text
"="

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

    ansiStream :: SimpleDocStream AnsiStyle
ansiStream = (Ann -> AnsiStyle)
-> SimpleDocStream Ann -> SimpleDocStream AnsiStyle
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 :: Int -> [a] -> [a]
takeEnd Int
n [a]
l = [a] -> [a] -> [a]
forall a a. [a] -> [a] -> [a]
go (Int -> [a] -> [a]
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 :: a -> Doc Ann
insert a
expression =
    Doc Ann
"↳ " Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann -> Doc Ann
forall ann. Doc ann -> Doc ann
Pretty.align (Doc Ann -> Doc Ann
forall a. Doc Ann -> Doc a
snipDoc (a -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty a
expression))

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

get
    :: (String -> Text -> Either ParseError a)
    -> Censor
    -> InputOrTextFromStdin
    -> IO a
get :: (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        -> Text -> IO 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   -> (ParseError -> ParseError)
-> Either ParseError a -> Either ParseError a
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

    Either ParseError a -> IO a
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 :: Either e a -> io a
throws (Left  e
e) = IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (e -> IO a
forall e a. Exception e => e -> IO a
Control.Exception.throwIO e
e)
throws (Right a
r) = a -> io a
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
(Input -> Input -> Bool) -> (Input -> Input -> Bool) -> Eq Input
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{Text
NonEmpty Input
inputs :: NonEmpty Input
modified :: Text
command :: Text
inputs :: MultipleCheckFailed -> NonEmpty Input
modified :: MultipleCheckFailed -> Text
command :: MultipleCheckFailed -> Text
..} =
         String
forall string. IsString string => string
_ERROR String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
command_ String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" --check❱ failed on:\n\
        \\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
files String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
"\n\
        \You ran ❰dhall " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
command_ String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" --check❱, but the input appears to have not\n\
        \been " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
modified_ String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" before, or was changed since the last time the input\n\
        \was " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
modified_ String -> ShowS
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 ([String] -> String) -> ([Input] -> [String]) -> [Input] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> String) -> [Input] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input -> String
format ([Input] -> String) -> [Input] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty Input -> [Input]
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
"↳ " String -> ShowS
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 :: Text -> Text -> (a -> IO (Either CheckFailed ())) -> t a -> IO ()
handleMultipleChecksFailed Text
command Text
modified a -> IO (Either CheckFailed ())
f t a
xs = t (Either CheckFailed ()) -> IO ()
forall (t :: * -> *) b.
Foldable t =>
t (Either CheckFailed b) -> IO ()
post (t (Either CheckFailed ()) -> IO ())
-> IO (t (Either CheckFailed ())) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> IO (Either CheckFailed ()))
-> t a -> IO (t (Either CheckFailed ()))
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 [Either CheckFailed b] -> [CheckFailed]
forall a b. [Either a b] -> [a]
lefts (t (Either CheckFailed b) -> [Either CheckFailed b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Either CheckFailed b)
results) of
            [] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            CheckFailed
cf:[CheckFailed]
cfs -> MultipleCheckFailed -> IO ()
forall e a. Exception e => e -> IO a
Control.Exception.throwIO (MultipleCheckFailed -> IO ()) -> MultipleCheckFailed -> IO ()
forall a b. (a -> b) -> a -> b
$ MultipleCheckFailed :: Text -> Text -> NonEmpty Input -> MultipleCheckFailed
MultipleCheckFailed
                { Text
command :: Text
command :: Text
command
                , Text
modified :: Text
modified :: Text
modified
                , inputs :: NonEmpty Input
inputs = (CheckFailed -> Input) -> NonEmpty CheckFailed -> NonEmpty Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CheckFailed -> Input
input (CheckFailed
cfCheckFailed -> [CheckFailed] -> NonEmpty CheckFailed
forall 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 = (String -> Text -> Either ParseError (Expr Src Import))
-> Censor -> InputOrTextFromStdin -> IO (Expr Src Import)
forall a.
(String -> Text -> Either ParseError a)
-> Censor -> InputOrTextFromStdin -> IO a
get String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText Censor
censor (InputOrTextFromStdin -> IO (Expr Src Import))
-> (Input -> InputOrTextFromStdin) -> Input -> IO (Expr Src Import)
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 =
    (String -> Text -> Either ParseError (Header, Expr Src Import))
-> Censor -> InputOrTextFromStdin -> IO (Header, Expr Src Import)
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 (InputOrTextFromStdin -> IO (Header, Expr Src Import))
-> (Input -> InputOrTextFromStdin)
-> Input
-> IO (Header, Expr Src Import)
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 =
    (String -> Text -> Either ParseError (Header, Expr Src Import))
-> Censor -> InputOrTextFromStdin -> IO (Header, Expr Src Import)
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 (InputOrTextFromStdin -> IO (Header, Expr Src Import))
-> (Text -> InputOrTextFromStdin)
-> Text
-> IO (Header, Expr Src Import)
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 :: 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 = CharacterSet -> Expr Src a -> Doc Ann
forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src a
expression

    let stream :: SimpleDocStream Ann
stream = Doc Ann -> SimpleDocStream Ann
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 (Ann -> AnsiStyle)
-> SimpleDocStream Ann -> SimpleDocStream AnsiStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle SimpleDocStream Ann
stream
                    else SimpleDocStream Ann -> SimpleDocStream AnsiStyle
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_ ->
            String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
file_ IOMode
IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
                Handle -> SimpleDocStream Ann -> IO ()
forall ann. Handle -> SimpleDocStream ann -> IO ()
Pretty.Text.renderIO Handle
h SimpleDocStream Ann
stream

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