{-# 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 Int -> DiscoError -> ShowS
[DiscoError] -> ShowS
DiscoError -> String
(Int -> DiscoError -> ShowS)
-> (DiscoError -> String)
-> ([DiscoError] -> ShowS)
-> Show DiscoError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiscoError] -> ShowS
$cshowList :: [DiscoError] -> ShowS
show :: DiscoError -> String
$cshow :: DiscoError -> String
showsPrec :: Int -> DiscoError -> ShowS
$cshowsPrec :: Int -> DiscoError -> ShowS
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 :: String -> Sem r a
panic = DiscoError -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (DiscoError -> Sem r a)
-> (String -> DiscoError) -> String -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DiscoError
Panic

outputDiscoErrors :: Member (Output Message) r => Sem (Error DiscoError ': r) () -> Sem r ()
outputDiscoErrors :: Sem (Error DiscoError : r) () -> Sem r ()
outputDiscoErrors Sem (Error DiscoError : r) ()
m = do
  Either DiscoError ()
e <- Sem (Error DiscoError : r) () -> Sem r (Either DiscoError ())
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem (Error DiscoError : r) ()
m
  (DiscoError -> Sem r ())
-> (() -> Sem r ()) -> Either DiscoError () -> Sem r ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Sem r Doc -> Sem r ()
forall (r :: EffectRow).
Member (Output Message) r =>
Sem r Doc -> Sem r ()
err (Sem r Doc -> Sem r ())
-> (DiscoError -> Sem r Doc) -> DiscoError -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiscoError -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty') () -> Sem r ()
forall (m :: * -> *) a. Monad m => a -> m a
return Either DiscoError ()
e

instance Pretty DiscoError where
  pretty :: DiscoError -> Sem r Doc
pretty = \case
    ModuleNotFound String
m  -> Sem r Doc
"Error: couldn't find a module named '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
m Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"'."
    CyclicImport [ModuleName]
ms   -> [ModuleName] -> Sem r Doc
forall (r :: EffectRow).
Members '[Reader PA, LFresh] r =>
[ModuleName] -> Sem r Doc
cyclicImportError [ModuleName]
ms
    TypeCheckErr (LocTCError Maybe (QName Term)
Nothing TCError
te) -> TCError -> Sem r Doc
forall (r :: EffectRow).
Members '[Reader PA, LFresh] r =>
TCError -> Sem r Doc
prettyTCError TCError
te
    TypeCheckErr (LocTCError (Just QName Term
n) TCError
te) ->
      [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
        [ Sem r Doc
"While checking " Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> QName Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' QName Term
n Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
":"
        , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ TCError -> Sem r Doc
forall (r :: EffectRow).
Members '[Reader PA, LFresh] r =>
TCError -> Sem r Doc
prettyTCError TCError
te
        ]
    ParseErr ParseErrorBundle String DiscoParseError
pe       -> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (ParseErrorBundle String DiscoParseError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String DiscoParseError
pe)
    EvalErr EvalError
ee        -> EvalError -> Sem r Doc
forall (r :: EffectRow).
Members '[Reader PA, LFresh] r =>
EvalError -> Sem r Doc
prettyEvalError EvalError
ee
    Panic String
s           ->
      [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
        [ Sem r Doc
"Bug! " Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s
        , Sem r Doc
"Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
        ]

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

issue :: Int -> Sem r Doc
issue :: Int -> Sem r Doc
issue Int
n = Sem r Doc
"See https://github.com/disco-lang/disco/issues/" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (Int -> String
forall a. Show a => a -> String
show Int
n)

cyclicImportError
  :: Members '[Reader PA, LFresh] r
  => [ModuleName] -> Sem r Doc
cyclicImportError :: [ModuleName] -> Sem r Doc
cyclicImportError [ModuleName]
ms =
  [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: module imports form a cycle:"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Sem r Doc -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Monad f => f Doc -> [f Doc] -> f Doc
intercalate Sem r Doc
" ->" ((ModuleName -> Sem r Doc) -> [ModuleName] -> [Sem r Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Sem r Doc
forall t (r :: EffectRow).
(Pretty t, Members '[Reader PA, LFresh] r) =>
t -> Sem r Doc
pretty [ModuleName]
ms)
    ]

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

  -- XXX include some potential misspellings along with Unbound
  --   see https://github.com/disco-lang/disco/issues/180
  Unbound Name Term
x      -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: there is nothing named" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"unbound"
    ]

  Ambiguous Name Term
x [ModuleName]
ms -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the name" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"is ambiguous. It could refer to:"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 ([Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat ([Sem r Doc] -> Sem r Doc)
-> ([ModuleName] -> [Sem r Doc]) -> [ModuleName] -> Sem r Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> Sem r Doc) -> [ModuleName] -> [Sem r Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
m -> ModuleName -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' ModuleName
m Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"." Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x) ([ModuleName] -> Sem r Doc) -> [ModuleName] -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms)
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"ambiguous"
    ]

  NoType Name Term
x -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the definition of" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"must have an accompanying type signature."
    , Sem r Doc
"Try writing something like '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
": Int' (or whatever the type of"
      Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"should be) first."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"missingtype"
    ]

  NotCon Con
