{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

-- I generally try to avoid modules full of (only) types but these are here
-- so the can be shared in both Technique.Translate and Technique.Builtins.

-- |
-- Error messages from compiling.
module Technique.Failure where

import Core.System.Base
import Core.System.Pretty
import Core.Text.Rope
import Core.Text.Utilities
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as OrdSet
import qualified Data.Text as T
import Data.Void
import Technique.Formatter
import Technique.Language hiding (Label)
import Text.Megaparsec (PosState (..), SourcePos (..))
import Text.Megaparsec.Error
  ( ErrorItem (..),
    ParseError (..),
    ParseErrorBundle (..),
  )
import Text.Megaparsec.Pos (unPos)
import Prelude hiding (lines)

data Status = Ok | Failed CompilationError | Reload

instance Render Status where
  type Token Status = TechniqueToken
  colourize :: Token Status -> AnsiColour
colourize = Token Status -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Status -> Doc (Token Status)
highlight Status
status = case Status
status of
    Status
Ok -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
LabelToken Doc TechniqueToken
"ok"
    Failed CompilationError
e -> CompilationError -> Doc (Token CompilationError)
forall α. Render α => α -> Doc (Token α)
highlight CompilationError
e
    Status
Reload -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
MagicToken Doc TechniqueToken
"Δ"

data Source = Source
  { Source -> Rope
sourceContents :: Rope,
    Source -> FilePath
sourceFilename :: FilePath,
    Source -> Offset
sourceOffset :: !Offset
  }
  deriving (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Eq Source
Eq Source
-> (Source -> Source -> Ordering)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Source)
-> (Source -> Source -> Source)
-> Ord Source
Source -> Source -> Bool
Source -> Source -> Ordering
Source -> Source -> Source
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Source -> Source -> Source
$cmin :: Source -> Source -> Source
max :: Source -> Source -> Source
$cmax :: Source -> Source -> Source
>= :: Source -> Source -> Bool
$c>= :: Source -> Source -> Bool
> :: Source -> Source -> Bool
$c> :: Source -> Source -> Bool
<= :: Source -> Source -> Bool
$c<= :: Source -> Source -> Bool
< :: Source -> Source -> Bool
$c< :: Source -> Source -> Bool
compare :: Source -> Source -> Ordering
$ccompare :: Source -> Source -> Ordering
$cp1Ord :: Eq Source
Ord, Offset -> Source -> ShowS
[Source] -> ShowS
Source -> FilePath
(Offset -> Source -> ShowS)
-> (Source -> FilePath) -> ([Source] -> ShowS) -> Show Source
forall a.
(Offset -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> FilePath
$cshow :: Source -> FilePath
showsPrec :: Offset -> Source -> ShowS
$cshowsPrec :: Offset -> Source -> ShowS
Show)

instance Located Source where
  locationOf :: Source -> Offset
locationOf = Source -> Offset
sourceOffset

instance Render Source where
  type Token Source = TechniqueToken
  colourize :: Token Source -> AnsiColour
colourize = Token Source -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: Source -> Doc (Token Source)
highlight Source
source = FilePath -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Source -> FilePath
sourceFilename Source
source) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Offset -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Source -> Offset
sourceOffset Source
source)

emptySource :: Source
emptySource :: Source
emptySource =
  Source :: Rope -> FilePath -> Offset -> Source
Source
    { sourceContents :: Rope
sourceContents = Rope
emptyRope,
      sourceFilename :: FilePath
sourceFilename = FilePath
"<undefined>",
      sourceOffset :: Offset
sourceOffset = -Offset
1
    }

