Error.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}

-- |
-- Module      :  Disco.Error
-- Copyright   :  disco team and contributors
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Type for collecting all potential Disco errors at the top level,
-- and a type for runtime errors.
module Disco.Error (DiscoError (..), EvalError (..), panic, outputDiscoErrors) where

import Prelude hiding ((<>))

import Text.Megaparsec (
  ParseErrorBundle,
  errorBundlePretty,
 )
import Unbound.Generics.LocallyNameless (Name)

import Disco.Effects.LFresh
import Polysemy
import Polysemy.Error
import Polysemy.Output
import Polysemy.Reader

import Disco.Messages
import Disco.Names (ModuleName, QName)
import Disco.Parser (DiscoParseError)
import Disco.Pretty
import Disco.Typecheck.Solve
import Disco.Typecheck.Util (
  LocTCError (..),
  TCError (..),
 )
import Disco.Types
import Disco.Types.Qualifiers

-- | Top-level error type for Disco.
data DiscoError where
  -- | Module not found.
  ModuleNotFound :: String -> DiscoError
  -- | Cyclic import encountered.
  CyclicImport :: [ModuleName] -> DiscoError
  -- | Error encountered during typechecking.
  TypeCheckErr :: LocTCError -> DiscoError
  -- | Error encountered during parsing.
  ParseErr :: ParseErrorBundle String DiscoParseError -> DiscoError
  -- | Error encountered at runtime.
  EvalErr :: EvalError -> DiscoError
  -- | Something that shouldn't happen; indicates the presence of a
  --   bug.
  Panic :: String -> DiscoError
  deriving (Show)

-- | Errors that can be generated at runtime.
data EvalError where
  -- | An unbound name was encountered.
  UnboundError :: QName core -> EvalError
  -- | An unbound name that really shouldn't happen, coming from some
  --   kind of internal name generation scheme.
  UnboundPanic :: Name core -> EvalError
  -- | Division by zero.
  DivByZero :: EvalError
  -- | Overflow, e.g. (2^66)!
  Overflow :: EvalError
  -- | Non-exhaustive case analysis.
  NonExhaustive :: EvalError
  -- | Infinite loop detected via black hole.
  InfiniteLoop :: EvalError
  -- | User-generated crash.
  Crash :: String -> EvalError

deriving instance Show EvalError

panic :: Member (Error DiscoError) r => String -> Sem r a
panic = throw . Panic

