38d43e4 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Fix type synonym bugs

commit38d43e4afe332d77620b3471ad06ff7d232883c1 authorPhil Freeman <paf31@cantab.net> dateTue 29 Oct 2013, 17:31 (13 years ago) parentc584c40

4 files changed+54−35

compare with golang

unifiedsplit

examples/TypeSynonyms.ps+17−1 src/PureScript/CodeGen/Externs.hs+3 src/PureScript/TypeChecker/Synonyms.hs+10−12 src/PureScript/TypeChecker/Types.hs+24−22

examples/TypeSynonyms.ps+17−1

@@ -1,6 +1,6 @@

11type Lens a b =

22 { get :: a -> b

3− ; set :: a -> b -> b

3+ ; set :: a -> b -> a

44 }

66composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

@@ -11,3 +11,19 @@ composeLenses = \l1 -> \l2 ->

1111 var b1 = l2.set b c

1212 return l1.set a b1

1313 }

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

2121import PureScript.Declarations

2222import PureScript.TypeChecker.Monad

2323import PureScript.CodeGen.Pretty.Types

24+import PureScript.CodeGen.Pretty.Kinds

2425

2526externToPs :: Environment -> Declaration -> Maybe String

2627externToPs env (ValueDeclaration name _) = do

@@ -28,6 +29,8 @@ externToPs env (ValueDeclaration name _) = do

2829 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty

2930externToPs env (ExternDeclaration name ty) =

3031 return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty

32+externToPs env (ExternDataDeclaration name kind) =

33+ return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind

3134externToPs env (TypeSynonymDeclaration name args ty) =

3235 return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty

3336externToPs _ _ = Nothing

src/PureScript/TypeChecker/Synonyms.hs+10−12

@@ -36,23 +36,21 @@ replaceTypeVars m = everywhere (mkT replace)

3636 replace t@(TypeVar var) = fromMaybe t (M.lookup var m)

3737 replace t = t

3838

39−buildTypeSubstitution :: String -> Type -> [String] -> Type -> WriterT Any (Either String) (Maybe Type)

39+buildTypeSubstitution :: String -> Type -> [String] -> Type -> Either String (Maybe Type)

4040buildTypeSubstitution name ty args = go (reverse args) M.empty

4141 where

42− go :: [String] -> M.Map String Type -> Type -> WriterT Any (Either String) (Maybe Type)

43− go [] m (TypeConstructor ctor) | name == ctor = tell (Any True) >> return (Just $ replaceTypeVars m ty)

44− go (_:_) _ (TypeConstructor ctor) | name == ctor = lift . throwError $ "Partially applied type synonym " ++ name

42+ go :: [String] -> M.Map String Type -> Type -> Either String (Maybe Type)

43+ go [] m (TypeConstructor ctor) | name == ctor = return (Just $ replaceTypeVars m ty)

44+ go (_:_) _ (TypeConstructor ctor) | name == ctor = throwError $ "Partially applied type synonym " ++ name

4545 go (arg:args) m (TypeApp f x) = go args (M.insert arg x m) f

4646 go _ _ _ = return Nothing

4747

48−everywhereButM' :: (Monad m, Data d) => (forall d. (Data d) => d -> WriterT Any m d) -> d -> m d

49−everywhereButM' f x = do

50− (y, halt) <- runWriterT $ f x

51− case getAny halt of

52− True -> return y