data FailureReason
  = InvalidSetup -- TODO placeholder
  | ParsingFailed [ErrorItem Char] [ErrorItem Char]
  | VariableAlreadyInUse Identifier
  | ProcedureAlreadyDeclared Identifier
  | CallToUnknownProcedure Identifier
  | UseOfUnknownIdentifier Identifier
  | EncounteredUndefined
  deriving (Offset -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> FilePath
(Offset -> FailureReason -> ShowS)
-> (FailureReason -> FilePath)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
forall a.
(Offset -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> FilePath
$cshow :: FailureReason -> FilePath
showsPrec :: Offset -> FailureReason -> ShowS
$cshowsPrec :: Offset -> FailureReason -> ShowS
Show, FailureReason -> FailureReason -> Bool
(FailureReason -> FailureReason -> Bool)
-> (FailureReason -> FailureReason -> Bool) -> Eq FailureReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureReason -> FailureReason -> Bool
$c/= :: FailureReason -> FailureReason -> Bool
== :: FailureReason -> FailureReason -> Bool
$c== :: FailureReason -> FailureReason -> Bool
Eq)

instance Enum FailureReason where
  fromEnum :: FailureReason -> Offset
fromEnum FailureReason
x = case FailureReason
x of
    FailureReason
InvalidSetup -> Offset
1
    ParsingFailed [ErrorItem Char]
_ [ErrorItem Char]
_ -> Offset
2
    VariableAlreadyInUse Identifier
_ -> Offset
3
    ProcedureAlreadyDeclared Identifier
_ -> Offset
4
    CallToUnknownProcedure Identifier
_ -> Offset
5
    UseOfUnknownIdentifier Identifier
_ -> Offset
6
    FailureReason
EncounteredUndefined -> Offset
7
  toEnum :: Offset -> FailureReason
toEnum = Offset -> FailureReason
forall a. HasCallStack => a
undefined

data CompilationError = CompilationError Source FailureReason
  deriving (Offset -> CompilationError -> ShowS
[CompilationError] -> ShowS
CompilationError -> FilePath
(Offset -> CompilationError -> ShowS)
-> (CompilationError -> FilePath)
-> ([CompilationError] -> ShowS)
-> Show CompilationError
forall a.
(Offset -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CompilationError] -> ShowS
$cshowList :: [CompilationError] -> ShowS
show :: CompilationError -> FilePath
$cshow :: CompilationError -> FilePath
showsPrec :: Offset -> CompilationError -> ShowS
$cshowsPrec :: Offset -> CompilationError -> ShowS
Show)

instance Exception CompilationError

exitCodeFor :: CompilationError -> Int
exitCodeFor :: CompilationError -> Offset
exitCodeFor (CompilationError Source
_ FailureReason
reason) = FailureReason -> Offset
forall a. Enum a => a -> Offset
fromEnum FailureReason
reason

-- TODO upgrade this to (Doc ann) so we can get prettier error messages.

instance Render FailureReason where
  type Token FailureReason = TechniqueToken
  colourize :: Token FailureReason -> AnsiColour
colourize = Token FailureReason -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: FailureReason -> Doc (Token FailureReason)
highlight FailureReason
failure = case FailureReason
failure of
    FailureReason
InvalidSetup -> Doc (Token FailureReason)
"Invalid setup!"
    ParsingFailed [ErrorItem Char]
unexpected [ErrorItem Char]
expected ->
      let un :: Doc TechniqueToken
un = case [ErrorItem Char]
unexpected of
            [] -> Doc TechniqueToken
forall ann. Doc ann
emptyDoc
            (ErrorItem Char
item : [ErrorItem Char]
_) -> Doc TechniqueToken
"unexpected " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> ErrorItem Char -> Doc TechniqueToken
formatErrorItem TechniqueToken
FilenameToken ErrorItem Char
item Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          ex :: Doc TechniqueToken
ex = case [ErrorItem Char]
expected of
            [] -> Doc TechniqueToken
forall ann. Doc ann
emptyDoc
            [ErrorItem Char]
items -> Doc TechniqueToken
"expecting " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> [Doc TechniqueToken] -> Doc TechniqueToken
forall ann. [Doc ann] -> Doc ann
fillCat ([Doc TechniqueToken] -> [Doc TechniqueToken]
forall ann. [Doc ann] -> [Doc ann]
fancyPunctuate ((ErrorItem Char -> Doc TechniqueToken)
-> [ErrorItem Char] -> [Doc TechniqueToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TechniqueToken -> ErrorItem Char -> Doc TechniqueToken
formatErrorItem TechniqueToken
SymbolToken) [ErrorItem Char]
items)) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"."
       in Doc TechniqueToken
un Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
ex
    VariableAlreadyInUse Identifier
i -> Doc TechniqueToken
"Variable by the name of '" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
VariableToken (Identifier -> Doc (Token Identifier)
forall α. Render α => α -> Doc (Token α)
highlight Identifier
i) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"' already defined."
    ProcedureAlreadyDeclared Identifier
i -> Doc TechniqueToken
"Procedure by the name of '" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ProcedureToken (Identifier -> Doc (Token Identifier)
forall α. Render α => α -> Doc (Token α)
highlight Identifier
i) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"' already declared."
    CallToUnknownProcedure Identifier
i -> Doc TechniqueToken
"Call to unknown procedure '" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ApplicationToken (Identifier -> Doc (Token Identifier)
forall α. Render α => α -> Doc (Token α)
highlight Identifier
i) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"'."
    UseOfUnknownIdentifier Identifier
i -> Doc TechniqueToken
"Variable '" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
VariableToken (Identifier -> Doc (Token Identifier)
forall α. Render α => α -> Doc (Token α)
highlight Identifier
i) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"' not in scope."
    FailureReason
EncounteredUndefined -> Doc TechniqueToken
"Encountered an " Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken Doc TechniqueToken
"undefined" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
" marker."

fancyPunctuate :: [Doc ann] -> [Doc ann]
fancyPunctuate :: [Doc ann] -> [Doc ann]
fancyPunctuate [Doc ann]
list = case [Doc ann]
list of
  [] -> []
  [Doc ann
x] -> [Doc ann
x]
  (Doc ann
x1 : Doc ann
x2 : []) -> Doc ann
x1 Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Doc ann
", or " Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Doc ann
x2 Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: []
  (Doc ann
x1 : [Doc ann]
xs) -> Doc ann
x1 Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Doc ann
", " Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann] -> [Doc ann]
forall ann. [Doc ann] -> [Doc ann]
fancyPunctuate [Doc ann]
xs