outputDiscoErrors :: Member (Output (Message ann)) r => Sem (Error DiscoError ': r) () -> Sem r ()
outputDiscoErrors m = do
  e <- runError m
  either (err . pretty') return e

instance Pretty DiscoError where
  pretty = \case
    ModuleNotFound m -> "Error: couldn't find a module named '" <> text m <> "'."
    CyclicImport ms -> cyclicImportError ms
    TypeCheckErr (LocTCError Nothing te) -> prettyTCError te
    TypeCheckErr (LocTCError (Just n) te) ->
      nest 2 $
        vcat
          [ "While checking " <> pretty' n <> ":"
          , prettyTCError te
          ]
    ParseErr pe -> text (errorBundlePretty pe)
    EvalErr ee -> prettyEvalError ee
    Panic s ->
      vcat
        [ "Bug! " <> text s
        , "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
        ]

rtd :: String -> Sem r (Doc ann)
rtd page = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text page <> ".html"

-- issue :: Int -> Sem r (Doc ann)
-- issue n = "See https://github.com/disco-lang/disco/issues/" <> text (show n)

squote :: String -> String
squote x = "'" ++ x ++ "'"

cyclicImportError ::
  Members '[Reader PA, LFresh] r =>
  [ModuleName] ->
  Sem r (Doc ann)
cyclicImportError ms =
  nest 2 $
    vcat
      [ "Error: module imports form a cycle:"
      , intercalate " ->" (map pretty ms)
      ]

prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r (Doc ann)
prettyEvalError = \case
  UnboundPanic x ->
    ("Bug! No variable found named" <+> pretty' x <> ".")
      $+$ "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
  UnboundError x -> "Error: encountered undefined name" <+> pretty' x <> ". Maybe you haven't defined it yet?"
  DivByZero -> "Error: division by zero."
  Overflow -> "Error: that number would not even fit in the universe!"
  NonExhaustive -> "Error: value did not match any of the branches in a case expression."
  InfiniteLoop -> "Error: infinite loop detected!"
  Crash s -> "User crash:" <+> text s

-- [X] Step 1: nice error messages, make sure all are tested
-- [ ] Step 2: link to wiki/website with more info on errors!
-- [ ] Step 3: improve error messages according to notes below
-- [ ] Step 4: get it to return multiple error messages
-- [ ] Step 5: save parse locations, display with errors
prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r (Doc ann)
prettyTCError = \case
  -- XXX include some potential misspellings along with Unbound
  --   see https://github.com/disco-lang/disco/issues/180
  Unbound x suggestions ->
    vcat $
      ["Error: there is nothing named" <+> pretty' x <> "."]
        ++ ["Perhaps you meant" <+> intercalate " or" (map (text . squote) suggestions) <> "?" | not (null suggestions)]
        ++ [rtd "unbound"]
  Ambiguous x ms ->
    vcat
      [ "Error: the name" <+> pretty' x <+> "is ambiguous. It could refer to:"
      , indent 2 . vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms
      , rtd "ambiguous"
      ]
  NoType x ->
    vcat
      [ "Error: the definition of" <+> pretty' x <+> "must have an accompanying type signature."
      , "Try writing something like '"
          <> pretty' x
          <+> ": Int' (or whatever the type of"
          <+> pretty' x
          <+> "should be) first."
      , rtd "missingtype"
      ]
  NotCon c t ty ->
    vcat
      [ "Error: the expression"
      , indent 2 $ pretty' t
      , "must have both a" <+> conWord c <+> "type and also the incompatible type"
      , indent 2 $ pretty' ty <> "."
      , rtd "notcon"
      ]
  EmptyCase ->
    vcat
      [ "Error: empty case expressions {? ?} are not allowed."
      , rtd "empty-case"
      ]
  PatternType c pat ty ->
    vcat
      [ "Error: the pattern"
      , indent 2 $ pretty' pat
      , "is supposed to have type"
      , indent 2 $ pretty' ty <> ","
      , "but instead it has a" <+> conWord c <+> "type."
      , rtd "pattern-type"
      ]
  DuplicateDecls x ->
    vcat
      [ "Error: duplicate type signature for" <+> pretty' x <> "."
      , rtd "dup-sig"
      ]
  DuplicateDefns x ->
    vcat
      [ "Error: duplicate definition for" <+> pretty' x <> "."
      , rtd "dup-def"
      ]
  DuplicateTyDefns s ->
    vcat
      [ "Error: duplicate definition for type" <+> text s <> "."
      , rtd "dup-tydef"
      ]
  -- XXX include all types involved in the cycle.
  CyclicTyDef s ->
    vcat
      [ "Error: cyclic type definition for" <+> text s <> "."
      , rtd "cyc-ty"
      ]
  -- XXX lots more info!  & Split into several different errors.
  NumPatterns ->
    vcat
      [ "Error: number of arguments does not match."
      , rtd "num-args"
      ]
  NonlinearPattern p x ->
    vcat
      [ "Error: pattern" <+> pretty' p <+> "contains duplicate variable" <+> pretty' x <> "."
      , rtd "nonlinear"
      ]
  NoSearch ty ->
    vcat
      [ "Error: the type"
      , indent 2 $ pretty' ty
      , "is not searchable (i.e. it cannot be used in a forall)."
      , rtd "no-search"
      ]
  Unsolvable solveErr -> prettySolveError solveErr
  -- XXX maybe include close edit-distance alternatives?
  NotTyDef s ->
    vcat
      [ "Error: there is no built-in or user-defined type named '" <> text s <> "'."
      , rtd "no-tydef"
      ]
  NoTWild ->
    vcat
      [ "Error: wildcards (_) are not allowed in expressions."
      , rtd "wildcard-expr"
      ]
  -- XXX say how many are expected, how many there were, what the actual arguments were?
  -- XXX distinguish between built-in and user-supplied type constructors in the error
  --     message?
  NotEnoughArgs con ->
    vcat
      [ "Error: not enough arguments for the type '" <> pretty' con <> "'."
      , rtd "num-args-type"
      ]
  TooManyArgs con ->
    vcat
      [ "Error: too many arguments for the type '" <> pretty' con <> "'."
      , rtd "num-args-type"
      ]
  -- XXX Mention the definition in which it was found
  UnboundTyVar v suggestions ->
    vcat $
      ["Error: Unknown type variable '" <> pretty' v <> "'."]
        ++ ["Perhaps you meant" <+> intercalate " or" (map (text . squote) suggestions) <> "?" | not (null suggestions)]
        ++ [rtd "unbound-tyvar"]
  NoPolyRec s ss tys ->
    vcat
      [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments."
      , indent
          2
          ( text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule."
          )
      , rtd "no-poly-rec"
      ]
  NoError -> empty

conWord :: Con -> Sem r (Doc ann)
conWord = \case
  CArr -> "function"
  CProd -> "pair"
  CSum -> "sum"
  CSet -> "set"
  CBag -> "bag"
  CList -> "list"
  CContainer _ -> "container"
  CMap -> "map"
  CGraph -> "graph"
  CUser s -> text s

prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r (Doc ann)
prettySolveError = \case
  -- XXX say which types!
  NoWeakUnifier ->
    vcat
      [ "Error: the shape of two types does not match."
      , rtd "shape-mismatch"
      ]
  -- XXX say more!  XXX HIGHEST PRIORITY!
  NoUnify ->
    vcat
      [ "Error: typechecking failed."
      , rtd "typecheck-fail"
      ]
  UnqualBase q b ->
    vcat
      [ "Error: values of type" <+> pretty' b <+> qualPhrase False q <> "."
      , rtd "not-qual"
      ]
  Unqual q ty ->
    vcat
      [ "Error: values of type" <+> pretty' ty <+> qualPhrase False q <> "."
      , rtd "not-qual"
      ]
  QualSkolem q a ->
    vcat
      [ "Error: type variable" <+> pretty' a <+> "represents any type, so we cannot assume values of that type"
      , indent 2 (qualPhrase True q) <> "."
      , rtd "qual-skolem"
      ]

qualPhrase :: Bool -> Qualifier -> Sem r (Doc ann)
qualPhrase b q
  | q `elem` [QBool, QBasic, QSimple] = "are" <+> (if b then empty else "not") <+> qualAction q
  | otherwise = "can" <> (if b then empty else "not") <+> "be" <+> qualAction q

qualAction :: Qualifier -> Sem r (Doc ann)
qualAction = \case
  QNum -> "added and multiplied"
  QSub -> "subtracted"
  QDiv -> "divided"
  QCmp -> "compared"
  QEnum -> "enumerated"
  QBool -> "boolean"
  QBasic -> "basic"
  QSimple -> "simple"