53− _ -> gmapM (everywhereButM' f) y

48+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d

49+everywhereM' f x = do

50+ y <- f x

51+ gmapM (everywhereM' f) y

5452

55−substituteTypeSynonym :: String -> [String] -> Type -> Type -> Either String Type

56−substituteTypeSynonym name args ty = everywhereButM' (mkM replace)

53+substituteTypeSynonym :: (Data d) => String -> [String] -> Type -> d -> Either String d

54+substituteTypeSynonym name args ty = everywhereM' (mkM replace)

5755 where

5856 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name ty args t

src/PureScript/TypeChecker/Types.hs+24−22

@@ -12,6 +12,8 @@

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

1517module PureScript.TypeChecker.Types (

1618 TypeConstraint(..),

1719 TypeSolution(..),

@@ -20,7 +22,7 @@ module PureScript.TypeChecker.Types (

2022

2123import Data.List

2224import Data.Function

23−import Data.Data (Data(..))

25+import qualified Data.Data as D

2426import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)

2527

2628import PureScript.Values

@@ -44,7 +46,7 @@ import qualified Data.Map as M

4446

4547data TypeConstraint

4648 = TypeConstraint Int Type

47− | RowConstraint Int Row deriving Show

49+ | RowConstraint Int Row deriving (Show, D.Data, D.Typeable)

4850

4951newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }

5052

@@ -59,9 +61,10 @@ typeOf name val = do

5961 (cs, n) <- typeConstraints (M.singleton name me) val

6062 return (TypeConstraint me (TUnknown n) : cs, n)

6163 _ -> typeConstraints M.empty val

62− solution <- solveTypeConstraints cs emptyTypeSolution

64+ desugared <- replaceAllTypeSynonyms cs

65+ solution <- solveTypeConstraints desugared emptyTypeSolution

6366 let ty = fst (runTypeSolution solution) n

64− allUnknownsBecameQuantified cs solution ty

67+ allUnknownsBecameQuantified desugared solution ty

6568 return $ varIfUnknown ty

6669

6770allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

@@ -81,21 +84,21 @@ allUnknownsBecameQuantified cs solution ty = do

8184 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

8285 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

8386

84−findUnknownTypes :: (Data d) => d -> [Int]

87+findUnknownTypes :: (D.Data d) => d -> [Int]

8588findUnknownTypes = everything (++) (mkQ [] f)

8689 where

8790 f :: Type -> [Int]

8891 f (TUnknown n) = [n]

8992 f _ = []

9093

91−findTypeVars :: (Data d) => d -> [String]

94+findTypeVars :: (D.Data d) => d -> [String]

9295findTypeVars = everything (++) (mkQ [] f)

9396 where

9497 f :: Type -> [String]

9598 f (TypeVar v) = [v]

9699 f _ = []

97100

98−findUnknownRows :: (Data d) => d -> [Int]

101+findUnknownRows :: (D.Data d) => d -> [Int]

99102findUnknownRows = everything (++) (mkQ [] f)

100103 where

101104 f :: Row -> [Int]

@@ -154,13 +157,23 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext

154157 Just u -> return $ RUnknown u

155158 g r = return r

156159

157−replaceType :: (Data d) => Int -> Type -> d -> d

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+

170+replaceType :: (D.Data d) => Int -> Type -> d -> d

158171replaceType n t = everywhere (mkT go)

159172 where

160173 go (TUnknown m) | m == n = t

161174 go t = t

162175

163−replaceRow :: (Data d) => Int -> Row -> d -> d

176+replaceRow :: (D.Data d) => Int -> Row -> d -> d

164177replaceRow n r = everywhere (mkT go)

165178 where

166179 go (RUnknown m) | m == n = r

@@ -174,7 +187,7 @@ rowOccursCheck :: Int -> Row -> Check ()

174187rowOccursCheck u (RUnknown _) = return ()

175188rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r

176189

177−occursCheck :: (Data d) => Int -> d -> Bool

190+occursCheck :: (D.Data d) => Int -> d -> Bool

178191occursCheck u = everything (||) $ flip extQ g $ mkQ False f

179192 where

180193 f (TUnknown u') | u' == u = True

@@ -276,19 +289,8 @@ typeConstraints m (IfThenElse cond th el) = do

276289typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do

277290 kind <- kindOf poly

278291 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

279− desugared <- replaceAllTypeSynonyms ty

280292 (cs, n1) <- typeConstraints m val

281− return (TypeConstraint n1 desugared : 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'

293+ return (TypeConstraint n1 ty : cs, n1)

292294

293295unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]

294296unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]