git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Tidying, add kind traversal
commit7cd8e64719d1da0a45bdaffdfdb4174833014ef3 authorPhil Freeman <paf31@cantab.net> dateSun 26 Apr 2015, 13:39 (12 years ago) parentb578d26
2 files changed+22−11
compare with golang
unifiedsplit
src/Language/PureScript/Errors.hs+14−11 src/Language/PureScript/Kinds.hs+8
src/Language/PureScript/Errors.hs+14−11
@@ -255,21 +255,24 @@ errorMessage err = MultipleErrors [err]
255255onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
256256onErrorMessages f = MultipleErrors . map f . runMultipleErrors
257257
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+
258261-- | 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
260263
261264replaceUnknowns :: Type -> State UnknownMap Type
262−replaceUnknowns = everywhereOnTypesM replaceUnknowns'
265+replaceUnknowns = everywhereOnTypesM replaceTypes
263266 where
264− lookupTable :: (Maybe String, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
265− 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)
267− Just i -> (i, m)
268−
269− replaceUnknowns' :: Type -> State UnknownMap Type
270− replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable (Nothing, u)
271− replaceUnknowns' (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (Just name, s)
272− replaceUnknowns' other = return other
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)
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
273276
274277onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
275278onTypesInErrorMessageM f = g
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