@@ -19,14 +19,16 @@
1919module Language.PureScript.Errors where
2020
2121import Data.Either (lefts, rights)
22−import Data.List (intercalate)
22+import Data.List (intercalate, elemIndex)
2323import Data.Monoid
2424import Data.Foldable (fold, foldMap)
2525
2626import Control.Monad
2727import Control.Monad.Error.Class (MonadError(..))
2828import Control.Monad.Unify
29−import Control.Applicative ((<$>))
29+import Control.Applicative ((<$>), (<*>), Applicative, pure)
30+import Control.Monad.Trans.State.Lazy
31+import Control.Arrow(first)
3032
3133import Language.PureScript.AST
3234import Language.PureScript.Pretty
@@ -250,12 +252,55 @@ errorMessage err = MultipleErrors [err]
250252onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
251253onErrorMessages f = MultipleErrors . map f . runMultipleErrors
252254
255+replaceUnknowns :: Type -> State [Unknown] Type
256+replaceUnknowns = everywhereOnTypesM replaceUnknowns'
257+ where
258+ lookupTable :: Unknown -> [Unknown] -> (Unknown, [Unknown])
259+ lookupTable x table = case (elemIndex x table) of
260+ Nothing -> (length table, table ++ [x])
261+ Just i -> (i, table)
262+
263+ replaceUnknowns' :: Type -> State [Unknown] Type
264+ replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable u
265+ replaceUnknowns' other = return other
266+
267+
268+onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
269+onTypesInErrorMessageM f = g
270+ where
271+ g (InfiniteType t) = InfiniteType <$> (f t)
272+ g (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
273+ g (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
274+ g (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
275+ g (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
276+ g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
277+ g (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
278+ g (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
279+ g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
280+ g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
281+ g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
282+ g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
283+ g (NotYetDefined x e) = NotYetDefined x <$> (g e)
284+ g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
285+ g (ErrorInModule x e) = ErrorInModule x <$> (g e)
286+ g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
287+ g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
288+ g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
289+ g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
290+ g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
291+ g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
292+ g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
293+ g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
294+ g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
295+ g (PositionedError x e) = PositionedError x <$> (g e)
296+ g other = pure other
297+
253298-- |
254299-- Pretty print a single error, simplifying if necessary
255300--
256−prettyPrintSingleError :: Bool -> ErrorMessage -> Box.Box
257−prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
258− where
301+prettyPrintSingleError :: Bool -> ErrorMessage -> State [Unknown] Box.Box
302+prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
303+ where
259304 -- |
260305 -- Pretty print an ErrorMessage
261306 --
@@ -514,32 +559,37 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim
514559 unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
515560 unwrap _ (PositionedError pos err) = unwrap (Just pos) err
516561 unwrap pos other = wrap pos other
517−
562+
518563 wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
519564 wrap Nothing = id
520565 wrap (Just pos) = PositionedError pos
521566
567+
522568-- |
523569-- Pretty print multiple errors
524570--
525571prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
526−prettyPrintMultipleErrors = prettyPrintMultipleErrorsWith "Error:" "Multiple errors:"
527−
572+prettyPrintMultipleErrors full = flip evalState [] . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
573+
528574-- |
529575-- Pretty print multiple warnings
530576--
531−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
532−prettyPrintMultipleWarnings = prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:"
533−
534−prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> String
535−prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = renderBox $
536− Box.vcat Box.left [ Box.text intro
537− , prettyPrintSingleError full e
538− ]
539−prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = renderBox $
540− Box.vcat Box.left [ Box.text intro
541− , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es
542− ]
577+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
578+prettyPrintMultipleWarnings full = flip evalState [] . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
579+
580+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State [Unknown] String
581+prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
582+ result <- prettyPrintSingleError full e
583+ return $ renderBox $
584+ Box.vcat Box.left [ Box.text intro
585+ , result
586+ ]
587+prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = do
588+ result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full
589+ return $ renderBox $
590+ Box.vcat Box.left [ Box.text intro
591+ , Box.vsep 1 Box.left result
592+ ]
543593
544594renderBox :: Box.Box -> String
545595renderBox = unlines . map trimEnd . lines . Box.render