c Term
t Type
ty -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the expression"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Term
t
    , Sem r Doc
"must have both a" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Con -> Sem r Doc
forall (r :: EffectRow). Con -> Sem r Doc
conWord Con
c Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"type and also the incompatible type"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Type
ty Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"notcon"
    ]

  TCError
EmptyCase -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: empty case expressions {? ?} are not allowed."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"empty-case"
    ]

  PatternType Con
c Pattern
pat Type
ty -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the pattern"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Pattern -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Pattern
pat
    , Sem r Doc
"is supposed to have type"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Type
ty Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
","
    , Sem r Doc
"but instead it has a" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Con -> Sem r Doc
forall (r :: EffectRow). Con -> Sem r Doc
conWord Con
c Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"type."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"pattern-type"
    ]

  DuplicateDecls Name Term
x -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: duplicate type signature for" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"dup-sig"
    ]

  DuplicateDefns Name Term
x -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: duplicate definition for" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Term -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Term
x Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"dup-def"
    ]

  DuplicateTyDefns String
s -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: duplicate definition for type" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"dup-tydef"
    ]

  -- XXX include all types involved in the cycle.
  CyclicTyDef String
s -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: cyclic type definition for" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"cyc-ty"
    ]

  -- XXX lots more info!  & Split into several different errors.
  TCError
NumPatterns -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: number of arguments does not match."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"num-args"
    ]

  NoSearch Type
ty ->
    [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the type"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Sem r Doc -> Sem r Doc) -> Sem r Doc -> Sem r Doc
forall a b. (a -> b) -> a -> b
$ Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Type
ty
    , Sem r Doc
"is not searchable (i.e. it cannot be used in a forall)."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"no-search"
    ]

  Unsolvable SolveError
solveErr -> SolveError -> Sem r Doc
forall (r :: EffectRow).
Members '[Reader PA, LFresh] r =>
SolveError -> Sem r Doc
prettySolveError SolveError
solveErr

  -- XXX maybe include close edit-distance alternatives?
  NotTyDef String
s -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: there is no built-in or user-defined type named '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"'."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"no-tydef"
    ]

  TCError
NoTWild -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: wildcards (_) are not allowed in expressions."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"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
con -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: not enough arguments for the type '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Con -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Con
con Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"'."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"num-args-type"
    ]

  TooManyArgs Con
con -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: too many arguments for the type '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Con -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Con
con Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"'."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"num-args-type"
    ]

  -- XXX Mention the definition in which it was found, suggest adding the variable
  --     as a parameter
  UnboundTyVar Name Type
v -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: Unknown type variable '" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Name Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Type
v Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"'."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"unbound-tyvar"
    ]

  NoPolyRec String
