git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1082 from purescript/errors
04cd31cPhil Freeman
src/Language/PureScript/Errors.hs+24−15
compare with golang
unifiedsplit
@@ -19,10 +19,13 @@
19module Language.PureScript.Errors where
19module Language.PureScript.Errors where
20
20
21import Data.Either (lefts, rights)
21import Data.Either (lefts, rights)
22−import Data.List (intercalate, elemIndex)
22+import Data.List (intercalate)
23+import Data.Function (on)
23import Data.Monoid
24import Data.Monoid
24import Data.Foldable (fold, foldMap)
25import Data.Foldable (fold, foldMap)
25
26
27+import qualified Data.Map as M
28+
26import Control.Monad
29import Control.Monad
27import Control.Monad.Error.Class (MonadError(..))
30import Control.Monad.Error.Class (MonadError(..))
28import Control.Monad.Unify
31import Control.Monad.Unify
@@ -252,18 +255,24 @@ errorMessage err = MultipleErrors [err]
252onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
255onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
253onErrorMessages f = MultipleErrors . map f . runMultipleErrors
256onErrorMessages f = MultipleErrors . map f . runMultipleErrors
254
257
255−replaceUnknowns :: Type -> State [Unknown] Type
258+-- | The various types of things which might need to be relabelled in errors messages.
256−replaceUnknowns = everywhereOnTypesM replaceUnknowns'
259+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
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
260
261+-- | A map from rigid type variable name/unknown variable pairs to new variables.
262+type UnknownMap = M.Map (LabelType, Unknown) Unknown
263+
263− replaceUnknowns' :: Type -> State [Unknown] Type
264+replaceUnknowns :: Type -> State UnknownMap Type
264− replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable u
265+replaceUnknowns = everywhereOnTypesM replaceTypes
265− replaceUnknowns' other = return other
266+ where
267+ lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
268+ lookupTable x m = case M.lookup x m of
269+ Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
270+ Just i -> (i, m)
266
271
272+ replaceTypes :: Type -> State UnknownMap Type
273+ replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
274+ replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
275+ replaceTypes other = return other
267
276
268onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
277onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
269onTypesInErrorMessageM f = g
278onTypesInErrorMessageM f = g
@@ -298,7 +307,7 @@ onTypesInErrorMessageM f = g
298-- |
307-- |
299-- Pretty print a single error, simplifying if necessary
308-- Pretty print a single error, simplifying if necessary
300--
309--
301−prettyPrintSingleError :: Bool -> ErrorMessage -> State [Unknown] Box.Box
310+prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box
302prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
311prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
303 where
312 where
304 -- |
313 -- |
@@ -569,15 +578,15 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
569-- Pretty print multiple errors
578-- Pretty print multiple errors
570--
579--
571prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
580prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
572−prettyPrintMultipleErrors full = flip evalState [] . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
581+prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
573
582
574-- |
583-- |
575-- Pretty print multiple warnings
584-- Pretty print multiple warnings
576--
585--
577prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
586prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
578−prettyPrintMultipleWarnings full = flip evalState [] . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
587+prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
579
588
580−prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State [Unknown] String
589+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String
581prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
590prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
582 result <- prettyPrintSingleError full e
591 result <- prettyPrintSingleError full e
583 return $ renderBox $
592 return $ renderBox $
src/Language/PureScript/Kinds.hs+8
@@ -18,6 +18,7 @@ module Language.PureScript.Kinds where
18
18
19import Data.Data
19import Data.Data
20
20
21+import Control.Applicative
21import Control.Monad.Unify (Unknown)
22import Control.Monad.Unify (Unknown)
22
23
23-- |
24-- |
@@ -52,6 +53,13 @@ everywhereOnKinds f = go
52 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
53 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
53 go other = f other
54 go other = f other
54
55
56+everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
57+everywhereOnKindsM f = go
58+ where
59+ go (Row k1) = (Row <$> go k1) >>= f
60+ go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
61+ go other = f other
62+
55everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
63everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
56everythingOnKinds (<>) f = go
64everythingOnKinds (<>) f = go
57 where
65 where
src/Language/PureScript/Pretty/Types.hs+1−1
@@ -39,7 +39,7 @@ typeLiterals = mkPattern match
39 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
39 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
40 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
40 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
41 match (TypeConstructor ctor) = Just $ show ctor
41 match (TypeConstructor ctor) = Just $ show ctor
42− match (TUnknown u) = Just $ 'u' : show u
42+ match (TUnknown u) = Just $ '_' : show u
43 match (Skolem name s _) = Just $ name ++ show s
43 match (Skolem name s _) = Just $ name ++ show s
44 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
44 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
45 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
45 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"