04cd31c · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge pull request #1082 from purescript/errors

Errors

commit04cd31cfcab249322e021b753a5ce0558cf082f8 authorPhil Freeman <paf31@cantab.net> dateSun 26 Apr 2015, 15:30 (12 years ago) parent9db8c6c 7cd8e64

3 files changed+33−16

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+24−15 src/Language/PureScript/Kinds.hs+8 src/Language/PureScript/Pretty/Types.hs+1−1

src/Language/PureScript/Errors.hs+24−15

@@ -19,10 +19,13 @@

1919module Language.PureScript.Errors where

2020

2121import Data.Either (lefts, rights)

22−import Data.List (intercalate, elemIndex)

22+import Data.List (intercalate)

23+import Data.Function (on)

2324import Data.Monoid

2425import Data.Foldable (fold, foldMap)

2526

27+import qualified Data.Map as M

28+

2629import Control.Monad

2730import Control.Monad.Error.Class (MonadError(..))

2831import Control.Monad.Unify

@@ -252,18 +255,24 @@ errorMessage err = MultipleErrors [err]

252255onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

253256onErrorMessages f = MultipleErrors . map f . runMultipleErrors

254257

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)

258+-- | The various types of things which might need to be relabelled in errors messages.

259+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)

262260

263− replaceUnknowns' :: Type -> State [Unknown] Type

264− replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable u

265− replaceUnknowns' other = return other

261+-- | A map from rigid type variable name/unknown variable pairs to new variables.

262+type UnknownMap = M.Map (LabelType, Unknown) Unknown

263+

264+replaceUnknowns :: Type -> State UnknownMap Type

265+replaceUnknowns = everywhereOnTypesM replaceTypes

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)

266271

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

267276

268277onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

269278onTypesInErrorMessageM f = g

@@ -298,7 +307,7 @@ onTypesInErrorMessageM f = g

298307-- |

299308-- Pretty print a single error, simplifying if necessary

300309--

301−prettyPrintSingleError :: Bool -> ErrorMessage -> State [Unknown] Box.Box

310+prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box

302311prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

303312 where

304313 -- |

@@ -569,15 +578,15 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

569578-- Pretty print multiple errors

570579--

571580prettyPrintMultipleErrors :: 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

573582

574583-- |

575584-- Pretty print multiple warnings

576585--

577586prettyPrintMultipleWarnings :: 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

579588

580−prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State [Unknown] String

589+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String

581590prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do

582591 result <- prettyPrintSingleError full e

583592 return $ renderBox $

src/Language/PureScript/Kinds.hs+8

@@ -18,6 +18,7 @@ module Language.PureScript.Kinds where

1818

1919import Data.Data

2020

21+import Control.Applicative

2122import Control.Monad.Unify (Unknown)

2223

2324-- |

@@ -52,6 +53,13 @@ everywhereOnKinds f = go

5253 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

5354 go other = f other

5455

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+

5563everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r

5664everythingOnKinds (<>) f = go

5765 where

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -39,7 +39,7 @@ typeLiterals = mkPattern match

3939 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

4040 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

4141 match (TypeConstructor ctor) = Just $ show ctor

42− match (TUnknown u) = Just $ 'u' : show u

42+ match (TUnknown u) = Just $ '_' : show u

4343 match (Skolem name s _) = Just $ name ++ show s

4444 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

4545 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"