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

-- | This module contains Dhall's parsing logic

module Dhall.Parser (
    -- * Utilities
      exprFromText
    , exprAndHeaderFromText
    , censor
    , createHeader

    -- * Parsers
    , expr, exprA

    -- * Types
    , Header(..)
    , Src(..)
    , SourcedException(..)
    , ParseError(..)
    , Parser(..)
    ) where

import Control.Applicative (many)
import Control.Exception   (Exception)
import Data.Text           (Text)
import Data.Void           (Void)
import Dhall.Src           (Src (..))
import Dhall.Syntax
import Text.Megaparsec     (ParseErrorBundle (..), PosState (..))

import qualified Data.Text       as Text
import qualified Dhall.Core      as Core
import qualified Text.Megaparsec

import Dhall.Parser.Combinators
import Dhall.Parser.Expression
import Dhall.Parser.Token       hiding (text)

-- | Parser for a top-level Dhall expression
expr :: Parser (Expr Src Import)
expr :: Parser (Expr Src Import)
expr = Parser Import -> Parser (Expr Src Import)
forall a. Parser a -> Parser (Expr Src a)
exprA (Parser Import -> Parser Import
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Text.Megaparsec.try Parser Import
import_)

-- | Parser for a top-level Dhall expression. The expression is parameterized
-- over any parseable type, allowing the language to be extended as needed.
exprA :: Parser a -> Parser (Expr Src a)
exprA :: Parser a -> Parser (Expr Src a)
exprA = Parser a -> Parser (Expr Src a)
forall a. Parser a -> Parser (Expr Src a)
completeExpression
{-# DEPRECATED exprA "Support for parsing custom imports will be dropped in a future release" #-}

-- | A parsing error
data ParseError = ParseError {
      ParseError -> ParseErrorBundle Text Void
unwrap :: Text.Megaparsec.ParseErrorBundle Text Void
    , ParseError -> Text
input  :: Text
    }

{-| Replace the source code with spaces when rendering error messages

    This utility is used to implement the @--censor@ flag
-}
censor :: ParseError -> ParseError
censor :: ParseError -> ParseError
censor ParseError
parseError =
    ParseError
parseError
        { unwrap :: ParseErrorBundle Text Void
unwrap =
            (ParseError -> ParseErrorBundle Text Void
unwrap ParseError
parseError)
                { bundlePosState :: PosState Text
bundlePosState =
                    (ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
bundlePosState (ParseError -> ParseErrorBundle Text Void
unwrap ParseError
parseError))
                        { pstateInput :: Text
pstateInput =
                            Text -> Text
Core.censorText
                                (PosState Text -> Text
forall s. PosState s -> s
pstateInput (ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
bundlePosState (ParseError -> ParseErrorBundle Text Void
unwrap ParseError
parseError)))
                        }
                }
        }

instance Show ParseError where
    show :: ParseError -> String
show (ParseError {Text
ParseErrorBundle Text Void
input :: Text
unwrap :: ParseErrorBundle Text Void
input :: ParseError -> Text
unwrap :: ParseError -> ParseErrorBundle Text Void
..}) =
      String
"\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Text.Megaparsec.errorBundlePretty ParseErrorBundle Text Void
unwrap

instance Exception ParseError

-- | Parse an expression from `Text.Text` containing a Dhall program
exprFromText
  :: String -- ^ User-friendly name describing the input expression,
            --   used in parsing error messages
  -> Text   -- ^ Input expression to parse
  -> Either ParseError (Expr Src Import)
exprFromText :: String -> Text -> Either ParseError (Expr Src Import)
exprFromText String
delta Text
text = ((Header, Expr Src Import) -> Expr Src Import)
-> Either ParseError (Header, Expr Src Import)
-> Either ParseError (Expr Src Import)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Header, Expr Src Import) -> Expr Src Import
forall a b. (a, b) -> b
snd (String -> Text -> Either ParseError (Header, Expr Src Import)
exprAndHeaderFromText String
delta Text
text)

-- | A header corresponds to the leading comment at the top of a Dhall file.
--
-- The header includes comment characters but is stripped of leading spaces and
-- trailing newlines
newtype Header = Header Text deriving Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show

-- | Create a header with stripped leading spaces and trailing newlines
createHeader :: Text -> Header
createHeader :: Text -> Header
createHeader Text
text = Text -> Header
Header (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newSuffix)
  where
    isWhitespace :: Char -> Bool
isWhitespace Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'

    prefix :: Text
prefix = (Char -> Bool) -> Text -> Text
Text.dropAround Char -> Bool
isWhitespace Text
text

    newSuffix :: Text
newSuffix
        | Text -> Bool
Text.null Text
prefix = Text
""
        | Bool
otherwise        = Text
"\n"

-- | Like `exprFromText` but also returns the leading comments and whitespace
-- (i.e. header) up to the last newline before the code begins
--
-- In other words, if you have a Dhall file of the form:
--
-- > -- Comment 1
-- > {- Comment -} 2
--
-- Then this will preserve @Comment 1@, but not @Comment 2@
--
-- This is used by @dhall-format@ to preserve leading comments and whitespace
exprAndHeaderFromText
    :: String -- ^ User-friendly name describing the input expression,
              --   used in parsing error messages
    -> Text   -- ^ Input expression to parse
    -> Either ParseError (Header, Expr Src Import)
exprAndHeaderFromText :: String -> Text -> Either ParseError (Header, Expr Src Import)
exprAndHeaderFromText String
delta Text
text = case Either (ParseErrorBundle Text Void) (Text, Expr Src Import)
result of
    Left ParseErrorBundle Text Void
errInfo   -> ParseError -> Either ParseError (Header, Expr Src Import)
forall a b. a -> Either a b
Left (ParseError :: ParseErrorBundle Text Void -> Text -> ParseError
ParseError { unwrap :: ParseErrorBundle Text Void
unwrap = ParseErrorBundle Text Void
errInfo, input :: Text
input = Text
text })
    Right (Text
txt, Expr Src Import
r) -> (Header, Expr Src Import)
-> Either ParseError (Header, Expr Src Import)
forall a b. b -> Either a b
Right (Text -> Header
createHeader Text
txt, Expr Src Import
r)
  where
    parser :: Parser (Text, Expr Src Import)
parser = do
        (Text
bytes, ()
_) <- Parser () -> Parser (Tokens Text, ())
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
Text.Megaparsec.match (Parser () -> Parser [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
shebang Parser [()] -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
whitespace)
        Expr Src Import
r <- Parser (Expr Src Import)
expr
        Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Text.Megaparsec.eof
        (Text, Expr Src Import) -> Parser (Text, Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
bytes, Expr Src Import
r)

    result :: Either (ParseErrorBundle Text Void) (Text, Expr Src Import)
result = Parsec Void Text (Text, Expr Src Import)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (Text, Expr Src Import)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Text.Megaparsec.parse (Parser (Text, Expr Src Import)
-> Parsec Void Text (Text, Expr Src Import)
forall a. Parser a -> Parsec Void Text a
unParser Parser (Text, Expr Src Import)
parser) String
delta Text
text