-- |
-- ErrorItem is a bit overbearing, but we handle its /four/ cases by saying
-- single quotes around characters, double quotes around strings, /no/ quotes
-- around labels (descriptive text) and hard code the end of input and newline
-- cases.
formatErrorItem :: TechniqueToken -> ErrorItem Char -> Doc TechniqueToken
formatErrorItem :: TechniqueToken -> ErrorItem Char -> Doc TechniqueToken
formatErrorItem TechniqueToken
token ErrorItem Char
item = case ErrorItem Char
item of
  -- It would appear that **prettyprinter** has a Pretty instance for
  -- NonEmpty a. In this case token ~ Char so these are Strings, ish.
  -- Previously we converted to Rope, but looks like we can go directly.

  Tokens NonEmpty Char
tokens ->
    case NonEmpty Char -> (Char, Maybe (NonEmpty Char))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NonEmpty.uncons NonEmpty Char
tokens of
      (Char
ch, Maybe (NonEmpty Char)
Nothing) -> case Char
ch of
        Char
'\n' -> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
token Doc TechniqueToken
"newline"
        Char
_ -> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'\'' Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
token (Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
ch) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'\''
      (Char, Maybe (NonEmpty Char))
_ -> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'\"' Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
token (NonEmpty Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty NonEmpty Char
tokens) Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Char
'\"'
  Label NonEmpty Char
chars ->
    TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
token (NonEmpty Char -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty NonEmpty Char
chars)
  ErrorItem Char
EndOfInput ->
    Doc TechniqueToken
"end of input"

numberOfCarots :: FailureReason -> Int
numberOfCarots :: FailureReason -> Offset
numberOfCarots FailureReason
reason = case FailureReason
reason of
  FailureReason
InvalidSetup -> Offset
0
  ParsingFailed [ErrorItem Char]
unexpected [ErrorItem Char]
_ -> case [ErrorItem Char]
unexpected of
    [] -> Offset
1
    (ErrorItem Char
item : [ErrorItem Char]
_) -> case ErrorItem Char
item of
      Tokens NonEmpty Char
tokens -> NonEmpty Char -> Offset
forall a. NonEmpty a -> Offset
NonEmpty.length NonEmpty Char
tokens
      Label NonEmpty Char
chars -> NonEmpty Char -> Offset
forall a. NonEmpty a -> Offset
NonEmpty.length NonEmpty Char
chars
      ErrorItem Char
EndOfInput -> Offset
1
  VariableAlreadyInUse Identifier
