quox/lib/Quox/Parser/FromParser/Error.idr

module Quox.Parser.FromParser.Error

import Quox.Parser.Parser
import Quox.Parser.LoadFile
import Quox.Typing
import System.File

import Quox.Pretty

%default total

%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)


public export
TypeError, LexError, ParseError : Type
TypeError = Typing.Error
LexError = Lexer.Error
ParseError = Parser.Error
%hide Typing.Error
%hide Lexer.Error
%hide Parser.Error

public export
data Error =
    AnnotationNeeded Loc (NameContexts d n) (Term d n)
  | DuplicatesInEnumType Loc (List TagVal)
  | DuplicatesInEnumCase Loc (List TagVal)
  | TermNotInScope Loc Name
  | DimNotInScope Loc PBaseName
  | QtyNotGlobal Loc Qty
  | DimNameInTerm Loc PBaseName
  | DisplacedBoundVar Loc PName
  | WrapTypeError TypeError
  | AlreadyExists Loc Name
  | LoadError Loc FilePath FileError
  | ExpectedFail Loc
  | SchemeOnNamespace Loc Mods
  | MainOnNamespace Loc Mods
  | WrongFail String Error Loc
  | WrapParseError String ParseError


export
prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
prettyLexError file (Err reason line col char) = do
  reason <- case reason of
    Other msg => pure $ text msg
    NoRuleApply => case char of
      Just char => pure $ text "unrecognised character: \{show char}"
      Nothing   => pure $ text "unexpected end of input"
    ComposeNotClosing (sl, sc) (el, ec) => pure $
      hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
  let loc = makeLoc file (MkBounds line col line col)
  pure $ vappend !(prettyLoc loc) reason

export
prettyParseError1 : {opts : _} -> String -> ParsingError _ ->
                    Eff Pretty (Doc opts)
prettyParseError1 file (Error msg Nothing) =
  pure $ text msg
prettyParseError1 file (Error msg (Just bounds)) =
  pure $ vappend !(prettyLoc $ makeLoc file bounds) (text msg)

export
prettyParseError : {opts : _} -> String -> ParseError ->
                   Eff Pretty (Doc opts)
prettyParseError file (LexError err) =
  pure $ vsep ["lexical error:", !(prettyLexError file err)]
prettyParseError file (ParseError errs) =
  map (vsep . ("parse error:" ::)) $
    traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)


parameters {opts : LayoutOpts} (showContext : Bool)
  export
  prettyError : Error -> Eff Pretty (Doc opts)
  prettyError (AnnotationNeeded loc ctx tm) =
    [|vappend (prettyLoc loc)
        (hangD "type annotation needed on"
               !(prettyTerm ctx.dnames ctx.tnames tm))|]
    -- [todo] print the original PTerm instead

  prettyError (DuplicatesInEnumType loc tags) =
    [|vappend (prettyLoc loc)
        (hangD "duplicate tags in enum type" !(prettyEnum tags))|]

  prettyError (DuplicatesInEnumCase loc tags) =
    [|vappend (prettyLoc loc)
        (hangD "duplicate arms in enum case" !(prettyEnum tags))|]

  prettyError (DimNotInScope loc i) =
    [|vappend (prettyLoc loc)
        (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]

  prettyError (TermNotInScope loc x) =
    [|vappend (prettyLoc loc)
        (pure $ hsep ["term variable", !(prettyFree x), "not in scope"])|]

  prettyError (QtyNotGlobal loc pi) = pure $
    vappend !(prettyLoc loc)
      (sep ["quantity" <++> !(prettyQty pi),
            "can't be used on a top level declaration"])

  prettyError (DimNameInTerm loc i) = pure $
    vappend !(prettyLoc loc)
      (sep ["dimension" <++> !(hl DVar $ text i),
            "used in a term context"])

  prettyError (DisplacedBoundVar loc x) = pure $
    vappend !(prettyLoc loc)
      (sep ["local variable" <++> !(hl TVar $ text $ toDotsP x),
            "cannot be displaced"])

  prettyError (WrapTypeError err) =
    Typing.prettyError showContext $ trimContext 2 err

  prettyError (AlreadyExists loc name) = pure $
    vsep [!(prettyLoc loc),
          sep [!(prettyFree name), "has already been defined"]]

  prettyError (LoadError loc file err) = pure $
    vsep [!(prettyLoc loc),
          "couldn't load file" <++> text file,
          text $ show err]

  prettyError (ExpectedFail loc) = pure $
    vsep [!(prettyLoc loc), "expected error"]

  prettyError (SchemeOnNamespace loc ns) = pure $
    vsep [!(prettyLoc loc),
          hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
                "cannot have #[compile-scheme] attached"]]

  prettyError (MainOnNamespace loc ns) = pure $
    vsep [!(prettyLoc loc),
          hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
                "cannot have #[main] attached"]]

  prettyError (WrongFail str err loc) = pure $
    vsep [!(prettyLoc loc),
          "wrong error, expected to match", !(hl Tag $ text "\"\{str}\""),
          "but got", !(prettyError err)]

  prettyError (WrapParseError file err) =
    prettyParseError file err