s [String]
ss [Type]
tys -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: in the definition of " Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => f Doc -> f Doc
parens (Sem r Doc -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Monad f => f Doc -> [f Doc] -> f Doc
intercalate Sem r Doc
"," ((String -> Sem r Doc) -> [String] -> [Sem r Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text [String]
ss)) Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
": recursive occurrences of" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"may only have type variables as arguments."
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (
        String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => f Doc -> f Doc
parens (Sem r Doc -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Monad f => f Doc -> [f Doc] -> f Doc
intercalate Sem r Doc
"," ((Type -> Sem r Doc) -> [Type] -> [Sem r Doc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' [Type]
tys)) Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"does not follow this rule."
      )
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"no-poly-rec"
    ]

  TCError
NoError -> Sem r Doc
forall (m :: * -> *). Applicative m => m Doc
empty

conWord :: Con -> Sem r Doc
conWord :: Con -> Sem r Doc
conWord = \case
  Con
CArr         -> Sem r Doc
"function"
  Con
CProd        -> Sem r Doc
"product"
  Con
CSum         -> Sem r Doc
"sum"
  Con
CSet         -> Sem r Doc
"set"
  Con
CBag         -> Sem r Doc
"bag"
  Con
CList        -> Sem r Doc
"list"
  CContainer Atom
_ -> Sem r Doc
"container"
  Con
CMap         -> Sem r Doc
"map"
  Con
CGraph       -> Sem r Doc
"graph"
  CUser String
s      -> String -> Sem r Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
s

prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r Doc
prettySolveError :: SolveError -> Sem r Doc
prettySolveError = \case

  -- XXX say which types!
  SolveError
NoWeakUnifier -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: the shape of two types does not match."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"shape-mismatch"
    ]

  -- XXX say more!  XXX HIGHEST PRIORITY!
  SolveError
NoUnify       -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: typechecking failed."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"typecheck-fail"
    ]

  UnqualBase Qualifier
q BaseTy
b -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: values of type" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> BaseTy -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' BaseTy
b Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Bool -> Qualifier -> Sem r Doc
forall (r :: EffectRow). Bool -> Qualifier -> Sem r Doc
qualPhrase Bool
False Qualifier
q Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"not-qual"
    ]

  Unqual Qualifier
q Type
ty -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: values of type" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Type
ty Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Bool -> Qualifier -> Sem r Doc
forall (r :: EffectRow). Bool -> Qualifier -> Sem r Doc
qualPhrase Bool
False Qualifier
q Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"not-qual"
    ]

  QualSkolem Qualifier
q Name Type
a -> [Sem r Doc] -> Sem r Doc
forall (f :: * -> *). Applicative f => [f Doc] -> f Doc
vcat
    [ Sem r Doc
"Error: type variable" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Name Type -> Sem r Doc
forall t (r :: EffectRow). Pretty t => t -> Sem r Doc
pretty' Name Type
a Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"represents any type, so we cannot assume values of that type"
    , Int -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Functor f => Int -> f Doc -> f Doc
nest Int
2 (Bool -> Qualifier -> Sem r Doc
forall (r :: EffectRow). Bool -> Qualifier -> Sem r Doc
qualPhrase Bool
True Qualifier
q) Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> Sem r Doc
"."
    , String -> Sem r Doc
forall (r :: EffectRow). String -> Sem r Doc
rtd String
"qual-skolem"
    ]

qualPhrase :: Bool -> Qualifier -> Sem r Doc
qualPhrase :: Bool -> Qualifier -> Sem r Doc
qualPhrase Bool
b Qualifier
q
  | Qualifier
q Qualifier -> [Qualifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Qualifier
QBool, Qualifier
QBasic, Qualifier
QSimple] = Sem r Doc
"are" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> (if Bool
b then Sem r Doc
forall (m :: * -> *). Applicative m => m Doc
empty else Sem r Doc
"not") Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Qualifier -> Sem r Doc
forall (r :: EffectRow). Qualifier -> Sem r Doc
qualAction Qualifier
q
  | Bool
otherwise = Sem r Doc
"can" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<> (if Bool
b then Sem r Doc
forall (m :: * -> *). Applicative m => m Doc
empty else Sem r Doc
"not") Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Sem r Doc
"be" Sem r Doc -> Sem r Doc -> Sem r Doc
forall (f :: * -> *). Applicative f => f Doc -> f Doc -> f Doc
<+> Qualifier -> Sem r Doc
forall (r :: EffectRow). Qualifier -> Sem r Doc
qualAction Qualifier
q

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