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

outputDiscoErrors :: Member (Output (Message ann)) r => Sem (Error DiscoError ': r) () -> Sem r ()
outputDiscoErrors :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
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 ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
err (Sem r (Doc ann) -> Sem r ())
-> (DiscoError -> Sem r (Doc ann)) -> DiscoError -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiscoError -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty') () -> Sem r ()
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return Either DiscoError ()
e

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

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

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

squote :: String -> String
squote :: ShowS
squote [Char]
x = [Char]
"'" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'"

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

prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r (Doc ann)
prettyEvalError :: forall (r :: EffectRow) ann.
Members '[Reader PA, LFresh] r =>
EvalError -> Sem r (Doc ann)
prettyEvalError = \case
  UnboundPanic Name core
x ->
    (Sem r (Doc ann)
"Bug! No variable found named" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name core -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name core
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
".")
      Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
$+$ Sem r (Doc ann)
"Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
  UnboundError QName core
x -> Sem r (Doc ann)
"Error: encountered undefined name" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> QName core -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' QName core
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
". Maybe you haven't defined it yet?"
  EvalError
DivByZero -> Sem r (Doc ann)
"Error: division by zero."
  EvalError
Overflow -> Sem r (Doc ann)
"Error: that number would not even fit in the universe!"
  EvalError
NonExhaustive -> Sem r (Doc ann)
"Error: value did not match any of the branches in a case expression."
  EvalError
InfiniteLoop -> Sem r (Doc ann)
"Error: infinite loop detected!"
  Crash [Char]
s -> Sem r (Doc ann)
"User crash:" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
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 :: forall (r :: EffectRow) ann.
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 Name Term
x [[Char]]
suggestions ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat ([Sem r (Doc ann)] -> Sem r (Doc ann))
-> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$
      [Sem r (Doc ann)
"Error: there is nothing named" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."]
        [Sem r (Doc ann)] -> [Sem r (Doc ann)] -> [Sem r (Doc ann)]
forall a. [a] -> [a] -> [a]
++ [Sem r (Doc ann)
"Perhaps you meant" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann) -> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Monad f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate Sem r (Doc ann)
" or" (([Char] -> Sem r (Doc ann)) -> [[Char]] -> [Sem r (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text ([Char] -> Sem r (Doc ann)) -> ShowS -> [Char] -> Sem r (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
squote) [[Char]]
suggestions) Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"?" | Bool -> Bool
not ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
suggestions)]
        [Sem r (Doc ann)] -> [Sem r (Doc ann)] -> [Sem r (Doc ann)]
forall a. [a] -> [a] -> [a]
++ [[Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"unbound"]
  Ambiguous Name Term
x [ModuleName]
ms ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: the name" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"is ambiguous. It could refer to:"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> ([ModuleName] -> Sem r (Doc ann))
-> [ModuleName]
-> Sem r (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat ([Sem r (Doc ann)] -> Sem r (Doc ann))
-> ([ModuleName] -> [Sem r (Doc ann)])
-> [ModuleName]
-> Sem r (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> Sem r (Doc ann))
-> [ModuleName] -> [Sem r (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
m -> ModuleName -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' ModuleName
m Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"." Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x) ([ModuleName] -> Sem r (Doc ann))
-> [ModuleName] -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"ambiguous"
      ]
  NoType Name Term
x ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: the definition of" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"must have an accompanying type signature."
      , Sem r (Doc ann)
"Try writing something like '"
          Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x
          Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
": Int' (or whatever the type of"
          Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x
          Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"should be) first."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"missingtype"
      ]
  NotCon Con
c Term
t Type
ty ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: the expression"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> Sem r (Doc ann) -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Term
t
      , Sem r (Doc ann)
"must have both a" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Con -> Sem r (Doc ann)
forall (r :: EffectRow) ann. Con -> Sem r (Doc ann)
conWord Con
c Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"type and also the incompatible type"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> Sem r (Doc ann) -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ Type -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Type
ty Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"notcon"
      ]
  TCError
EmptyCase ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: empty case expressions {? ?} are not allowed."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"empty-case"
      ]
  PatternType Con
c Pattern
pat Type
ty ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: the pattern"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> Sem r (Doc ann) -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ Pattern -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Pattern
pat
      , Sem r (Doc ann)
"is supposed to have type"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> Sem r (Doc ann) -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ Type -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Type
ty Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
","
      , Sem r (Doc ann)
"but instead it has a" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Con -> Sem r (Doc ann)
forall (r :: EffectRow) ann. Con -> Sem r (Doc ann)
conWord Con
c Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"type."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"pattern-type"
      ]
  DuplicateDecls Name Term
x ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: duplicate type signature for" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"dup-sig"
      ]
  DuplicateDefns Name Term
x ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: duplicate definition for" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"dup-def"
      ]
  DuplicateTyDefns [Char]
s ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: duplicate definition for type" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"dup-tydef"
      ]
  -- XXX include all types involved in the cycle.
  CyclicTyDef [Char]
s ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: cyclic type definition for" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"cyc-ty"
      ]
  -- XXX lots more info!  & Split into several different errors.
  TCError
NumPatterns ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: number of arguments does not match."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"num-args"
      ]
  NonlinearPattern Pattern
p Name Term
x ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: pattern" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Pattern -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Pattern
p Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"contains duplicate variable" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Name Term -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Term
x Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"nonlinear"
      ]
  NoSearch Type
ty ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: the type"
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent Int
2 (Sem r (Doc ann) -> Sem r (Doc ann))
-> Sem r (Doc ann) -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$ Type -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Type
ty
      , Sem r (Doc ann)
"is not searchable (i.e. it cannot be used in a forall)."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"no-search"
      ]
  Unsolvable SolveError
solveErr -> SolveError -> Sem r (Doc ann)
forall (r :: EffectRow) ann.
Members '[Reader PA, LFresh] r =>
SolveError -> Sem r (Doc ann)
prettySolveError SolveError
solveErr
  -- XXX maybe include close edit-distance alternatives?
  NotTyDef [Char]
s ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: there is no built-in or user-defined type named '" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"'."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"no-tydef"
      ]
  TCError
NoTWild ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: wildcards (_) are not allowed in expressions."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"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 ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: not enough arguments for the type '" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Con -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Con
con Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"'."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"num-args-type"
      ]
  TooManyArgs Con
con ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: too many arguments for the type '" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Con -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Con
con Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"'."
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"num-args-type"
      ]
  -- XXX Mention the definition in which it was found
  UnboundTyVar Name Type
v [[Char]]
suggestions ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat ([Sem r (Doc ann)] -> Sem r (Doc ann))
-> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall a b. (a -> b) -> a -> b
$
      [Sem r (Doc ann)
"Error: Unknown type variable '" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Name Type -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' Name Type
v Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"'."]
        [Sem r (Doc ann)] -> [Sem r (Doc ann)] -> [Sem r (Doc ann)]
forall a. [a] -> [a] -> [a]
++ [Sem r (Doc ann)
"Perhaps you meant" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann) -> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Monad f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate Sem r (Doc ann)
" or" (([Char] -> Sem r (Doc ann)) -> [[Char]] -> [Sem r (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text ([Char] -> Sem r (Doc ann)) -> ShowS -> [Char] -> Sem r (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
squote) [[Char]]
suggestions) Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
"?" | Bool -> Bool
not ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
suggestions)]
        [Sem r (Doc ann)] -> [Sem r (Doc ann)] -> [Sem r (Doc ann)]
forall a. [a] -> [a] -> [a]
++ [[Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"unbound-tyvar"]
  NoPolyRec [Char]
s [[Char]]
ss [Type]
tys ->
    [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
[f (Doc ann)] -> f (Doc ann)
vcat
      [ Sem r (Doc ann)
"Error: in the definition of " Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
parens (Sem r (Doc ann) -> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Monad f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate Sem r (Doc ann)
"," (([Char] -> Sem r (Doc ann)) -> [[Char]] -> [Sem r (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [[Char]]
ss)) Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann)
": recursive occurrences of" Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"may only have type variables as arguments."
      , Int -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Functor f =>
Int -> f (Doc ann) -> f (Doc ann)
indent
          Int
2
          ( [Char] -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => [Char] -> m (Doc ann)
text [Char]
s Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann. Functor f => f (Doc ann) -> f (Doc ann)
parens (Sem r (Doc ann) -> [Sem r (Doc ann)] -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Monad f =>
f (Doc ann) -> [f (Doc ann)] -> f (Doc ann)
intercalate Sem r (Doc ann)
"," ((Type -> Sem r (Doc ann)) -> [Type] -> [Sem r (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty' [Type]
tys)) Sem r (Doc ann) -> Sem r (Doc ann) -> Sem r (Doc ann)
forall (f :: * -> *) ann.
Applicative f =>
f (Doc ann) -> f (Doc ann) -> f (Doc ann)
<+> Sem r (Doc ann)
"does not follow this rule."
          )
      , [Char] -> Sem r (Doc ann)
forall (r :: EffectRow) ann. [Char] -> Sem r (Doc ann)
rtd [Char]
"no-poly-rec"
      ]
  TCError
NoError -> Sem r (Doc ann)
forall (m :: * -> *) ann. Applicative m => m (Doc ann)
empty

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

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

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

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