855c372 · rowtype-yoga/purescript-native

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

on golang help sign in

Only generalize types for declarations without type annotations

855c372Phil Freeman11 years ago

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

compare with golang

unifiedsplit

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

36entails

37 :: forall m

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

39+ => Bool

39− => ModuleName

40+ -> ModuleName

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

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

41 -> Constraint

42 -> Constraint

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

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

43−entails moduleName context = solve

44+entails shouldGeneralize moduleName context = solve

44 where

45 where

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

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

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

47 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

83 where

84 where

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

86 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)

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

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

88 unique [a] = return $ Left a

89 unique [a] = return $ Left a

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

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

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

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

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE TupleSections #-}

6-- |

7-- |

7-- This module implements the type checker

8-- This module implements the type checker

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

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

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

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

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

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

74 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)

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

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

77 -- Replace type class dictionary placeholders with actual dictionaries

78 -- Replace type class dictionary placeholders with actual dictionaries

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

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

79 -- Check skolem variables did not escape their scope

80 -- Check skolem variables did not escape their scope

80 skolemEscapeCheck val'

81 skolemEscapeCheck val'

81 -- Check rows do not contain duplicate labels

82 -- Check rows do not contain duplicate labels

82 checkDuplicateLabels val'

83 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)))

84 where

85 where

85 -- | Generalize over any unsolved constraints

86 -- | Generalize over any unsolved constraints

86 constrain [] = id

87 constrain [] = id

87 constrain cs = ConstrainedType (map snd cs)

88 constrain cs = ConstrainedType (map snd cs)

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

89 -- 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

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

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

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

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

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

93 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'

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

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

174replaceTypeClassDictionaries ::

175replaceTypeClassDictionaries ::

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

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

177+ Bool ->

176 ModuleName ->

178 ModuleName ->

177 Expr ->

179 Expr ->

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

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

179−replaceTypeClassDictionaries mn =

181+replaceTypeClassDictionaries shouldGeneralize mn =

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

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

181 in runWriterT . f

183 in runWriterT . f

182 where

184 where

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

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

184 go other = return (other, [])

186 go other = return (other, [])

185

187

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

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