git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Tidying, add kind traversal
7cd8e64Phil Freeman
src/Language/PureScript/Errors.hs+14−11
compare with golang
unifiedsplit
@@ -255,21 +255,24 @@ errorMessage err = MultipleErrors [err]
255onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
255onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
256onErrorMessages f = MultipleErrors . map f . runMultipleErrors
256onErrorMessages f = MultipleErrors . map f . runMultipleErrors
257
257
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)
260+
258-- | A map from rigid type variable name/unknown variable pairs to new variables.
261-- | A map from rigid type variable name/unknown variable pairs to new variables.
259−type UnknownMap = M.Map (Maybe String, Unknown) Unknown
262+type UnknownMap = M.Map (LabelType, Unknown) Unknown
260
263
261replaceUnknowns :: Type -> State UnknownMap Type
264replaceUnknowns :: Type -> State UnknownMap Type
262−replaceUnknowns = everywhereOnTypesM replaceUnknowns'
265+replaceUnknowns = everywhereOnTypesM replaceTypes
263 where
266 where
264− lookupTable :: (Maybe String, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
267+ lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
265− lookupTable x m = case M.lookup x m of
268+ lookupTable x m = case M.lookup x m of
266− Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
269+ Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
267− Just i -> (i, m)
270+ Just i -> (i, m)
268−
271+
269− replaceUnknowns' :: Type -> State UnknownMap Type
272+ replaceTypes :: Type -> State UnknownMap Type
270− replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable (Nothing, u)
273+ replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
271− replaceUnknowns' (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (Just name, s)
274+ replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
272− replaceUnknowns' other = return other
275+ replaceTypes other = return other
273
276
274onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
277onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
275onTypesInErrorMessageM f = g
278onTypesInErrorMessageM f = g
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