bb979a8 · rowtype-yoga/purescript-native

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

Typed holes

commitbb979a82733cbf43dc7e43cec31b3cc0c2d451c9 authorGary Burgess <gary.burgess@gmail.com> dateTue 19 Apr 2016, 16:29 (11 years ago) parentda1a498

8 files changed+70−3

compare with golang

unifiedsplit

examples/failing/TypedHole.purs+9 src/Language/PureScript/AST/Declarations.hs+4 src/Language/PureScript/Errors.hs+24−1 src/Language/PureScript/Parser/Declarations.hs+4 src/Language/PureScript/Parser/Lexer.hs+10 src/Language/PureScript/Pretty/Values.hs+1 src/Language/PureScript/TypeChecker/Monad.hs+1 src/Language/PureScript/TypeChecker/Types.hs+17−2

examples/failing/TypedHole.pursnew file+9

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

1+-- @shouldFailWith HoleInferredType

2+module Main where

4+import Prelude

5+import Control.Monad.Eff (Eff)

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

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

440440 --

441441 | AnonymousArgument

442442 -- |

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

444+ --

445+ | Hole String

446+ -- |

443447 -- A value with source position information

444448 --

445449 | PositionedValue SourceSpan [Comment] Expr

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

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

1010import Data.Ord (comparing)

1111import Data.Char (isSpace)

1212import Data.Either (lefts, rights)

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

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

1414import Data.Foldable (fold)

1515import Data.Maybe (maybeToList)

1616

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

128128 | ShadowedTypeVar String

129129 | UnusedTypeVar String

130130 | WildcardInferredType Type

131+ | HoleInferredType String Type

131132 | MissingTypeDeclaration Ident Type

132133 | NotExhaustivePattern [[Binder]] Bool

133134 | OverlappingPattern [[Binder]] Bool

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

316317 ShadowedTypeVar{} -> "ShadowedTypeVar"

317318 UnusedTypeVar{} -> "UnusedTypeVar"

318319 WildcardInferredType{} -> "WildcardInferredType"

320+ HoleInferredType{} -> "HoleInferredType"

319321 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

320322 NotExhaustivePattern{} -> "NotExhaustivePattern"

321323 OverlappingPattern{} -> "OverlappingPattern"

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

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

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

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

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

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

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

440443

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

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

873876 , indent $ typeAsBox ty

874877 ]

878+ renderSimpleErrorMessage (HoleInferredType name ty) =

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

880+ , indent $ typeAsBox ty

881+ ]

875882 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

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

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

13621369withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

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

13641371

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+

13651388-- |

13661389-- Collect errors in in parallel

13671390--

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

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

392392 , parseLet

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

394394 , parseOperatorSection

395+ , parseHole

395396 ]

396397

397398-- |

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

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

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

409410

411+parseHole :: TokenParser Expr

412+parseHole = Hole <$> holeLit

413+

410414parsePropertyUpdate :: TokenParser (String, Expr)

411415parsePropertyUpdate = do

412416 name <- lname <|> stringLiteral

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

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

4848 , semi

4949 , at

5050 , underscore

51+ , holeLit

5152 , semiSep

5253 , semiSep1

5354 , commaSep

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

115116 | CharLiteral Char

116117 | StringLiteral String

117118 | Number (Either Integer Double)

119+ | HoleLit String

118120 deriving (Show, Read, Eq, Ord)

119121

120122prettyPrintToken :: Token -> String

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

146148prettyPrintToken (CharLiteral c) = show c

147149prettyPrintToken (StringLiteral s) = show s

148150prettyPrintToken (Number n) = either show show n

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

149152

150153data PositionedToken = PositionedToken

151154 { ptSourcePos :: P.SourcePos

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

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

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

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

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

212216 , LName <$> parseLName

213217 , do uName <- parseUName

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

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

376380underscore :: TokenParser ()

377381underscore = match Underscore

378382

383+holeLit :: TokenParser String

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

385+ where

386+ go (HoleLit n) = Just n

387+ go _ = Nothing

388+

379389-- |

380390-- Parse zero or more values separated by semicolons

381391--

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

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

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

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

6666prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

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

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

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

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

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

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

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

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

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

228+

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

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

230231guardWith _ True = return ()

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

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

7474 [(Ident, Expr)] ->

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

7676typesOf bindingGroupType moduleName vals = do

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

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

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

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

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

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

109109 checkDuplicateLabels val'

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

111111 where

112+

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

113114 generalize unsolved = varIfUnknown . constrain unsolved

115+

114116 -- | Add any unsolved constraints

115117 constrain [] = id

116118 constrain cs = ConstrainedType (map snd cs)

119+

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

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

122+

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

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

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

125+ ErrorMessage hints . WildcardInferredType $ substituteType sub ty

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

127+ ErrorMessage hints . HoleInferredType name $ substituteType sub ty

121128 replace _ em = em

122129

130+ isHoleError :: ErrorMessage -> Bool

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

132+ isHoleError _ = False

133+

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

124135

125136type UntypedData = [(Ident, Type)]

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

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

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

318329 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

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

320335 TypedValue t v ty <- infer' val

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