bb979a8 · rowtype-yoga/purescript-native

examples/failing/TypedHole.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+-- @shouldFailWith HoleInferredType

2+module Main where

3+

4+import Prelude

5+import Control.Monad.Eff (Eff)

6+import Control.Monad.Eff.Console (CONSOLE, log)

7+

8+main :: forall e. Eff (console :: CONSOLE | e) Unit

9+main = ?ummm

src/Language/PureScript/AST/Declarations.hs+4

@@ -440,6 +440,10 @@ data Expr

440 --

441 | AnonymousArgument

442 -- |

443+ -- A typed hole that will be turned into a hint/error duing typechecking

444+ --

445+ | Hole String

446+ -- |

443 -- A value with source position information

447 -- A value with source position information

444 --

448 --

445 | PositionedValue SourceSpan [Comment] Expr

449 | PositionedValue SourceSpan [Comment] Expr

src/Language/PureScript/Errors.hs+24−1

@@ -10,7 +10,7 @@ import Prelude.Compat

10import Data.Ord (comparing)

11import Data.Char (isSpace)

12import Data.Either (lefts, rights)

13−import Data.List (intercalate, transpose, nub, nubBy, sortBy)

13+import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

14import Data.Foldable (fold)

15import Data.Maybe (maybeToList)

16

@@ -128,6 +128,7 @@ data SimpleErrorMessage

128 | ShadowedTypeVar String

129 | UnusedTypeVar String

130 | WildcardInferredType Type

131+ | HoleInferredType String Type

131 | MissingTypeDeclaration Ident Type

132 | MissingTypeDeclaration Ident Type

132 | NotExhaustivePattern [[Binder]] Bool

133 | NotExhaustivePattern [[Binder]] Bool

133 | OverlappingPattern [[Binder]] Bool

134 | OverlappingPattern [[Binder]] Bool

@@ -316,6 +317,7 @@ errorCode em = case unwrapErrorMessage em of

316 ShadowedTypeVar{} -> "ShadowedTypeVar"

317 ShadowedTypeVar{} -> "ShadowedTypeVar"

317 UnusedTypeVar{} -> "UnusedTypeVar"

318 UnusedTypeVar{} -> "UnusedTypeVar"

318 WildcardInferredType{} -> "WildcardInferredType"

319 WildcardInferredType{} -> "WildcardInferredType"

320+ HoleInferredType{} -> "HoleInferredType"

319 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

321 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

320 NotExhaustivePattern{} -> "NotExhaustivePattern"

322 NotExhaustivePattern{} -> "NotExhaustivePattern"

321 OverlappingPattern{} -> "OverlappingPattern"

323 OverlappingPattern{} -> "OverlappingPattern"

@@ -435,6 +437,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

435 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

437 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

436 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

438 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

437 gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

439 gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

440+ gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty

438 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

441 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

439 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

442 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

440

443

@@ -872,6 +875,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

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

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

873 , indent $ typeAsBox ty

876 , indent $ typeAsBox ty

874 ]

877 ]

878+ renderSimpleErrorMessage (HoleInferredType name ty) =

879+ paras [ line $ "Hole '" ++ name ++ "' has the inferred type "

880+ , indent $ typeAsBox ty

881+ ]

875 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

882 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

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

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

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

@@ -1362,6 +1369,22 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

1362withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

1369withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

1363withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

1370withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

1364

1371

1372+-- |

1373+-- Runs a computation listening for warnings and then escalating any warnings

1374+-- that match the predicate to error status.

1375+--

1376+escalateWarningWhen

1377+ :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)

1378+ => (ErrorMessage -> Bool)

1379+ -> m a

1380+ -> m a

1381+escalateWarningWhen isError ma = do

1382+ (a, w) <- censor (const mempty) $ listen ma

1383+ let (errors, warnings) = partition isError (runMultipleErrors w)

1384+ tell $ MultipleErrors warnings

1385+ unless (null errors) $ throwError $ MultipleErrors errors

1386+ return a

1387+

1365-- |

1388-- |

1366-- Collect errors in in parallel

1389-- Collect errors in in parallel

1367--

1390--

src/Language/PureScript/Parser/Declarations.hs+4

@@ -392,6 +392,7 @@ parseValueAtom = P.choice

392 , parseLet

393 , P.try $ Parens <$> parens parseValue

394 , parseOperatorSection

395+ , parseHole

395 ]

396 ]

396

397

397-- |

398-- |

@@ -407,6 +408,9 @@ parseOperatorSection = parens $ left <|> right

407 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

408 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

408 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

409 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

409

410

411+parseHole :: TokenParser Expr

412+parseHole = Hole <$> holeLit

413+

410parsePropertyUpdate :: TokenParser (String, Expr)

414parsePropertyUpdate :: TokenParser (String, Expr)

411parsePropertyUpdate = do

415parsePropertyUpdate = do

412 name <- lname <|> stringLiteral

416 name <- lname <|> stringLiteral

src/Language/PureScript/Parser/Lexer.hs+10

@@ -48,6 +48,7 @@ module Language.PureScript.Parser.Lexer

48 , semi

49 , at

50 , underscore

51+ , holeLit

51 , semiSep

52 , semiSep