i -> Rope -> Offset
widthRope (Identifier -> Rope
unIdentifier Identifier
i)
  ProcedureAlreadyDeclared Identifier
i -> Rope -> Offset
widthRope (Identifier -> Rope
unIdentifier Identifier
i)
  CallToUnknownProcedure Identifier
i -> Rope -> Offset
widthRope (Identifier -> Rope
unIdentifier Identifier
i)
  UseOfUnknownIdentifier Identifier
i -> Rope -> Offset
widthRope (Identifier -> Rope
unIdentifier Identifier
i)
  FailureReason
EncounteredUndefined -> Offset
1

instance Render CompilationError where
  type Token CompilationError = TechniqueToken
  colourize :: Token CompilationError -> AnsiColour
colourize = Token CompilationError -> AnsiColour
TechniqueToken -> AnsiColour
colourizeTechnique
  highlight :: CompilationError -> Doc (Token CompilationError)
highlight (CompilationError Source
source FailureReason
reason) =
    let filename :: Doc TechniqueToken
filename = FilePath -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Source -> FilePath
sourceFilename Source
source)
        contents :: Rope
contents = Rope -> Rope
forall α. Textual α => α -> Rope
intoRope (Source -> Rope
sourceContents Source
source)
        o :: Offset
o = Source -> Offset
sourceOffset Source
source
        -- Given an offset point where the error occured, split the input at that
        -- point.

        (Rope
before, Rope
_) = Offset -> Rope -> (Rope, Rope)
splitRope Offset
o Rope
contents
        (Offset
l, Offset
c) = Rope -> (Offset, Offset)
calculatePositionEnd Rope
before
        -- Isolate the line on which the error occured. l and c are 1-origin here,
        -- so if there's only a single line (or empty file) we take that one single
        -- line and then last one is also that line.

        lines :: [Rope]
lines = Rope -> [Rope]
breakLines Rope
contents
        lines' :: [Rope]
lines' = Offset -> [Rope] -> [Rope]
forall a. Offset -> [a] -> [a]
take Offset
l [Rope]
lines
        offending :: Rope
offending =
          if Rope -> Bool
nullRope Rope
contents
            then Rope
emptyRope
            else [Rope] -> Rope
forall a. [a] -> a
last [Rope]
lines'
        -- Now prepare for rendering. If the offending line is long trim it. Then
        -- create a line with some carets which show where the problem is.

        linenum :: Doc TechniqueToken
linenum = Offset -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Offset
l
        colunum :: Doc TechniqueToken
colunum = Offset -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Offset
c
        (Rope
truncated, Rope
_) = Offset -> Rope -> (Rope, Rope)
splitRope Offset
77 Rope
offending
        trimmed :: Rope
trimmed =
          if Rope -> Offset
widthRope Rope
offending Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
77 Bool -> Bool -> Bool
&& Offset
c Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
< Offset
77
            then Rope
truncated Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"..."
            else Rope
offending
        padding :: Rope
padding = Offset -> Char -> Rope
replicateChar (Offset
c Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
1) Char
' '
        num :: Offset
num = FailureReason -> Offset
numberOfCarots FailureReason
reason
        caroted :: Rope
caroted = Offset -> Char -> Rope
replicateChar Offset
num Char
'^'
        columns :: Doc TechniqueToken
columns =
          if Offset
num Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
1
            then Doc TechniqueToken
colunum Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
"-" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Offset -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty (Offset
c Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
num Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
1)
            else Doc TechniqueToken
colunum
     in TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
FilenameToken Doc TechniqueToken
filename Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
":" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
linenum Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
":" Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
columns Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
trimmed
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
padding
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall ann. ann -> Doc ann -> Doc ann
annotate TechniqueToken
ErrorToken (Rope -> Doc TechniqueToken
forall a ann. Pretty a => a -> Doc ann
pretty Rope
caroted)
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> Doc TechniqueToken
forall ann. Doc ann
hardline
          Doc TechniqueToken -> Doc TechniqueToken -> Doc TechniqueToken
forall a. Semigroup a => a -> a -> a
<> FailureReason -> Doc (Token FailureReason)
forall α. Render α => α -> Doc (Token α)
highlight FailureReason
reason

