Parser.hs

{-# OPTIONS_GHC -Wno-unused-do-bind #-}

{-| This module translates @./dhall.abnf@ into a parser implemented using an
    LL parser combinator package

    This parser tries to hew as closely as possible to the ABNF grammar,
    sometimes at the expense of efficiency.  However, the efficiency is still
    decent.
-}
module Parser
    ( -- * Type
      Parser(..)

      -- * Parser
    , completeExpression
    ) where

import Control.Applicative (Alternative(..), optional)
import Control.Monad (MonadPlus(..), guard, replicateM)
import Crypto.Hash (Digest, SHA256)
import Data.ByteArray.Encoding (Base(..))
import Data.ByteString (ByteString)
import Data.Functor (void)
import Data.List.NonEmpty (NonEmpty(..))
import Data.String (IsString(..))
import Data.Fixed (Pico)
import Data.Ratio ((%))
import Data.Text (Text)
import Data.Void (Void)
import Numeric.Natural (Natural)
import Prelude hiding (exponent, takeWhile)
import Text.Megaparsec.Char (char)

import Syntax
    ( Builtin(..)
    , Constant(..)
    , Expression(..)
    , File(..)
    , FilePrefix(..)
    , ImportMode(..)
    , ImportType(..)
    , Operator(..)
    , Scheme(..)
    , TextLiteral(..)
    , URL(..)
    , PathComponent(..)
    )
import Text.Megaparsec
    ( MonadParsec
    , Parsec
    , count
    , notFollowedBy
    , satisfy
    , takeWhileP
    , takeWhile1P
    , try
    )

import qualified Control.Monad.Combinators.NonEmpty as Combinators.NonEmpty
import qualified Crypto.Hash                        as Hash
import qualified Data.ByteArray.Encoding            as ByteArray.Encoding
import qualified Data.ByteString.Char8              as ByteString8
import qualified Data.ByteString.Base16             as Base16
import qualified Data.Char                          as Char
import qualified Data.List.NonEmpty                 as NonEmpty
import qualified Data.Map                           as Map
import qualified Data.Scientific                    as Scientific
import qualified Data.Text                          as Text
import qualified Data.Text.Encoding                 as Text.Encoding
import qualified Data.Time                          as Time
import qualified Multiline

{-| @newtype@ wrapper around the `Parsec` type to improve inferred types and
    error messages
-}
newtype Parser a = Parser { unParser :: Parsec Void Text a }
    deriving
    ( Alternative
    , Applicative
    , Functor
    , Monad
    , MonadFail
    , MonadParsec Void Text
    , MonadPlus
    , Monoid
    , Semigroup
    )

instance a ~ Text => IsString (Parser a) where
    fromString x = Parser (fromString x)

between :: Char -> Char -> Char -> Bool
between lo hi c = lo <= c && c <= hi

takeWhile :: (Char -> Bool) -> Parser Text
takeWhile = takeWhileP Nothing

takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 = takeWhile1P Nothing

digitToNumber :: Char -> Int
digitToNumber c
    | '0' <= c && c <= '9' = 0x0 + Char.ord c - Char.ord '0'
    | 'A' <= c && c <= 'F' = 0xA + Char.ord c - Char.ord 'A'
    | 'a' <= c && c <= 'f' = 0xa + Char.ord c - Char.ord 'a'
    | otherwise = error "Invalid hexadecimal digit"

caseInsensitive :: Char -> Char -> Bool
caseInsensitive expected actual = Char.toUpper actual == expected

base :: Num n => [Char] -> n -> n
digits `base` b = foldl snoc 0 (map (fromIntegral . digitToNumber) digits)
  where
    snoc result number = result * b + number

atMost :: Int -> Parser a -> Parser [a]
atMost 0 _ = do
    return []
atMost n parser = (do
    x <- parser

    xs <- atMost (n - 1) parser

    return (x : xs) ) <|> return []

atLeast :: Int -> Parser a -> Parser [a]
atLeast lowerBound parser = do
    prefix <- replicateM lowerBound parser

    suffix <- many parser

    return (prefix <> suffix)

range :: Int -> Int -> Parser a -> Parser [a]
range lowerBound upperBound parser = do
    prefix <- replicateM lowerBound parser

    suffix <- atMost (upperBound - lowerBound) parser

    return (prefix <> suffix)

endOfLine :: Parser Text
endOfLine = "\n" <|> "\r\n"

validNonAscii :: Char -> Bool
validNonAscii c =
       between     '\x80'   '\xD7FF' c
    || between   '\xE000'   '\xFFFD' c
    || between  '\x10000'  '\x1FFFD' c
    || between  '\x20000'  '\x2FFFD' c
    || between  '\x30000'  '\x3FFFD' c
    || between  '\x40000'  '\x4FFFD' c
    || between  '\x50000'  '\x5FFFD' c
    || between  '\x60000'  '\x6FFFD' c
    || between  '\x70000'  '\x7FFFD' c
    || between  '\x80000'  '\x8FFFD' c
    || between  '\x90000'  '\x9FFFD' c
    || between  '\xA0000'  '\xAFFFD' c
    || between  '\xB0000'  '\xBFFFD' c
    || between  '\xC0000'  '\xCFFFD' c
    || between  '\xD0000'  '\xDFFFD' c
    || between  '\xE0000'  '\xEFFFD' c
    || between  '\xF0000'  '\xFFFFD' c
    || between '\x100000' '\x10FFFD' c

tab :: Char
tab = '\t'

blockComment :: Parser ()
blockComment = do "{-"; blockCommentContinue

blockCommentChar :: Parser ()
blockCommentChar =
        void (satisfy (between '\x20' '\x7F'))
    <|> void (satisfy validNonAscii)
    <|> void (char tab)
    <|> void endOfLine

blockCommentContinue :: Parser ()
blockCommentContinue =
        void "-}"
    <|> (do blockComment; blockCommentContinue)
    <|> (do blockCommentChar; blockCommentContinue)

notEndOfLine :: Parser ()
notEndOfLine = void (satisfy predicate)
  where
    predicate c =
            between '\x20' '\x7F' c
        ||  validNonAscii c
        ||  tab == c

lineCommentPrefix :: Parser ()
lineCommentPrefix = do "--"; many notEndOfLine; return ()

lineComment :: Parser ()
lineComment = try (do lineCommentPrefix; endOfLine; return ())

whitespaceChunk :: Parser ()
whitespaceChunk =
        void " "
    <|> void (char tab)
    <|> void endOfLine
    <|> lineComment
    <|> blockComment

whsp :: Parser ()
whsp = void (many whitespaceChunk)

whsp1 :: Parser ()
whsp1 = void (some whitespaceChunk)

alpha :: Char -> Bool
alpha c = between '\x41' '\x5A' c || between '\x61' '\x7A' c

digit :: Char -> Bool
digit = between '\x30' '\x39'

alphaNum :: Char -> Bool
alphaNum c = alpha c || digit c

hexUpTo :: Char -> Char -> Bool
hexUpTo upperBound c = digit c || between 'A' upperBound (Char.toUpper c)

hexDig :: Char -> Bool
hexDig = hexUpTo 'F'

simpleLabelFirstChar :: Char -> Bool
simpleLabelFirstChar c = alpha c || c == '_'

simpleLabelNextChar :: Char -> Bool
simpleLabelNextChar c = alphaNum c || c `elem` [ '-', '/', '_' ]

simpleLabel :: Parser Text
simpleLabel = try do
    first <- satisfy simpleLabelFirstChar

    rest  <- takeWhile simpleLabelNextChar

    let l = Text.cons first rest

    guard (l `notElem` reservedKeywords)

    return l

quotedLabelChar :: Char -> Bool
quotedLabelChar c = between '\x20' '\x5F' c || between '\x61' '\x7E' c

quotedLabel :: Parser Text
quotedLabel = takeWhile quotedLabelChar

label :: Parser Text
label = (do "`"; l <- quotedLabel; "`"; return l)
    <|> simpleLabel

nonreservedLabel :: Parser Text
nonreservedLabel = do
    notFollowedBy do
        void builtin <|> void constant <|> keyword
        notFollowedBy (satisfy simpleLabelNextChar)

    label

anyLabel :: Parser Text
anyLabel = label

anyLabelOrSome :: Parser Text
anyLabelOrSome = anyLabel <|> "Some"

withComponent :: Parser PathComponent
withComponent = (Label <$> anyLabelOrSome) <|> (DescendOptional <$ "?")

doubleQuoteChunk :: Parser TextLiteral
doubleQuoteChunk =
        interpolation
    <|> (do char '\x5C';

            c <- doubleQuoteEscaped;

            return (Chunks [] (Text.singleton c))
        )
    <|> (do c <- satisfy doubleQuoteChar

            return (Chunks [] (Text.singleton c))
        )

doubleQuoteEscaped :: Parser Char
doubleQuoteEscaped = do
        (do "\""; return '"' )
    <|> (do "$" ; return '$' )
    <|> (do "\\"; return '\\')
    <|> (do "/" ; return '/' )
    <|> (do "b" ; return '\b')
    <|> (do "f" ; return '\f')
    <|> (do "n" ; return '\n')
    <|> (do "r" ; return '\r')
    <|> (do "t" ; return '\t')
    <|> (do "u"; unicodeEscape)

unicodeEscape :: Parser Char
unicodeEscape = do
    number <- unbracedEscape <|> (do "{"; c <- bracedEscape; "}"; return c)

    return (Char.chr number)

unicodeSuffix :: Parser Int
unicodeSuffix = beginsWithoutF <|> beginsWithF
  where
    beginsWithoutF = do
        digit0 <- satisfy (hexUpTo 'E')

        digits1 <- replicateM 3 (satisfy hexDig)

        return ((digit0 : digits1) `base` 16)

    beginsWithF = do
        digit0 <- satisfy (caseInsensitive 'F')

        digits1 <- replicateM 2 (satisfy hexDig)

        digit2 <- satisfy (hexUpTo 'D')

        return ((digit0 : digits1 <> [ digit2 ]) `base` 16)

unbracedEscape :: Parser Int
unbracedEscape = beginsUpToC <|> beginsWithD <|> beginsWithE <|> beginsWithF
  where
    beginsUpToC = do
        digit0 <- satisfy (hexUpTo 'C')

        digits1 <- replicateM 3 (satisfy hexDig)

        return ((digit0 : digits1) `base` 16)

    beginsWithD = do
        digit0 <- satisfy (caseInsensitive 'D')

        digit1 <- satisfy (between '0' '7')

        digits2 <- replicateM 2 (satisfy hexDig)

        return ((digit0 : digit1 : digits2) `base` 16)

    beginsWithE = do
        digit0 <- satisfy (caseInsensitive 'E')

        digits1 <- replicateM 3 (satisfy hexDig)

        return ((digit0 : digits1) `base` 16)

    beginsWithF = do
        digit0 <- satisfy (caseInsensitive 'F')

        digits1 <- replicateM 2 (satisfy hexDig)

        digit2 <- satisfy (hexUpTo 'D')

        return ((digit0 : digits1 <> [ digit2 ]) `base` 16)

bracedCodepoint :: Parser Int
bracedCodepoint = planes1Through16 <|> unbracedEscape <|> threeDigits
  where
    planes1Through16 = do
        prefix <- fmap digitToNumber (satisfy hexDig) <|> (do "10"; return 16)

        suffix <- unicodeSuffix

        return (prefix * 0x10000 + suffix)

    threeDigits = do
        digits <- range 1 3 (satisfy hexDig)

        return (digits `base` 16)

bracedEscape :: Parser Int
bracedEscape = do
    takeWhile (== '0')

    bracedCodepoint

doubleQuoteChar :: Char -> Bool
doubleQuoteChar c = do
        between '\x20' '\x21' c
    ||  between '\x23' '\x5B' c
    ||  between '\x5D' '\x7F' c
    ||  validNonAscii c

doubleQuoteLiteral :: Parser TextLiteral
doubleQuoteLiteral = do
    char '"'

    chunks <- many doubleQuoteChunk

    char '"'

    return (mconcat chunks)

singleQuoteContinue :: Parser TextLiteral
singleQuoteContinue =
        (interpolation <> singleQuoteContinue)
    <|> (escapedQuotePair <> singleQuoteContinue)
    <|> (escapedInterpolation <> singleQuoteContinue)
    <|> (do "''"; return mempty)
    <|> (singleQuoteChar <> singleQuoteContinue)

escapedQuotePair :: Parser TextLiteral
escapedQuotePair = do "'''"; return (Chunks [] "''")

escapedInterpolation :: Parser TextLiteral
escapedInterpolation = do
    "''${"

    return (Chunks [] "${")

singleQuoteChar :: Parser TextLiteral
singleQuoteChar =
        (do c <- satisfy predicate

            return (Chunks [] (Text.singleton c))
        )
    <|> (do t <- endOfLine

            return (Chunks [] t)
        )
  where
    predicate c =
            between '\x20' '\x7F' c
        ||  validNonAscii c
        ||  tab == c

singleQuoteLiteral :: Parser TextLiteral
singleQuoteLiteral = do
    "''"

    endOfLine

    contents <- singleQuoteContinue

    return (Multiline.toDoubleQuotes contents)

interpolation :: Parser TextLiteral
interpolation = do
    "${"

    e <- completeExpression

    "}"

    return (Chunks [("", e)] "")

textLiteral :: Parser TextLiteral
textLiteral = doubleQuoteLiteral <|> singleQuoteLiteral

bytesLiteral :: Parser ByteString
bytesLiteral = hexadecimal
  where
    hexadecimal = do
        "0x\""

        chunks <- many (count 2 (satisfy hexDig))

        char '"'

        case Base16.decodeBase16 $ ByteString8.pack $ concat chunks of
            Left e -> fail $ Text.unpack e
            Right bytes -> return bytes

reservedKeywords :: [Text]
reservedKeywords =
    [ "if"
    , "then"
    , "else"
    , "let"
    , "in"
    , "using"
    , "missing"
    , "assert"
    , "as"
    , "Infinity"
    , "NaN"
    , "merge"
    , "Some"
    , "toMap"
    , "forall"
    , "with"
    , "showConstructor"
    ]

keyword :: Parser ()
keyword =
        if_
    <|> then_
    <|> else_
    <|> let_
    <|> in_
    <|> using
    <|> void missing
    <|> assert
    <|> as
    <|> _Infinity
    <|> _NaN
    <|> merge
    <|> _Some
    <|> toMap
    <|> forallKeyword
    <|> with
    <|> showConstructor

if_ :: Parser ()
if_ = void "if"

then_ :: Parser ()
then_ = void "then"

else_ :: Parser ()
else_ = void "else"

let_ :: Parser ()
let_ = void "let"

in_ :: Parser ()
in_ = void "in"

as :: Parser ()
as = void "as"

using :: Parser ()
using = void "using"

merge :: Parser ()
merge = void "merge"

missing :: Parser ImportType
missing = try do
    "missing"

    notFollowedBy (satisfy simpleLabelNextChar)

    return Missing

_Infinity :: Parser ()
_Infinity = void "Infinity"

_NaN :: Parser ()
_NaN = void "NaN"

_Some :: Parser ()
_Some = void "Some"

toMap :: Parser ()
toMap = void "toMap"

assert :: Parser ()
assert = void "assert"

forallKeyword :: Parser ()
forallKeyword = void "forall"

forallSymbol :: Parser ()
forallSymbol = void "∀"

forall_ :: Parser ()
forall_ = forallSymbol <|> forallKeyword

with :: Parser ()
with = void "with"

showConstructor :: Parser ()
showConstructor = void "showConstructor"

builtin :: Parser Builtin
builtin =
        _NaturalFold
    <|> _NaturalBuild
    <|> _NaturalIsZero
    <|> _NaturalEven
    <|> _NaturalOdd
    <|> _NaturalToInteger
    <|> _NaturalShow
    <|> _IntegerToDouble
    <|> _IntegerShow
    <|> _IntegerNegate
    <|> _IntegerClamp
    <|> _NaturalSubtract
    <|> _DoubleShow
    <|> _ListBuild
    <|> _ListFold
    <|> _ListLength
    <|> _ListHead
    <|> _ListLast
    <|> _ListIndexed
    <|> _ListReverse
    <|> _TextShow
    <|> _TextReplace
    <|> _DateShow
    <|> _TimeShow
    <|> _TimeZoneShow
    <|> _Bool
    <|> _True
    <|> _False
    <|> _Optional
    <|> _None
    <|> _Natural
    <|> _Integer
    <|> _Double
    <|> _Text
    <|> _Bytes
    <|> _List
    <|> _Date
    <|> _TimeZone
    <|> _Time

_NaturalFold :: Parser Builtin
_NaturalFold = do "Natural/fold"; return NaturalFold

_NaturalBuild :: Parser Builtin
_NaturalBuild = do "Natural/build"; return NaturalBuild

_NaturalIsZero :: Parser Builtin
_NaturalIsZero = do "Natural/isZero"; return NaturalIsZero

_NaturalEven :: Parser Builtin
_NaturalEven = do "Natural/even"; return NaturalEven

_NaturalOdd :: Parser Builtin
_NaturalOdd = do "Natural/odd"; return NaturalOdd

_NaturalToInteger :: Parser Builtin
_NaturalToInteger = do "Natural/toInteger"; return NaturalToInteger

_NaturalShow :: Parser Builtin
_NaturalShow = do "Natural/show"; return NaturalShow

_IntegerToDouble :: Parser Builtin
_IntegerToDouble = do "Integer/toDouble"; return IntegerToDouble

_IntegerShow :: Parser Builtin
_IntegerShow = do "Integer/show"; return IntegerShow

_IntegerNegate :: Parser Builtin
_IntegerNegate = do "Integer/negate"; return IntegerNegate

_IntegerClamp :: Parser Builtin
_IntegerClamp = do "Integer/clamp"; return IntegerClamp

_NaturalSubtract :: Parser Builtin
_NaturalSubtract = do "Natural/subtract"; return NaturalSubtract

_DoubleShow :: Parser Builtin
_DoubleShow = do "Double/show"; return DoubleShow

_ListBuild :: Parser Builtin
_ListBuild = do "List/build"; return ListBuild

_ListFold :: Parser Builtin
_ListFold = do "List/fold"; return ListFold

_ListLength :: Parser Builtin
_ListLength = do "List/length"; return ListLength

_ListHead :: Parser Builtin
_ListHead = do "List/head"; return ListHead

_ListLast :: Parser Builtin
_ListLast = do "List/last"; return ListLast

_ListIndexed :: Parser Builtin
_ListIndexed = do "List/indexed"; return ListIndexed

_ListReverse :: Parser Builtin
_ListReverse = do "List/reverse"; return ListReverse

_TextShow :: Parser Builtin
_TextShow = do "Text/show"; return TextShow

_TextReplace :: Parser Builtin
_TextReplace = do "Text/replace"; return TextReplace

_DateShow :: Parser Builtin
_DateShow = do "Date/show"; return DateShow

_TimeShow :: Parser Builtin
_TimeShow = do "Time/show"; return TimeShow

_TimeZoneShow :: Parser Builtin
_TimeZoneShow = do "TimeZone/show"; return TimeZoneShow

_Bool :: Parser Builtin
_Bool = do "Bool"; return Bool

_True :: Parser Builtin
_True = do "True"; return Syntax.True

_False :: Parser Builtin
_False = do "False"; return Syntax.False

_Optional :: Parser Builtin
_Optional = do "Optional"; return Optional

_None :: Parser Builtin
_None = do "None"; return None

_Natural :: Parser Builtin
_Natural = do "Natural"; return Natural

_Integer :: Parser Builtin
_Integer = do "Integer"; return Integer

_Double :: Parser Builtin
_Double = do "Double"; return Double

_Text :: Parser Builtin
_Text = do "Text"; return Text

_Bytes :: Parser Builtin
_Bytes = do "Bytes"; return Bytes

_List :: Parser Builtin
_List = do "List"; return List

_Date :: Parser Builtin
_Date = do "Date"; return Date

_Time :: Parser Builtin
_Time = do "Time"; return Time

_TimeZone :: Parser Builtin
_TimeZone = do "TimeZone"; return TimeZone

_Location :: Parser ()
_Location = void "Location"

constant :: Parser Constant
constant =
        _Type
    <|> _Kind
    <|> _Sort

_Type :: Parser Constant
_Type = do "Type"; return Type

_Kind :: Parser Constant
_Kind = do "Kind"; return Kind

_Sort :: Parser Constant
_Sort = do "Sort"; return Sort

combine :: Parser Operator
combine = do "∧" <|> "/\\"; return CombineRecordTerms

combineTypes :: Parser Operator
combineTypes = do "⩓" <|> "//\\\\"; return CombineRecordTypes

equivalent :: Parser Operator
equivalent = do "≡" <|> "==="; return Equivalent

prefer :: Parser Operator
prefer = do "⫽" <|> "//"; return Prefer

lambda :: Parser ()
lambda = do "λ" <|> "\\"; return ()

arrow :: Parser ()
arrow = do "→" <|> "->"; return ()

complete :: Parser ()
complete = do "::"; return ()

sign :: Num n => Parser (n -> n)
sign = (do "+"; return id) <|> (do "-"; return negate)

exponent :: Parser Int
exponent = do
    "e"

    s <- sign <|> pure id

    digits <- atLeast 1 (satisfy digit)

    return (s (digits `base` 10))

numericDoubleLiteral :: Parser Double
numericDoubleLiteral = do
    s <- sign <|> pure id

    digits0 <- atLeast 1 (satisfy digit)

    let withRadix = do
            "."

            digits1 <- atLeast 1 (satisfy digit)

            e <- exponent <|> pure 0

            let c = s ((digits0 <> digits1) `base` 10)

            return (Scientific.toRealFloat (Scientific.scientific c (e - length digits1)))

    let withoutRadix = do
            e <- exponent

            let c = s (fromInteger (digits0 `base` 10))

            return (Scientific.toRealFloat (Scientific.scientific c e))

    withRadix <|> withoutRadix

minusInfinityLiteral :: Parser Double
minusInfinityLiteral = do
    "-"

    _Infinity

    return (-1/0)

plusInfinityLiteral :: Parser Double
plusInfinityLiteral = do
    _Infinity

    return (1/0)

doubleLiteral :: Parser Double
doubleLiteral =
        try minusInfinityLiteral
    <|> plusInfinityLiteral
    <|> (do _NaN; return (0/0))
    <|> numericDoubleLiteral

naturalLiteral :: Parser Natural
naturalLiteral = binary <|> hexadecimal <|> decimal <|> zero
  where
    binary = do
        "0b"

        digits <- atLeast 1 (satisfy $ between '0' '1')

        return (digits `base` 2)

    hexadecimal = do
        "0x"

        digits <- atLeast 1 (satisfy hexDig)

        return (digits `base` 16)

    decimal = do
        digit0 <- satisfy (between '1' '9')

        digits1 <- many (satisfy digit)

        return ((digit0 : digits1) `base` 10)

    zero = do
        "0"

        return 0

integerLiteral :: Parser Integer
integerLiteral = do
    s <- sign

    n <- naturalLiteral

    return (s (fromIntegral n))

temporalLiteral :: Parser Expression
temporalLiteral =
        try (do
            date <- fullDate

            "T" <|> "t"

            time <- partialTime

            timeZone <- timeOffset

            return
                (RecordLiteral
                    [   ("date"    , date)
                    ,   ("time"    , time)
                    ,   ("timeZone", timeZone)
                    ]
                )
        )
    <|> try (do
            date <- fullDate

            "T" <|> "t"

            time <- partialTime

            return
                (RecordLiteral
                    [   ("date", date)
                    ,   ("time", time)
                    ]
                )
        )
    <|> try (do
            time <- partialTime

            timeZone <- timeOffset

            return
                (RecordLiteral
                    [   ("time"    , time)
                    ,   ("timeZone", timeZone)
                    ]
                )
        )
    <|> try fullDate
    <|> try partialTime
    <|> try timeNumOffset


dateFullYear :: Parser Integer
dateFullYear = do
    digits <- replicateM 4 (satisfy digit)

    return (digits `base` 10)

dateMonth :: Parser Int
dateMonth = do
    digits <- replicateM 2 (satisfy digit)

    let month = digits `base` 10

    if 1 <= month && month <= 12
        then return month
        else fail "Invalid month"

dateMday :: Parser Int
dateMday = do
    digits <- replicateM 2 (satisfy digit)

    let day = digits `base` 10

    if 1 <= day && day <= 31
        then return day
        else fail "Invalid day"

timeHour :: Parser Int
timeHour = do
    digits <- replicateM 2 (satisfy digit)

    let hour = digits `base` 10

    if 0 <= hour && hour < 24
        then return hour
        else fail "Invalid hour"

timeMinute :: Parser Int
timeMinute = do
    digits <- replicateM 2 (satisfy digit)

    let minute = digits `base` 10

    if 0 <= minute && minute < 60
        then return minute
        else fail "Invalid minute"

timeSecond :: Parser Pico
timeSecond = do
    digits <- replicateM 2 (satisfy digit)

    let second = digits `base` 10

    if 0 <= second && second < 60
        then return second
        else fail "Invalid second"

timeSecFrac :: Parser (Pico, Int)
timeSecFrac = do
    "."

    digits <- some (satisfy digit)

    let precision = length digits

    return (fromRational ((digits `base` 10) % (10 ^ precision)), precision)

timeNumOffset :: Parser Expression
timeNumOffset = do
    s <- sign

    hour <- timeHour

    ":"

    minute <- timeMinute

    let minutes = s (hour * 60 + minute)

    return (TimeZoneLiteral (Time.TimeZone minutes Prelude.False ""))

timeOffset :: Parser Expression
timeOffset =
        (do "Z"

            return (TimeZoneLiteral (Time.TimeZone 0 Prelude.False ""))
        )
    <|> timeNumOffset

partialTime :: Parser Expression
partialTime = do
    hour <- timeHour

    ":"

    minute <- timeMinute

    ":"

    second <- timeSecond

    (fraction, precision) <- timeSecFrac <|> pure (0, 0)

    let time = Time.TimeOfDay hour minute (second + fraction)

    return (TimeLiteral time precision)

fullDate :: Parser Expression
fullDate = do
    year <- dateFullYear

    "-"

    month <- dateMonth

    "-"

    day <- dateMday

    case Time.fromGregorianValid year month day of
        Nothing -> fail "Invalid calendar day"
        Just d  -> return (DateLiteral d)

identifier :: Parser Expression
identifier = variable <|> fmap Constant constant <|> fmap Builtin builtin

variable :: Parser Expression
variable = do
    x <- nonreservedLabel

    n <- index <|> pure 0

    return (Variable x n)
  where
    index = do
        try (do whsp; "@")

        whsp

        naturalLiteral

pathCharacter :: Char -> Bool
pathCharacter c =
        c == '\x21'
    ||  between '\x24' '\x27' c
    ||  between '\x2A' '\x2B' c
    ||  between '\x2D' '\x2E' c
    ||  between '\x30' '\x3B' c
    ||  c == '\x3D'
    ||  between '\x40' '\x5A' c
    ||  between '\x5E' '\x7A' c
    ||  c == '\x7C'
    ||  c == '\x7E'

quotedPathCharacter :: Char -> Bool
quotedPathCharacter c =
        between '\x20' '\x21' c
    ||  between '\x23' '\x2E' c
    ||  between '\x30' '\x7F' c
    ||  validNonAscii c

unquotedPathComponent :: Parser Text
unquotedPathComponent = takeWhile1 pathCharacter

quotedPathComponent :: Parser Text
quotedPathComponent = takeWhile1 quotedPathCharacter

pathComponent :: Parser Text
pathComponent = do
    "/"

    let quoted = do
            "\""

            component <- quotedPathComponent

            "\""

            return component

    unquotedPathComponent <|> quoted

path_ :: Parser File
path_ = do
    components <- Combinators.NonEmpty.some pathComponent

    return (File (reverse (NonEmpty.init components)) (NonEmpty.last components))

local :: Parser ImportType
local = parentPath <|> herePath <|> homePath <|> absolutePath

parentPath :: Parser ImportType
parentPath = do
    ".."

    p <- path_

    return (Path Parent p)

herePath :: Parser ImportType
herePath = do
    "."

    p <- path_

    return (Path Here p)

homePath :: Parser ImportType
homePath = do
    "~"

    p <- path_

    return (Path Home p)

absolutePath :: Parser ImportType
absolutePath = do
    p <- path_

    return (Path Absolute p)

scheme_ :: Parser Scheme
scheme_ = do
    "http"

    let secure = do
            "s"

            return HTTPS

    secure <|> return HTTP

httpRaw :: Parser URL
httpRaw = do
    s <- scheme_

    "://"

    a <- authority_

    p <- pathAbempty

    q <- optional (do "?"; query_)

    return (URL s a p q)

pathAbempty :: Parser File
pathAbempty = do
    segments <- many (do "/"; segment)

    case segments of
        [] -> do
            return (File [] "")
        s : ss -> do
            let n = s :| ss

            return (File (reverse (NonEmpty.init n)) (NonEmpty.last n))

authority_ :: Parser Text
authority_ = do
    (try (userinfo <> "@") <|> "") <> host <> ((":" <> port) <|> "")

userinfo :: Parser Text
userinfo = do
    let character = do
            c <- satisfy (\c -> unreserved c || subDelims c || c == ':')

            return (Text.singleton c)

    texts <- many (character <|> pctEncoded)

    return (Text.concat texts)

host :: Parser Text
host = ipLiteral <|> try ipv4Address <|> domain

port :: Parser Text
port = takeWhile digit

ipLiteral :: Parser Text
ipLiteral = "[" <> (ipv6Address <|> ipvFuture) <> "]"

ipvFuture :: Parser Text
ipvFuture = do
        "v"
    <>  takeWhile1 hexDig
    <>  "."
    <>  takeWhile1 (\c -> unreserved c || subDelims c || c == ':')

ipv6Address :: Parser Text
ipv6Address =
        try option0
    <|> try option1
    <|> try option2
    <|> try option3
    <|> try option4
    <|> try option5
    <|> try option6
    <|> try option7
    <|> option8
  where
    option0 = do
        a <- replicateM 6 (h16 <> ":")

        b <- ls32

        return (Text.concat (a <> [ b ]))

    option1 = do
        a <- "::"

        b <- replicateM 5 (h16 <> ":")

        c <- ls32

        return (Text.concat ([ a ] <> b <> [ c ]))

    option2 = do
        a <- (h16 <|> "")

        b <- "::"

        c <- replicateM 4 (h16 <> ":")

        d <- ls32

        return (Text.concat ([ a, b ] <> c <> [ d ]))

    option3 = do
        let prefix = do
                a <- h16

                b <- atMost 1 (try (":" <> h16))

                return (Text.concat (a : b))

        a <- prefix <|> ""

        b <- "::"

        c <- replicateM 3 (h16 <> ":")

        d <- ls32

        return (Text.concat ([ a, b ] <> c <> [ d ]))

    option4 = do
        let prefix = do
                a <- h16

                b <- atMost 2 (try (":" <> h16))

                return (Text.concat (a : b))

        a <- prefix <|> ""

        b <- "::"

        c <- replicateM 2 (h16 <> ":")

        d <- ls32

        return (Text.concat ([ a, b ] <> c <> [ d ]))

    option5 = do
        let prefix = do
                a <- h16

                b <- atMost 3 (try (":" <> h16))

                return (Text.concat (a : b))

        (prefix <|> "") <> "::" <> h16 <> ":" <> ls32

    option6 = do
        let prefix = do
                a <- h16

                b <- atMost 4 (try (":" <> h16))

                return (Text.concat (a : b))

        (prefix <|> "") <> "::" <> ls32

    option7 = do
        let prefix = do
                a <- h16

                b <- atMost 5 (try (":" <> h16))

                return (Text.concat (a : b))

        (prefix <|> "") <> "::" <> h16

    option8 = do
        let prefix = do
                a <- h16

                b <- atMost 6 (try (":" <> h16))

                return (Text.concat (a : b))

        (prefix <|> "") <> "::"

h16 :: Parser Text
h16 = do
    a <- satisfy hexDig

    b <- atMost 3 (satisfy hexDig)

    return (Text.pack (a : b))

ls32 :: Parser Text
ls32 = try (h16 <> ":" <> h16) <|> ipv4Address

ipv4Address :: Parser Text
ipv4Address = decOctet <> "." <> decOctet <> "." <> decOctet <> "." <> decOctet

decOctet :: Parser Text
decOctet = do
        try beginsWith25
    <|> try beginsWith2
    <|> try beginsWith1
    <|> try twoDigits
    <|> oneDigit
  where
    beginsWith25 = do
        a <- "25"

        b <- satisfy (between '\x30' '\x35')

        return (a <> Text.singleton b)

    beginsWith2 = do
        a <- "2"

        b <- satisfy (between '\x30' '\x34')

        c <- satisfy digit

        return (a <> Text.singleton b <> Text.singleton c)

    beginsWith1 = do
        a <- "1"

        b <- replicateM 2 (satisfy digit)

        return (a <> Text.pack b)

    twoDigits = do
        a <- satisfy (between '\x31' '\x39')

        b <- satisfy digit

        return (Text.pack [a, b])

    oneDigit = do
        b <- satisfy digit

        return (Text.singleton b)

domain :: Parser Text
domain = do
    a <- domainlabel

    b <- many ("." <> domainlabel)

    c <- "." <|> ""

    return (a <> Text.concat b <> c)

domainlabel :: Parser Text
domainlabel = do
    a <- takeWhile1 alphaNum

    b <- many (takeWhile1 ('-' ==) <> takeWhile1 alphaNum)

    return (a <> Text.concat b)

segment :: Parser Text
segment = do
    a <- many pchar

    return (Text.concat a)

pchar :: Parser Text
pchar = character <|> pctEncoded
  where
    character = do
        c <- satisfy (\c -> unreserved c || subDelims c || c `elem` [ ':', '@' ])

        return (Text.singleton c)

query_ :: Parser Text
query_ = do
    let character = do
            c <- satisfy (\c -> c `elem` [ '/', '?' ])

            return (Text.singleton c)

    a <- many (pchar <|> character)

    return (Text.concat a)

pctEncoded :: Parser Text
pctEncoded = do
    a <- "%"

    b <- satisfy hexDig

    c <- satisfy hexDig

    return (a <> Text.pack [ b, c ])

unreserved :: Char -> Bool
unreserved c = alphaNum c || c `elem` [ '-', '.', '_', '~' ]

subDelims :: Char -> Bool
subDelims c = c `elem` [ '!', '$', '&', '\'', '*', '+', ';', '=' ]

http :: Parser ImportType
http = do
    url <- httpRaw

    headers <- optional do
        try (do whsp; using)

        whsp

        importExpression

    return (Remote url headers)

env :: Parser ImportType
env = do
    "env:"

    let posix = do
            "\""

            v <- posixEnvironmentVariable

            "\""

            return v

    v <- bashEnvironmentVariable <|> posix

    return (Env v)

bashEnvironmentVariable :: Parser Text
bashEnvironmentVariable = do
    a <- satisfy (\c -> alpha c || c == '_')

    b <- takeWhile1 (\c -> alphaNum c || c == '_')

    return (Text.cons a b)

posixEnvironmentVariable :: Parser Text
posixEnvironmentVariable = do
    a <- some posixEnvironmentVariableCharacter

    return (Text.pack a)

posixEnvironmentVariableCharacter :: Parser Char
posixEnvironmentVariableCharacter = do
    let escaped = do
            "\\"

            let remainder =
                         (do "\""; return '"' )
                    <|>  (do "\\"; return '\\')
                    <|>  (do "a" ; return '\a')
                    <|>  (do "b" ; return '\b')
                    <|>  (do "f" ; return '\f')
                    <|>  (do "n" ; return '\n')
                    <|>  (do "r" ; return '\r')
                    <|>  (do "t" ; return '\t')
                    <|>  (do "v" ; return '\v')

            remainder

    let unescaped c =
                between '\x20' '\x21' c
            ||  between '\x23' '\x3C' c
            ||  between '\x3E' '\x5B' c
            ||  between '\x5D' '\x7E' c

    escaped <|> satisfy unescaped

importType :: Parser ImportType
importType = missing <|> local <|> http <|> env

hash :: Parser (Digest SHA256)
hash = do
    "sha256:"

    hexDigits <- replicateM 64 (satisfy hexDig)

    let base16 = Text.Encoding.encodeUtf8 (Text.pack hexDigits)

    bytes <-  case ByteArray.Encoding.convertFromBase Base16 base16 of
        Left string -> fail string
        Right bytes -> return (bytes :: ByteString)

    case Hash.digestFromByteString bytes of
        Nothing -> fail "Invalid sha256 hash"
        Just h  -> return h

import_ :: Parser Expression
import_ = do
    i <- importType

    h <- optional (try (do whsp1; hash))

    let location = do
            try (do whsp; as; whsp1)

            (do _Text; return RawText) <|> (do _Location; return Location)

    l <- location <|> return Code

    return (Import i l h)

expression :: Parser Expression
expression =
        (do lambda

            whsp

            "("

            whsp

            x <- nonreservedLabel

            whsp

            ":"

            whsp1

            _A <- expression

            whsp

            ")"

            whsp

            arrow

            whsp

            _B <- expression

            return (Lambda x _A _B)
        )
    <|> (do if_

            whsp1

            a <- expression

            whsp

            then_

            whsp1

            b <- expression

            whsp

            else_

            whsp1

            c <- expression

            return (If a b c)
        )
    <|> (do bindings <- many letBinding

            in_

            whsp1

            b <- expression

            return (foldr (\(x, mA, a) -> Let x mA a) b bindings)
        )
    <|> (do forall_

            whsp

            "("

            whsp

            x <- nonreservedLabel

            whsp

            ":"

            whsp1

            _A <- expression

            whsp

            ")"

            whsp

            arrow

            whsp

            _B <- expression

            return (Forall x _A _B)
        )
    <|> try (do
            _A <- operatorExpression

            whsp

            arrow

            whsp

            _B <- expression

            return (Forall "_" _A _B)
        )
    <|> try withExpression
    <|> try (do
            merge

            whsp1

            a <- importExpression

            whsp1

            b <- importExpression

            whsp

            ":"

            whsp1

            c <- applicationExpression

            return (Merge a b (Just c))
        )
    <|> try emptyListLiteral
    <|> try (do
            toMap

            whsp1

            a <- importExpression

            whsp

            ":"

            whsp1

            b <- applicationExpression

            return (ToMap a (Just b))
        )
    <|> (do assert

            whsp

            ":"

            whsp1

            a <- expression

            return (Assert a)
        )
    <|> try (do
            showConstructor

            whsp1

            a <- importExpression

            return (ShowConstructor a)
        )
    <|> annotatedExpression

annotatedExpression :: Parser Expression
annotatedExpression = do
    a <- operatorExpression

    let annotation = do
            try (do whsp; ":")

            whsp1

            _A <- expression

            return (Annotation a _A)

    annotation <|> return a

letBinding :: Parser (Text, Maybe Expression, Expression)
letBinding = do
    let_

    whsp1

    x <- nonreservedLabel

    whsp

    mA <- optional do
        ":"

        whsp1

        _A <- expression

        whsp

        return _A

    "="

    whsp

    a <- expression

    whsp1

    return (x, mA, a)

emptyListLiteral :: Parser Expression
emptyListLiteral = do
    "["

    whsp

    optional (do ","; whsp)

    "]"

    whsp

    ":"

    whsp1

    _A <- applicationExpression

    return (EmptyList _A)

withExpression :: Parser Expression
withExpression = do
    a <- importExpression

    clauses <- Combinators.NonEmpty.some do
        try (do whsp1; with)

        whsp1

        withClause

    return (foldl (\e (ks, v) -> With e ks v) a clauses)

withClause :: Parser (NonEmpty PathComponent, Expression)
withClause = do
    k <- withComponent

    ks <- many (do try (do whsp; "."); whsp; withComponent)

    whsp

    "="

    whsp

    v <- operatorExpression

    return (k :| ks, v)

operatorExpression :: Parser Expression
operatorExpression = equivalentExpression

makeOperator :: Parser Operator -> Parser Expression -> Parser Expression
makeOperator parseOperator parseNext = do
    l0 <- parseNext

    fs <- many do
        operator <- try (do whsp; parseOperator)

        whsp

        r <- parseNext

        return (\l -> Operator l operator r)

    return (foldl (\l f -> f l) l0 fs)

makeOperator1 :: Parser Operator -> Parser Expression -> Parser Expression
makeOperator1 parseOperator parseNext = do
    l0 <- parseNext

    fs <- many do
        operator <- try (do whsp; parseOperator)

        whsp1

        r <- parseNext

        return (\l -> Operator l operator r)

    return (foldl (\l f -> f l) l0 fs)

equivalentExpression :: Parser Expression
equivalentExpression =
    makeOperator (do equivalent; return Equivalent) importAltExpression

importAltExpression :: Parser Expression
importAltExpression =
    makeOperator1 (do "?"; return Alternative) orExpression

orExpression :: Parser Expression
orExpression = makeOperator (do "||"; return Or) plusExpression

plusExpression :: Parser Expression
plusExpression = makeOperator1 (do "+"; return Plus) textAppendExpression

textAppendExpression :: Parser Expression
textAppendExpression =
    makeOperator (do "++"; return TextAppend) listAppendExpression

listAppendExpression :: Parser Expression
listAppendExpression =
    makeOperator (do "#"; return ListAppend) andExpression

andExpression :: Parser Expression
andExpression = makeOperator (do "&&"; return And) combineExpression

combineExpression :: Parser Expression
combineExpression =
    makeOperator (do combine; return CombineRecordTerms) preferExpression

preferExpression :: Parser Expression
preferExpression =
    makeOperator (do prefer; return Prefer) combineTypesExpression

combineTypesExpression :: Parser Expression
combineTypesExpression =
    makeOperator (do combineTypes; return CombineRecordTypes) timesExpression

timesExpression :: Parser Expression
timesExpression = makeOperator (do "*"; return Times) equalExpression

equalExpression :: Parser Expression
equalExpression =
    makeOperator (do "=="; notFollowedBy "="; return Equal) notEqualExpression

notEqualExpression :: Parser Expression
notEqualExpression =
    makeOperator (do "!="; return NotEqual) applicationExpression

applicationExpression :: Parser Expression
applicationExpression = do
    a <- firstApplicationExpression

    bs <- many (try (do whsp1; importExpression))

    return (foldl Application a bs)

firstApplicationExpression :: Parser Expression
firstApplicationExpression =
        (do merge

            whsp1

            a <- importExpression

            whsp1

            b <- importExpression

            return (Merge a b Nothing)
        )
    <|> (do _Some

            whsp1

            a <- importExpression

            return (Some a)
        )
    <|> (do toMap

            whsp1

            a <- importExpression

            return (ToMap a Nothing)
        )
    <|> importExpression

importExpression :: Parser Expression
importExpression = import_ <|> completionExpression

completionExpression :: Parser Expression
completionExpression = do
    a <- selectorExpression

    let selection = do
            try (do whsp; complete)

            whsp

            b <- selectorExpression

            return (Completion a b)

    selection <|> return a

selectorExpression :: Parser Expression
selectorExpression = do
    e0 <- primitiveExpression

    fs <- many (try (do whsp; "."; whsp; selector))

    return (foldl (\e f -> f e) e0 fs)

selector :: Parser (Expression -> Expression)
selector =
        (do x  <- anyLabel    ; return (\e -> Field           e x ))
    <|> (do ks <- labels      ; return (\e -> ProjectByLabels e ks))
    <|> (do t  <- typeSelector; return (\e -> ProjectByType   e t ))

labels :: Parser [Text]
labels = do
    "{"

    whsp

    optional (do ","; whsp)

    let nonEmpty = do
            k0 <- anyLabelOrSome

            whsp

            ks <- many do

                k <- try (do ","; whsp; anyLabelOrSome)

                whsp

                return k

            optional (do ","; whsp)

            return (k0 : ks)

    ks <- nonEmpty <|> pure []

    "}"

    return ks

typeSelector :: Parser Expression
typeSelector = do
    "("

    whsp

    e <- expression

    whsp

    ")"

    return e

primitiveExpression :: Parser Expression
primitiveExpression =
        temporalLiteral
    <|> (do n <- try doubleLiteral; return (DoubleLiteral n))
    <|> (do n <- try naturalLiteral; return (NaturalLiteral n))
    <|> (do n <- integerLiteral; return (IntegerLiteral n))
    <|> (do t <- textLiteral; return (TextLiteral t))
    <|> (do x <- bytesLiteral; return (BytesLiteral x))
    <|> (do "{"

            whsp

            optional (do ","; whsp)

            e <- recordTypeOrLiteral

            whsp

            "}"

            return e
        )
    <|> (do "<"

            whsp

            optional (do "|"; whsp)

            e <- unionType

            whsp

            ">"

            return e
        )
    <|> nonEmptyListLiteral
    <|> identifier
    <|> (do "("; e <- completeExpression; ")"; return e)

recordTypeOrLiteral :: Parser Expression
recordTypeOrLiteral =
        emptyRecordLiteral
    <|> nonEmptyRecordTypeOrLiteral
    <|> return (RecordType [])

emptyRecordLiteral :: Parser Expression
emptyRecordLiteral =
    do "="; optional (do try (do whsp; ",")); return (RecordLiteral [])

nonEmptyRecordTypeOrLiteral :: Parser Expression
nonEmptyRecordTypeOrLiteral = try nonEmptyRecordType <|> nonEmptyRecordLiteral

nonEmptyRecordType :: Parser Expression
nonEmptyRecordType = do
    kt <- recordTypeEntry

    kts <- many (try (do whsp; ","; whsp; recordTypeEntry))

    optional (try (do whsp; ","))

    return (RecordType (kt : kts))

recordTypeEntry :: Parser (Text, Expression)
recordTypeEntry = do
    k <- anyLabelOrSome

    whsp

    ":"

    whsp1

    t <- expression

    return (k, t)

nonEmptyRecordLiteral :: Parser Expression
nonEmptyRecordLiteral = do
    kv <- recordLiteralEntry

    kvs <- many (try (do whsp; ","; whsp; recordLiteralEntry))

    optional (try (do whsp; ","))

    let kvs' = Map.toList (Map.fromListWith combineRecordTerms (kv : kvs))
          where
            combineRecordTerms r l = Operator l CombineRecordTerms r

    return (RecordLiteral kvs')

recordLiteralEntry :: Parser (Text, Expression)
recordLiteralEntry = do
    k0 <- anyLabelOrSome

    let normalEntry = do
            (ks, v) <- recordLiteralNormalEntry

            return (k0, foldr (\k e -> RecordLiteral [(k, e)]) v ks)

    let punnedEntry = do
            return (k0, Variable k0 0)

    normalEntry <|> punnedEntry

recordLiteralNormalEntry :: Parser ([Text], Expression)
recordLiteralNormalEntry = do
    ks <- try do
        ks <- many (do try (do whsp; "."); anyLabelOrSome)

        whsp

        "="

        return ks

    whsp

    v <- expression

    return (ks, v)

unionType :: Parser Expression
unionType =
        (do kt <- unionTypeEntry

            kts <- many (try (do whsp; "|"; whsp; unionTypeEntry))

            optional (try (do whsp; "|"))

            return (UnionType (kt : kts))
        )
    <|> return (UnionType [])

unionTypeEntry :: Parser (Text, Maybe Expression)
unionTypeEntry = do
    k <- anyLabelOrSome

    t <- optional (do try (do whsp; ":"); whsp1; expression)

    return (k, t)

nonEmptyListLiteral :: Parser Expression
nonEmptyListLiteral = do
    "["

    whsp

    optional (do ","; whsp)

    e0 <- expression

    whsp

    es <- many (do e <- try (do ","; whsp; expression); whsp; return e)

    optional (do ","; whsp)

    "]"

    return (NonEmptyList (e0 :| es))

shebang :: Parser ()
shebang = do "#!"; many notEndOfLine; endOfLine; return ()

{-| Parse a complete Dhall expression, including leading and trailing
    whitespace
-}
completeExpression :: Parser Expression
completeExpression = do
    many shebang
    whsp
    e <- expression
    whsp
    _ <- optional lineCommentPrefix
    return e