git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix type synonym bugs
38d43e4Phil Freeman
examples/TypeSynonyms.ps+17−1
compare with golang
unifiedsplit
@@ -1,6 +1,6 @@
1type Lens a b =
1type Lens a b =
2 { get :: a -> b
2 { get :: a -> b
3− ; set :: a -> b -> b
3+ ; set :: a -> b -> a
4 }
4 }
5
5
6composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
6composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
@@ -11,3 +11,19 @@ composeLenses = \l1 -> \l2 ->
11 var b1 = l2.set b c
11 var b1 = l2.set b c
12 return l1.set a b1
12 return l1.set a b1
13 }
13 }
14+
15+type Pair a b = { fst :: a; snd :: b }
16+
17+fst :: forall a b. Lens (Pair a b) a
18+fst = {
19+ get: \p -> p.fst,
20+ set: \p -> \a -> { fst: a, snd: p.snd }
21+}
22+
23+test1 :: forall a b c. Lens (Pair (Pair a b) c) a
24+test1 = composeLenses fst fst
25+
26+extern head :: forall a. Lens [a] a
27+
28+test2 :: forall a b c. Lens (Pair [Pair a b] c) a
29+test2 = composeLenses fst (composeLenses head fst)
src/PureScript/CodeGen/Externs.hs+3
@@ -21,6 +21,7 @@ import qualified Data.Map as M
21import PureScript.Declarations
21import PureScript.Declarations
22import PureScript.TypeChecker.Monad
22import PureScript.TypeChecker.Monad
23import PureScript.CodeGen.Pretty.Types
23import PureScript.CodeGen.Pretty.Types
24+import PureScript.CodeGen.Pretty.Kinds
24
25
25externToPs :: Environment -> Declaration -> Maybe String
26externToPs :: Environment -> Declaration -> Maybe String
26externToPs env (ValueDeclaration name _) = do
27externToPs env (ValueDeclaration name _) = do
@@ -28,6 +29,8 @@ externToPs env (ValueDeclaration name _) = do
28 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
29 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
29externToPs env (ExternDeclaration name ty) =
30externToPs env (ExternDeclaration name ty) =
30 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
31 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
32+externToPs env (ExternDataDeclaration name kind) =
33+ return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind
31externToPs env (TypeSynonymDeclaration name args ty) =
34externToPs env (TypeSynonymDeclaration name args ty) =
32 return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty
35 return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty
33externToPs _ _ = Nothing
36externToPs _ _ = Nothing
src/PureScript/TypeChecker/Synonyms.hs+10−12
@@ -36,23 +36,21 @@ replaceTypeVars m = everywhere (mkT replace)
36 replace t@(TypeVar var) = fromMaybe t (M.lookup var m)
36 replace t@(TypeVar var) = fromMaybe t (M.lookup var m)
37 replace t = t
37 replace t = t
38
38
39−buildTypeSubstitution :: String -> Type -> [String] -> Type -> WriterT Any (Either String) (Maybe Type)
39+buildTypeSubstitution :: String -> Type -> [String] -> Type -> Either String (Maybe Type)
40buildTypeSubstitution name ty args = go (reverse args) M.empty
40buildTypeSubstitution name ty args = go (reverse args) M.empty
41 where
41 where
42− go :: [String] -> M.Map String Type -> Type -> WriterT Any (Either String) (Maybe Type)
42+ go :: [String] -> M.Map String Type -> Type -> Either String (Maybe Type)
43− go [] m (TypeConstructor ctor) | name == ctor = tell (Any True) >> return (Just $ replaceTypeVars m ty)
43+ go [] m (TypeConstructor ctor) | name == ctor = return (Just $ replaceTypeVars m ty)
44− go (_:_) _ (TypeConstructor ctor) | name == ctor = lift . throwError $ "Partially applied type synonym " ++ name
44+ go (_:_) _ (TypeConstructor ctor) | name == ctor = throwError $ "Partially applied type synonym " ++ name
45 go (arg:args) m (TypeApp f x) = go args (M.insert arg x m) f
45 go (arg:args) m (TypeApp f x) = go args (M.insert arg x m) f
46 go _ _ _ = return Nothing
46 go _ _ _ = return Nothing
47
47
48−everywhereButM' :: (Monad m, Data d) => (forall d. (Data d) => d -> WriterT Any m d) -> d -> m d
48+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d
49−everywhereButM' f x = do
49+everywhereM' f x = do
50− (y, halt) <- runWriterT $ f x
50+ y <- f x
51− case getAny halt of
51+ gmapM (everywhereM' f) y
52− True -> return y
53− _ -> gmapM (everywhereButM' f) y
54
52
55−substituteTypeSynonym :: String -> [String] -> Type -> Type -> Either String Type
53+substituteTypeSynonym :: (Data d) => String -> [String] -> Type -> d -> Either String d
56−substituteTypeSynonym name args ty = everywhereButM' (mkM replace)
54+substituteTypeSynonym name args ty = everywhereM' (mkM replace)
57 where
55 where
58 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name ty args t
56 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name ty args t
src/PureScript/TypeChecker/Types.hs+24−22
@@ -12,6 +12,8 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
15module PureScript.TypeChecker.Types (
17module PureScript.TypeChecker.Types (
16 TypeConstraint(..),
18 TypeConstraint(..),
17 TypeSolution(..),
19 TypeSolution(..),
@@ -20,7 +22,7 @@ module PureScript.TypeChecker.Types (
20
22
21import Data.List
23import Data.List
22import Data.Function
24import Data.Function
23−import Data.Data (Data(..))
25+import qualified Data.Data as D
24import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
26import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
25
27
26import PureScript.Values
28import PureScript.Values
@@ -44,7 +46,7 @@ import qualified Data.Map as M
44
46
45data TypeConstraint
47data TypeConstraint
46 = TypeConstraint Int Type
48 = TypeConstraint Int Type
47− | RowConstraint Int Row deriving Show
49+ | RowConstraint Int Row deriving (Show, D.Data, D.Typeable)
48
50
49newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }
51newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }
50
52
@@ -59,9 +61,10 @@ typeOf name val = do
59 (cs, n) <- typeConstraints (M.singleton name me) val
61 (cs, n) <- typeConstraints (M.singleton name me) val
60 return (TypeConstraint me (TUnknown n) : cs, n)
62 return (TypeConstraint me (TUnknown n) : cs, n)
61 _ -> typeConstraints M.empty val
63 _ -> typeConstraints M.empty val
64+ desugared <- replaceAllTypeSynonyms cs
62− solution <- solveTypeConstraints cs emptyTypeSolution
65+ solution <- solveTypeConstraints desugared emptyTypeSolution
63 let ty = fst (runTypeSolution solution) n
66 let ty = fst (runTypeSolution solution) n
64− allUnknownsBecameQuantified cs solution ty
67+ allUnknownsBecameQuantified desugared solution ty
65 return $ varIfUnknown ty
68 return $ varIfUnknown ty
66
69
67allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()
70allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()
@@ -81,21 +84,21 @@ allUnknownsBecameQuantified cs solution ty = do
81 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
84 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
82 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
85 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
83
86
84−findUnknownTypes :: (Data d) => d -> [Int]
87+findUnknownTypes :: (D.Data d) => d -> [Int]
85findUnknownTypes = everything (++) (mkQ [] f)
88findUnknownTypes = everything (++) (mkQ [] f)
86 where
89 where
87 f :: Type -> [Int]
90 f :: Type -> [Int]
88 f (TUnknown n) = [n]
91 f (TUnknown n) = [n]
89 f _ = []
92 f _ = []
90
93
91−findTypeVars :: (Data d) => d -> [String]
94+findTypeVars :: (D.Data d) => d -> [String]
92findTypeVars = everything (++) (mkQ [] f)
95findTypeVars = everything (++) (mkQ [] f)
93 where
96 where
94 f :: Type -> [String]
97 f :: Type -> [String]
95 f (TypeVar v) = [v]
98 f (TypeVar v) = [v]
96 f _ = []
99 f _ = []
97
100
98−findUnknownRows :: (Data d) => d -> [Int]
101+findUnknownRows :: (D.Data d) => d -> [Int]
99findUnknownRows = everything (++) (mkQ [] f)
102findUnknownRows = everything (++) (mkQ [] f)
100 where
103 where
101 f :: Row -> [Int]
104 f :: Row -> [Int]
@@ -154,13 +157,23 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext
154 Just u -> return $ RUnknown u
157 Just u -> return $ RUnknown u
155 g r = return r
158 g r = return r
156
159
160+replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
161+replaceAllTypeSynonyms ty = do
162+ env <- getEnv
163+ go (M.toList $ typeSynonyms env) ty
164+ where
165+ go [] d = return d
166+ go ((name, (args, repl)):rest) d = do
167+ d' <- either throwError return (substituteTypeSynonym name args repl d)
168+ go rest d'
169+
157−replaceType :: (Data d) => Int -> Type -> d -> d
170+replaceType :: (D.Data d) => Int -> Type -> d -> d
158replaceType n t = everywhere (mkT go)
171replaceType n t = everywhere (mkT go)
159 where
172 where
160 go (TUnknown m) | m == n = t
173 go (TUnknown m) | m == n = t
161 go t = t
174 go t = t
162
175
163−replaceRow :: (Data d) => Int -> Row -> d -> d
176+replaceRow :: (D.Data d) => Int -> Row -> d -> d
164replaceRow n r = everywhere (mkT go)
177replaceRow n r = everywhere (mkT go)
165 where
178 where
166 go (RUnknown m) | m == n = r
179 go (RUnknown m) | m == n = r
@@ -174,7 +187,7 @@ rowOccursCheck :: Int -> Row -> Check ()
174rowOccursCheck u (RUnknown _) = return ()
187rowOccursCheck u (RUnknown _) = return ()
175rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r
188rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r
176
189
177−occursCheck :: (Data d) => Int -> d -> Bool
190+occursCheck :: (D.Data d) => Int -> d -> Bool
178occursCheck u = everything (||) $ flip extQ g $ mkQ False f
191occursCheck u = everything (||) $ flip extQ g $ mkQ False f
179 where
192 where
180 f (TUnknown u') | u' == u = True
193 f (TUnknown u') | u' == u = True
@@ -276,19 +289,8 @@ typeConstraints m (IfThenElse cond th el) = do
276typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
289typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
277 kind <- kindOf poly
290 kind <- kindOf poly
278 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
291 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
279− desugared <- replaceAllTypeSynonyms ty
280 (cs, n1) <- typeConstraints m val
292 (cs, n1) <- typeConstraints m val
281− return (TypeConstraint n1 desugared : cs, n1)
293+ return (TypeConstraint n1 ty : cs, n1)
282−
283−replaceAllTypeSynonyms :: Type -> Check Type
284−replaceAllTypeSynonyms ty = do
285− env <- getEnv
286− go (M.toList $ typeSynonyms env) ty
287− where
288− go [] ty = return ty
289− go ((name, (args, repl)):rest) ty = do
290− ty' <- either throwError return (substituteTypeSynonym name args repl ty)
291− go rest ty'
292
294
293unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]
295unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]
294unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]
296unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]