855c372 · rowtype-yoga/purescript-native

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

Only generalize types for declarations without type annotations

commit855c37239ea0dc07f096f0a370b38c3d1145c4e5 authorPhil Freeman <paf31@cantab.net> dateWed 2 Mar 2016, 18:45 (11 years ago) parent3ed6f05

2 files changed+13−10

compare with golang

unifiedsplit

src/Language/PureScript/TypeChecker/Entailment.hs+4−3 src/Language/PureScript/TypeChecker/Types.hs+9−7

src/Language/PureScript/TypeChecker/Entailment.hs+4−3

@@ -36,11 +36,12 @@ import qualified Language.PureScript.Constants as C

3636entails

3737 :: forall m

3838 . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

39− => ModuleName

39+ => Bool

40+ -> ModuleName

4041 -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

4142 -> Constraint

4243 -> m (Expr, [(Ident, Constraint)])

43−entails moduleName context = solve

44+entails shouldGeneralize moduleName context = solve

4445 where

4546 forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

4647 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

@@ -83,7 +84,7 @@ entails moduleName context = solve

8384 where

8485

8586 unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)

86− unique [] | all canBeGeneralized tys' = return $ Right (className, tys)

87+ unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys)

8788 | otherwise = throwError . errorMessage $ NoInstanceFound className' tys'

8889 unique [a] = return $ Left a

8990 unique tcds | pairwise overlapping (map snd tcds) = do

src/Language/PureScript/TypeChecker/Types.hs+9−7

@@ -2,6 +2,7 @@

22{-# LANGUAGE ScopedTypeVariables #-}

33{-# LANGUAGE MultiParamTypeClasses #-}

44{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE TupleSections #-}

67-- |

78-- This module implements the type checker

@@ -71,22 +72,22 @@ typesOf moduleName vals = do

7172 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

7273 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

7374 ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict

74− return $ ds1 ++ ds2

75+ return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

7576

76− forM tys $ \(ident, (val, ty)) -> do

77+ forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do

7778 -- Replace type class dictionary placeholders with actual dictionaries

78− (val', unsolved) <- replaceTypeClassDictionaries moduleName val

79+ (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val

7980 -- Check skolem variables did not escape their scope

8081 skolemEscapeCheck val'

8182 -- Check rows do not contain duplicate labels

8283 checkDuplicateLabels val'

83− return (ident, (foldr (Abs . Left) val' (map fst unsolved), varIfUnknown (constrain unsolved ty)))

84+ return (ident, (foldr (Abs . Left . fst) val' unsolved, varIfUnknown (constrain unsolved ty)))

8485 where

8586 -- | Generalize over any unsolved constraints

8687 constrain [] = id

8788 constrain cs = ConstrainedType (map snd cs)

8889 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

89− tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts

90+ tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

9091 -- Replace all the wildcards types with their inferred types

9192 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty

9293 replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty))

@@ -173,14 +174,15 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

173174-- | Replace type class dictionary placeholders with inferred type class dictionaries

174175replaceTypeClassDictionaries ::

175176 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) =>

177+ Bool ->

176178 ModuleName ->

177179 Expr ->

178180 m (Expr, [(Ident, Constraint)])

179−replaceTypeClassDictionaries mn =

181+replaceTypeClassDictionaries shouldGeneralize mn =

180182 let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return

181183 in runWriterT . f

182184 where

183− go (TypeClassDictionary constraint dicts) = entails mn dicts constraint

185+ go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint

184186 go other = return (other, [])

185187

186188-- | Check the kind of a type, failing if it is not of kind *.