@@ -14,6 +14,7 @@
1414
1515{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1616{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
1718{-# LANGUAGE MultiParamTypeClasses #-}
1819
1920module Language.PureScript.Errors where
@@ -24,7 +25,6 @@ import Prelude.Compat
2425import Data.Ord (comparing)
2526import Data.Either (lefts, rights)
2627import Data.List (intercalate, transpose, nub, nubBy, sortBy)
27−import Data.Function (on)
2828import Data.Foldable (fold)
2929
3030import qualified Data.Map as M
@@ -33,7 +33,7 @@ import Control.Monad
3333import Control.Monad.Writer
3434import Control.Monad.Error.Class (MonadError(..))
3535import Control.Monad.Trans.State.Lazy
36−import Control.Arrow (first, (&&&))
36+import Control.Arrow ((&&&))
3737
3838import Language.PureScript.Crash
3939import Language.PureScript.AST
@@ -311,11 +311,16 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors
311311addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
312312addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
313313
314−-- | The various types of things which might need to be relabelled in errors messages.
315−data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
316−
317314-- | A map from rigid type variable name/unknown variable pairs to new variables.
318−type UnknownMap = M.Map (LabelType, Int) Int
315+data TypeMap = TypeMap
316+ { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)
317+ , umNextSkolem :: Int
318+ , umUnknownMap :: M.Map Int Int
319+ , umNextUnknown :: Int
320+ } deriving Show
321+
322+defaultUnknownMap :: TypeMap
323+defaultUnknownMap = TypeMap M.empty 0 M.empty 0
319324
320325-- | How critical the issue is
321326data Level = Error | Warning deriving Show
@@ -326,56 +331,80 @@ data Level = Error | Warning deriving Show
326331unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
327332unwrapErrorMessage (ErrorMessage _ se) = se
328333
329−replaceUnknowns :: Type -> State UnknownMap Type
334+replaceUnknowns :: Type -> State TypeMap Type
330335replaceUnknowns = everywhereOnTypesM replaceTypes
331336 where
332− lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap)
333− lookupTable x m = case M.lookup x m of
334− Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
335− Just i -> (i, m)
336−
337− replaceTypes :: Type -> State UnknownMap Type
338− replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
339− replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
337+ replaceTypes :: Type -> State TypeMap Type
338+ replaceTypes (TUnknown u) = do
339+ m <- get
340+ case M.lookup u (umUnknownMap m) of
341+ Nothing -> do
342+ let u' = umNextUnknown m
343+ put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }
344+ return (TUnknown u')
345+ Just u' -> return (TUnknown u')
346+ replaceTypes (Skolem name s sko ss) = do
347+ m <- get
348+ case M.lookup s (umSkolemMap m) of
349+ Nothing -> do
350+ let s' = umNextSkolem m
351+ put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }
352+ return (Skolem name s' sko ss)
353+ Just (_, s', _) -> return (Skolem name s' sko ss)
340354 replaceTypes other = return other
341355
342356onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
343357onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
344358 where
345− gSimple (InfiniteType t) = InfiniteType <$> f t
346− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
347− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
348− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
349− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
350− gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
351− gSimple other = pure other
352− gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
353− gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
354− gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
355− gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
356− gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
357− gHint other = pure other
359+ gSimple (InfiniteType t) = InfiniteType <$> f t
360+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
361+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
362+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
363+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
364+ gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
365+ gSimple other = pure other
366+
367+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
368+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
369+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
370+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
371+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
372+ gHint other = pure other
358373
359374-- |
360375-- Pretty print a single error, simplifying if necessary
361376--
362−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
363−prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
377+prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box
378+prettyPrintSingleError full level e = do
379+ em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
380+ um <- get
381+ return (prettyPrintErrorMessage um em)
364382 where
365383
366384 -- Pretty print an ErrorMessage
367− prettyPrintErrorMessage :: ErrorMessage -> Box.Box
368− prettyPrintErrorMessage (ErrorMessage hints simple) =
385+ prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
386+ prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =
369387 paras $
370− [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
371− , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "
372− , line $ "or to contribute content related to this " ++ levelText ++ "."
373− ]
374− ]
388+ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
389+ : typeInformation
390+ ++ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "
391+ , line $ "or to contribute content related to this " ++ levelText ++ "."
392+ ]
393+ ]
375394 where
376395 wikiUri :: String
377396 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
378397
398+ typeInformation :: [Box.Box]
399+ typeInformation = M.elems . M.mapMaybe skolemInfo . umSkolemMap $ typeMap
400+ where
401+ skolemInfo :: (String, Int, Maybe SourceSpan) -> Maybe Box.Box
402+ skolemInfo (name, s, Just ss) =
403+ Just . Box.moveDown 1 $ paras [ line $ "(" ++ name ++ show s ++ " is a rigid type variable"
404+ , line $ " bound at " ++ displayStartEndPos ss ++ ")"
405+ ]
406+ skolemInfo _ = Nothing
407+
379408 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
380409 renderSimpleErrorMessage (CannotGetFileInfo path) =
381410 paras [ line "Unable to read file info: "
@@ -878,6 +907,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
878907 hintCategory ErrorUnifyingTypes{} = CheckHint
879908 hintCategory ErrorInSubsumption{} = CheckHint
880909 hintCategory ErrorInApplication{} = CheckHint
910+ hintCategory ErrorCheckingKind{} = CheckHint
881911 hintCategory PositionedError{} = PositionHint
882912 hintCategory _ = OtherHint
883913
@@ -895,13 +925,13 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
895925
896926-- | Pretty print warnings as a Box
897927prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
898−prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
928+prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
899929
900930-- | Pretty print errors as a Box
901931prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
902−prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
932+prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
903933
904−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
934+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box
905935prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
906936 result <- prettyPrintSingleError full level e
907937 return $