52 , semiSep1

53 , semiSep1

53 , commaSep

54 , commaSep

@@ -115,6 +116,7 @@ data Token

115 | CharLiteral Char

116 | CharLiteral Char

116 | StringLiteral String

117 | StringLiteral String

117 | Number (Either Integer Double)

118 | Number (Either Integer Double)

119+ | HoleLit String

118 deriving (Show, Read, Eq, Ord)

120 deriving (Show, Read, Eq, Ord)

119

121

120prettyPrintToken :: Token -> String

122prettyPrintToken :: Token -> String

@@ -146,6 +148,7 @@ prettyPrintToken (Symbol s) = s

146prettyPrintToken (CharLiteral c) = show c

148prettyPrintToken (CharLiteral c) = show c

147prettyPrintToken (StringLiteral s) = show s

149prettyPrintToken (StringLiteral s) = show s

148prettyPrintToken (Number n) = either show show n

150prettyPrintToken (Number n) = either show show n

151+prettyPrintToken (HoleLit name) = "?" ++ name

149

152

150data PositionedToken = PositionedToken

153data PositionedToken = PositionedToken

151 { ptSourcePos :: P.SourcePos

154 { ptSourcePos :: P.SourcePos

@@ -209,6 +212,7 @@ parseToken = P.choice

209 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

212 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

210 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

213 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

211 , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

214 , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

215+ , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter)

212 , LName <$> parseLName

216 , LName <$> parseLName

213 , do uName <- parseUName

217 , do uName <- parseUName

214 (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)

218 (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)

@@ -376,6 +380,12 @@ at = match At

376underscore :: TokenParser ()

380underscore :: TokenParser ()

377underscore = match Underscore

381underscore = match Underscore

378

382

383+holeLit :: TokenParser String

384+holeLit = token go P.<?> "hole literal"

385+ where

386+ go (HoleLit n) = Just n

387+ go _ = Nothing

388+

379-- |

389-- |

380-- Parse zero or more values separated by semicolons

390-- Parse zero or more values separated by semicolons

381--

391--

src/Language/PureScript/Pretty/Values.hs+1

@@ -64,6 +64,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

64prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

65prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

66prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

67+prettyPrintValue _ (Hole name) = text "?" <> text name

67prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

68prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

68prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

69prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

69prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

70prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

src/Language/PureScript/TypeChecker/Monad.hs+1

@@ -225,6 +225,7 @@ runCheck = runCheck' initEnvironment

225-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.

226runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)

227runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)

228+

228-- | Make an assertion, failing with an error message

229-- | Make an assertion, failing with an error message

229guardWith :: (MonadError e m) => e -> Bool -> m ()

230guardWith :: (MonadError e m) => e -> Bool -> m ()

230guardWith _ True = return ()

231guardWith _ True = return ()

src/Language/PureScript/TypeChecker/Types.hs+17−2

@@ -74,7 +74,7 @@ typesOf ::

74 [(Ident, Expr)] ->

75 m [(Ident, (Expr, Type))]

76typesOf bindingGroupType moduleName vals = do

77− tys <- fmap tidyUp . liftUnifyWarnings replace $ do

77+ tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do

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

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

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

@@ -109,17 +109,28 @@ typesOf bindingGroupType moduleName vals = do

109 checkDuplicateLabels val'

110 return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))

111 where

112+

112 -- | Generalize type vars using forall and add inferred constraints

113 -- | Generalize type vars using forall and add inferred constraints

113 generalize unsolved = varIfUnknown . constrain unsolved

114 generalize unsolved = varIfUnknown . constrain unsolved

115+

114 -- | Add any unsolved constraints

116 -- | Add any unsolved constraints

115 constrain [] = id

117 constrain [] = id

116 constrain cs = ConstrainedType (map snd cs)

118 constrain cs = ConstrainedType (map snd cs)

119+

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

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

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

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

122+

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

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

124+ replace sub (ErrorMessage hints (WildcardInferredType ty)) =

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

125+ ErrorMessage hints . WildcardInferredType $ substituteType sub ty

126+ replace sub (ErrorMessage hints (HoleInferredType name ty)) =

127+ ErrorMessage hints . HoleInferredType name $ substituteType sub ty

121 replace _ em = em

128 replace _ em = em

122

129

130+ isHoleError :: ErrorMessage -> Bool

131+ isHoleError (ErrorMessage _ HoleInferredType{}) = True

132+ isHoleError _ = False

133+

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

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

124

135

125type UntypedData = [(Ident, Type)]

136type UntypedData = [(Ident, Type)]

@@ -316,6 +327,10 @@ infer' (TypedValue checkType val ty) = do

316 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

327 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

317 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

328 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

318 return $ TypedValue True val' ty'

329 return $ TypedValue True val' ty'

330+infer' (Hole name) = do

331+ ty <- freshType

332+ tell . errorMessage $ HoleInferredType name ty

333+ return $ TypedValue True (Hole name) ty

319infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

334infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

320 TypedValue t v ty <- infer' val

335 TypedValue t v ty <- infer' val

321 return $ TypedValue t (PositionedValue pos c v) ty

336 return $ TypedValue t (PositionedValue pos c v) ty