git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
#184 Nested type synonyms now expand properly, type class instances for type synonyms can be found
4e224e0Phil Freeman
examples/passing/NestedTypeSynonyms.pursnew file+13
compare with golang
unifiedsplit
@@ -0,0 +1,13 @@
1+module NestedTypeSynonyms where
2+
3+ type X = String
4+ type Y = X -> X
5+
6+ fn :: Y
7+ fn a = a
8+
9+module Main where
10+
11+ import Prelude
12+
13+ main = Trace.print (NestedTypeSynonyms.fn "Done")
examples/shouldpass/NestedTypeSynonyms.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Test where
2−
3− type X = {}
4− type Y = X -> X
5−
6− fn :: Y
7− fn a = a
8−
9− test = fn {}
src/Language/PureScript/TypeChecker/Types.hs+28−12
@@ -67,7 +67,6 @@ import Control.Arrow (Arrow(..))
67
67
68import qualified Data.Map as M
68import qualified Data.Map as M
69import Data.Function (on)
69import Data.Function (on)
70−import Debug.Trace (trace)
71
70
72instance Partial Type where
71instance Partial Type where
73 unknown = TUnknown
72 unknown = TUnknown
@@ -211,14 +210,16 @@ typesOf moduleName vals = do
211 -- Make sure unification variables do not escape
210 -- Make sure unification variables do not escape
212 escapeCheck val ty
211 escapeCheck val ty
213 return triple
212 return triple
214− forM tys $ \(ident, (val, ty)) -> rethrow (("Error in " ++ show ident ++ ": \n") ++) $ do
213+ forM tys $ \(ident, (val, ty)) -> do
215 -- Replace type class dictionary placeholders with actual dictionaries
214 -- Replace type class dictionary placeholders with actual dictionaries
216 val' <- replaceTypeClassDictionaries moduleName val
215 val' <- replaceTypeClassDictionaries moduleName val
217 -- Check skolem variables did not escape their scope
216 -- Check skolem variables did not escape their scope
218 skolemEscapeCheck val'
217 skolemEscapeCheck val'
219− --
218+ -- Remove type synonyms placeholders, remove duplicate row fields, and replace
219+ -- top-level unification variables with named type variables.
220− return $ (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
220+ let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
221− , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
221+ ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
222+ return $ (ident, (val'', ty'))
222 where
223 where
223 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
224 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
224 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
225 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
@@ -309,6 +310,9 @@ typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
309typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
310typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
310typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
311typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
311typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
312typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
313+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
314+ Left err -> Nothing
315+ Right t1 -> typeHeadsAreEqual m e t1 t2
312typeHeadsAreEqual _ _ _ _ = Nothing
316typeHeadsAreEqual _ _ _ _ = Nothing
313
317
314-- |
318-- |
@@ -429,12 +433,18 @@ replaceVarWithUnknown ident ty = do
429-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
433-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
430-- better error messages during unification.
434-- better error messages during unification.
431--
435--
436+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
437+replaceAllTypeSynonyms' env moduleName d =
438+ let
439+ syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
440+ in
441+ saturateAllTypeSynonyms env moduleName syns d
442+
432−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
443+replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
433replaceAllTypeSynonyms d = do
444replaceAllTypeSynonyms d = do
434 env <- getEnv
445 env <- getEnv
435 Just moduleName <- checkCurrentModule <$> get
446 Just moduleName <- checkCurrentModule <$> get
436− let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
437− either throwError return $ saturateAllTypeSynonyms env moduleName syns d
447+ either throwError return $ replaceAllTypeSynonyms' env moduleName d
438
448
439-- |
449-- |
440-- \"Desaturate\" @SaturatedTypeSynonym@s
450-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -448,13 +458,19 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
448-- |
458-- |
449-- Replace a type synonym and its arguments with the aliased type
459-- Replace a type synonym and its arguments with the aliased type
450--
460--
451−expandTypeSynonym :: Qualified ProperName -> [Type] -> UnifyT Type Check Type
461+expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
462+expandTypeSynonym' env moduleName name args =
463+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
464+ Just (synArgs, body) -> do
465+ let repl = replaceAllTypeVars (zip synArgs args) body
466+ replaceAllTypeSynonyms' env moduleName repl
467+ Nothing -> error "Type synonym was not defined"
468+
469+expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
452expandTypeSynonym name args = do
470expandTypeSynonym name args = do
453 env <- getEnv
471 env <- getEnv
454 Just moduleName <- checkCurrentModule <$> get
472 Just moduleName <- checkCurrentModule <$> get
455− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
473+ either throwError return $ expandTypeSynonym' env moduleName name args
456− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
457− Nothing -> error "Type synonym was not defined"
458
474
459-- |
475-- |
460-- Ensure a set of property names and value does not contain duplicate labels
476-- Ensure a set of property names and value does not contain duplicate labels