Tidying, add kind traversal

paf31 · paf31 · commit 7cd8e64719d1 · 2015-04-26T13:39:31.000-07:00
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -255,21 +255,24 @@ errorMessage err = MultipleErrors [err]
 onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
 onErrorMessages f = MultipleErrors . map f . runMultipleErrors
 
+-- | The various types of things which might need to be relabelled in errors messages.
+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
+
 -- | A map from rigid type variable name/unknown variable pairs to new variables.
-type UnknownMap = M.Map (Maybe String, Unknown) Unknown
+type UnknownMap = M.Map (LabelType, Unknown) Unknown
 
 replaceUnknowns :: Type -> State UnknownMap Type
-replaceUnknowns = everywhereOnTypesM replaceUnknowns'
+replaceUnknowns = everywhereOnTypesM replaceTypes 
   where
-    lookupTable :: (Maybe String, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
-    lookupTable x m = case M.lookup x m of
-                        Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
-                        Just i  -> (i, m)
-
-    replaceUnknowns' :: Type -> State UnknownMap Type
-    replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable (Nothing, u)
-    replaceUnknowns' (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (Just name, s)
-    replaceUnknowns' other = return other
+  lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
+  lookupTable x m = case M.lookup x m of
+                      Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
+                      Just i  -> (i, m)
+
+  replaceTypes :: Type -> State UnknownMap Type
+  replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
+  replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
+  replaceTypes other = return other
 
 onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
 onTypesInErrorMessageM f = g
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Kinds where
 
 import Data.Data
 
+import Control.Applicative
 import Control.Monad.Unify (Unknown)
 
 -- |
@@ -52,6 +53,13 @@ everywhereOnKinds f = go
   go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
   go other = f other
 
+everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
+everywhereOnKindsM f = go
+  where
+  go (Row k1) = (Row <$> go k1) >>= f
+  go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
+  go other = f other
+
 everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
 everythingOnKinds (<>) f = go
   where
