2541264 · rowtype-yoga/purescript-native

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

Merge master

commit25412648b7ccc9f4222106a7693d6daf4a634fbd authorPhil Freeman <paf31@cantab.net> dateSat 24 Oct 2015, 14:52 (11 years ago) parent8432b7c 0e6bfae

5 files changed+40−30

compare with golang

unifiedsplit

examples/passing/TypedBinders.purs+6−1 src/Language/PureScript/Errors.hs+4−4 src/Language/PureScript/Pretty/Types.hs+10−4 src/Language/PureScript/Sugar/TypeDeclarations.hs+14−20 src/Language/PureScript/TypeChecker/Types.hs+6−1

examples/passing/TypedBinders.purs+6−1

@@ -54,9 +54,14 @@ test3 n = case n of

5454test4 :: Tuple Int Int -> Tuple Int Int

5555test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a)

5656

57+type Int1 = Int

58+

59+test5 :: Int1 -> Int1

60+test5 = \(x :: Int1) -> x

61+

5762main = do

5863 let t1 = test

5964 t2 = test2 id

6065 t3 = test3 1

6166 t4 = test4 (Tuple 1 0)

62− Control.Monad.Eff.Console.log "Done"

67+ Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/Errors.hs+4−4

@@ -137,7 +137,7 @@ data SimpleErrorMessage

137137 | ShadowedTypeVar String

138138 | UnusedTypeVar String

139139 | WildcardInferredType Type

140− | MissingTypeDeclaration Ident

140+ | MissingTypeDeclaration Ident Type

141141 | NotExhaustivePattern [[Binder]] Bool

142142 | OverlappingPattern [[Binder]] Bool

143143 | IncompleteExhaustivityCheck

@@ -671,11 +671,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

671671 paras [ line "Wildcard type definition has the inferred type "

672672 , indent $ typeAsBox ty

673673 ]

674− renderSimpleErrorMessage (MissingTypeDeclaration ident) =

674+ renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

675675 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

676676 , line "It is good practice to provide type declarations as a form of documentation."

677− , line "Consider using a type wildcard to display the inferred type:"

678− , indent $ line $ showIdent ident ++ " :: _"

677+ , line $ "The inferred type of " ++ showIdent ident ++ " was:"

678+ , indent $ typeAsBox ty

679679 ]

680680 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

681681 paras $ [ line "A case expression could not be determined to cover all inputs."

src/Language/PureScript/Pretty/Types.hs+10−4

@@ -46,14 +46,13 @@ typeLiterals = mkPattern match

4646 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

4747 match (TUnknown u) = Just $ text $ '_' : show u

4848 match (Skolem name s _) = Just $ text $ name ++ show s

49− match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty

5049 match REmpty = Just $ text "()"

5150 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

5251 match _ = Nothing

5352

54−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box

55−constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty

56−constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty)

53+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

54+constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

55+constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

5756

5857constraintAsBox :: Qualified ProperName -> [Type] -> Box

5958constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

@@ -115,6 +114,12 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes

115114 go idents other = PrettyPrintForAll idents other

116115 convertForAlls other = other

117116

117+constrained :: Pattern () Type ([Constraint], Type)

118+constrained = mkPattern match

119+ where

120+ match (ConstrainedType deps ty) = Just (deps, ty)

121+ match _ = Nothing

122+

118123matchTypeAtom :: Pattern () Type Box

119124matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

120125

@@ -126,6 +131,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

126131 OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

127132 , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

128133 ]

134+ , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

129135 , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

130136 , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]

131137 ]

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−20

@@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations (

2525#if __GLASGOW_HASKELL__ < 710

2626import Control.Applicative

2727#endif

28−import Control.Monad (forM, when)

28+import Control.Monad (forM)

2929import Control.Monad.Error.Class (MonadError(..))

30−import Control.Monad.Writer.Class (MonadWriter(tell))

3130

3231import Language.PureScript.Crash

3332import Language.PureScript.AST

@@ -39,19 +38,19 @@ import Language.PureScript.Traversals

3938-- |

4039-- Replace all top level type declarations in a module with type annotations

4140--

42−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

41+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

4342desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

4443 rethrow (addHint (ErrorInModule name)) $

45− Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps

44+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

4645 where

4746

48− desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

49− desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do

50− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)

47+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]

48+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

5150 return (PositionedDeclaration pos com d' : ds')

52− desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do

51+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

5352 (_, nameKind, val) <- fromValueDeclaration d

54− desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

53+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

5554 where

5655 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

5756 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

@@ -59,19 +58,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

5958 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

6059 return (ident, nameKind, PositionedValue pos com val)

6160 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

62− desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

63− desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do

64− -- At the top level, match a type signature or emit a warning.

65− when reqd $ case val of

66− Right TypedValue{} -> return ()

67− Left _ -> internalError "desugarTypeDeclarations: cases were not desugared"

68− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

61+ desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

62+ desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

6963 let (_, f, _) = everywhereOnValuesTopDownM return go return

7064 f' (Left gs) = Left <$> mapM (pairM return f) gs

7165 f' (Right v) = Right <$> f v

72− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest

66+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

7367 where

74− go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'

68+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

7569 go other = return other

76− desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

77− desugarTypeDeclarations _ [] = return []

70+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

71+ desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker/Types.hs+6−1

@@ -50,6 +50,7 @@ import Control.Monad

5050import Control.Monad.State

5151import Control.Monad.Unify

5252import Control.Monad.Error.Class (MonadError(..))

53+import Control.Monad.Writer.Class (tell)

5354

5455import Language.PureScript.Crash

5556import Language.PureScript.AST

@@ -94,6 +95,7 @@ typesOf moduleName vals = do

9495 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

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

9697 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

98+ replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty))

9799 replace _ em = em

98100

99101type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -140,6 +142,7 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do

140142 -- Infer the type with the new names in scope

141143 TypedValue _ val' ty <- bindNames dict $ infer val

142144 ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

145+ tell . errorMessage $ MissingTypeDeclaration ident ty

143146 return (ident, (TypedValue True val' ty, ty))

144147

145148-- |

@@ -373,7 +376,9 @@ inferBinder val (PositionedBinder pos _ binder) =

373376 warnAndRethrowWithPosition pos $ inferBinder val binder

374377-- TODO: When adding support for polymorphic types, check subsumption here

375378-- and change the definition of `binderRequiresMonotype`

376−inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder

379+inferBinder val (TypedBinder ty binder) = do

380+ ty' <- replaceAllTypeSynonyms ty

381+ val =?= ty' >> inferBinder val binder

377382

378383-- | Returns true if a binder requires its argument type to be a monotype.

379384-- | If this is the case, we need to instantiate any polymorphic types before checking binders.