-- |
-- When we get a failure in the parsing stage **megaparsec** returns a
-- ParseErrorBundle. Extract the first error message therein (later handle
-- more? Yeah nah), and convert it into something we can use.
extractErrorBundle :: Source -> ParseErrorBundle T.Text Void -> CompilationError
extractErrorBundle :: Source -> ParseErrorBundle Text Void -> CompilationError
extractErrorBundle Source
source ParseErrorBundle Text Void
bundle =
  let errors :: NonEmpty (ParseError Text Void)
errors = ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors ParseErrorBundle Text Void
bundle
      first :: ParseError Text Void
first = NonEmpty (ParseError Text Void) -> ParseError Text Void
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (ParseError Text Void)
errors
      (Offset
o, [ErrorItem Char]
unexpected, [ErrorItem Char]
expected) = ParseError Text Void
-> (Offset, [ErrorItem Char], [ErrorItem Char])
extractParseError ParseError Text Void
first
      pstate :: PosState Text
pstate = ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
bundlePosState ParseErrorBundle Text Void
bundle
      srcpos :: SourcePos
srcpos = PosState Text -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState Text
pstate
      l0 :: Offset
l0 = Pos -> Offset
unPos (Pos -> Offset) -> (SourcePos -> Pos) -> SourcePos -> Offset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine (SourcePos -> Offset) -> SourcePos -> Offset
forall a b. (a -> b) -> a -> b
$ SourcePos
srcpos
      c0 :: Offset
c0 = Pos -> Offset
unPos (Pos -> Offset) -> (SourcePos -> Pos) -> SourcePos -> Offset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn (SourcePos -> Offset) -> SourcePos -> Offset
forall a b. (a -> b) -> a -> b
$ SourcePos
srcpos
      -- Do we need these? For all the examples we have seen the values of l0 and c0
      -- are `1`. **megaparsec** delays calculation of line and column until
      -- error rendering time. Perhaps we need to record this.

      l :: Offset
l = if Offset
l0 Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
1 then FilePath -> Offset
forall a. HasCallStack => FilePath -> a
error FilePath
"Unexpected line balance" else Offset
0
      c :: Offset
c = if Offset
c0 Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
1 then FilePath -> Offset
forall a. HasCallStack => FilePath -> a
error FilePath
"Unexpected columns balance" else Offset
0
      reason :: FailureReason
reason = [ErrorItem Char] -> [ErrorItem Char] -> FailureReason
ParsingFailed [ErrorItem Char]
unexpected [ErrorItem Char]
expected
      source' :: Source
source' =
        Source
source
          { sourceOffset :: Offset
sourceOffset = Offset
o Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
l Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
c
          }
   in Source -> FailureReason -> CompilationError
CompilationError Source
source' FailureReason
reason

extractParseError :: ParseError T.Text Void -> (Int, [ErrorItem Char], [ErrorItem Char])
extractParseError :: ParseError Text Void
-> (Offset, [ErrorItem Char], [ErrorItem Char])
extractParseError ParseError Text Void
e = case ParseError Text Void
e of
  TrivialError Offset
o Maybe (ErrorItem (Token Text))
unexpected0 Set (ErrorItem (Token Text))
expected0 ->
    let unexpected :: [ErrorItem Char]
unexpected = case Maybe (ErrorItem (Token Text))
unexpected0 of
          Just ErrorItem (Token Text)
item -> ErrorItem Char
ErrorItem (Token Text)
item ErrorItem Char -> [ErrorItem Char] -> [ErrorItem Char]
forall a. a -> [a] -> [a]
: []
          Maybe (ErrorItem (Token Text))
Nothing -> []
        expected :: [ErrorItem Char]
expected = Set (ErrorItem Char) -> [ErrorItem Char]
forall a. Set a -> [a]
OrdSet.toList Set (ErrorItem Char)
Set (ErrorItem (Token Text))
expected0
     in (Offset
o, [ErrorItem Char]
unexpected, [ErrorItem Char]
expected)
  FancyError Offset
_ Set (ErrorFancy Void)
_ -> FilePath -> (Offset, [ErrorItem Char], [ErrorItem Char])
forall a. HasCallStack => FilePath -> a
error FilePath
"Unexpected parser error"