cc947bd · rowtype-yoga/purescript-native

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

Add the ability to bypass type checking for a term, and therefore fix the ordering problem.

commitcc947bdf5c9181ff9fb1cd843562c88f1d10976e authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 20:53 (13 years ago) parent0828e3d

10 files changed+88−80

compare with golang

unifiedsplit

examples/passing/TypeClasses.purs−7 src/Language/PureScript.hs+3−2 src/Language/PureScript/CodeGen/JS.hs+2−2 src/Language/PureScript/Parser/Values.hs+1−1 src/Language/PureScript/Pretty/Values.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+13−1 src/Language/PureScript/Sugar/TypeClasses.hs+10−8 src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+56−56 src/Language/PureScript/Values.hs+1−1

examples/passing/TypeClasses.purs−7

@@ -1,8 +1,5 @@

11module TypeClasses where

3−import Eff

4−import Trace

5−

63class Show a where

74 show :: a -> String

@@ -43,7 +40,3 @@ test4 = ret 1

4340

4441test5 = Just 1 >>= \n -> ret (n + 1)

4542

46−module Main where

47−

48−main = eff do

49− print TypeClasses.test5

src/Language/PureScript.hs+3−2

@@ -35,8 +35,9 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)

3535compile opts ms = do

3636 desugared <- desugar ms

3737 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

38− let js = concatMap (flip (moduleToJs opts) env) $ elaborated

39− let exts = intercalate "\n" . map (flip moduleToPs env) $ elaborated

38+ let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

39+ let js = concatMap (flip (moduleToJs opts) env) $ regrouped

40+ let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped

4041 js' <- case () of

4142 _ | optionsRunMain opts -> do

4243 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

src/Language/PureScript/CodeGen/JS.hs+2−2

@@ -102,11 +102,11 @@ valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val

102102valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

103103valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)

104104valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])

105−valueToJs opts m e (TypedValue (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])

105+valueToJs opts m e (TypedValue _ (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])

106106valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

107107valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

108108valueToJs _ m e (Var ident) = varToJs m e ident

109−valueToJs opts m e (TypedValue val _) = valueToJs opts m e val

109+valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

110110valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

111111valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

112112

src/Language/PureScript/Parser/Values.hs+1−1

@@ -159,7 +159,7 @@ parseValue =

159159 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

160160 postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

161161 , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

162− , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

162+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

163163 , \v -> P.try $ Do v <$> (C.indented *> C.reserved "do" *> parseManyDoNotationElements)

164164 ]

165165 operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

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

@@ -86,7 +86,7 @@ lam = mkPattern match

8686typed :: Pattern () Value (Type, Value)

8787typed = mkPattern match

8888 where

89− match (TypedValue val ty) = Just (ty, val)

89+ match (TypedValue _ val ty) = Just (ty, val)

9090 match _ = Nothing

9191

9292unary :: UnaryOperator -> String -> Operator () Value String

src/Language/PureScript/Sugar/BindingGroups.hs+13−1

@@ -14,7 +14,9 @@

1414

1515module Language.PureScript.Sugar.BindingGroups (

1616 createBindingGroups,

17− createBindingGroupsModule

17+ createBindingGroupsModule,

18+ collapseBindingGroups,

19+ collapseBindingGroupsModule

1820) where

1921

2022import Data.Data

@@ -30,6 +32,9 @@ import Language.PureScript.Types

3032createBindingGroupsModule :: [Module] -> [Module]

3133createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)

3234

35+collapseBindingGroupsModule :: [Module] -> [Module]

36+collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)

37+

3338createBindingGroups :: [Declaration] -> [Declaration]

3439createBindingGroups ds =

3540 let

@@ -45,6 +50,13 @@ createBindingGroups ds =

4550 in

4651 dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

4752

53+collapseBindingGroups :: [Declaration] -> [Declaration]

54+collapseBindingGroups ds = concatMap go ds

55+ where

56+ go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds

57+ go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds

58+ go other = [other]

59+

4860usedIdents :: (Data d) => d -> [Ident]

4961usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)

5062 where

src/Language/PureScript/Sugar/TypeClasses.hs+10−8

@@ -75,17 +75,19 @@ typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)

7575typeInstanceDictionaryDeclaration mn deps name ty decls = do

7676 entryName <- lift $ mkDictionaryValueName mn name ty

7777 memberNames <- mapM memberToNameAndValue decls

78− return $ ExternDeclaration TypeClassDictionaryImport entryName

79− (Just (JSFunction (Just entryName)

78+ return $ ValueDeclaration entryName [] Nothing

79+ (TypedValue False

80+ (Abs

8081 (map (\n -> Ident ('_' : show n)) [1..length deps])

81− (JSBlock [JSReturn (JSObjectLiteral memberNames)])))

82− (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))

82+ (ObjectLiteral memberNames))

83+ (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))

84+ )

8385 where

84− memberToNameAndValue :: Declaration -> Desugar (String, JS)

86+ memberToNameAndValue :: Declaration -> Desugar (String, Value)

8587 memberToNameAndValue (ValueDeclaration ident _ _ _) = do

8688 memberName <- mkDictionaryEntryName mn name ty ident

87− return (identToJs ident, if null deps then JSVar memberName

88− else JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))

89+ return (identToJs ident, if null deps then Var (Qualified Nothing memberName)

90+ else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

8991 memberToNameAndValue _ = error "Invalid declaration in type instance definition"

9092

9193typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

@@ -97,7 +99,7 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [

9799 return $ replaceTypeVars arg ty ty'

98100 entryName <- mkDictionaryEntryName mn name ty ident

99101 return $ ValueDeclaration entryName [] Nothing

100− (TypedValue val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

102+ (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

101103typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

102104

103105qualifiedToString :: ModuleName -> Qualified ProperName -> String

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1

@@ -29,7 +29,7 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$

2929

3030desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

3131desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

32− desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

32+ desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)

3333desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

3434desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

3535desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker/Types.hs+56−56

@@ -151,17 +151,17 @@ typesOf moduleName vals = do

151151 typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed

152152 untypedNames <- replicateM (length untyped) fresh

153153 let untypedDict = zip (map fst untyped) untypedNames

154− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

154+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ (map (id *** fst) typedDict) ++ untypedDict)

155155 forM es $ \e -> do

156156 triple@(_, (val, ty)) <- case e of

157− (ident, (val, Just ty)) -> do

157+ (ident, (val, Just (ty, checkType))) -> do

158158 kind <- liftCheck $ kindOf moduleName ty

159159 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

160160 ty' <- replaceAllTypeSynonyms ty

161− val' <- bindNames dict $ check val ty'

161+ val' <- bindNames dict $ if checkType then check val ty' else return val

162162 return (ident, (val', ty'))

163163 (ident, (val, Nothing)) -> do

164− TypedValue val' ty <- bindNames dict $ infer val

164+ TypedValue _ val' ty <- bindNames dict $ infer val

165165 ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

166166 return (ident, (val', ty))

167167 when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do

@@ -175,8 +175,8 @@ typesOf moduleName vals = do

175175 return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'

176176 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

177177

178−isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))

179−isTyped (name, TypedValue value ty) = (name, (value, Just ty))

178+isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))

179+isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))

180180isTyped (name, value) = (name, (value, Nothing))

181181

182182overTypes :: (Type -> Type) -> Value -> Value

@@ -231,7 +231,7 @@ escapeCheck value ty = do

231231findAllTypes :: Value -> [Type]

232232findAllTypes = everything (++) (mkQ [] go)

233233 where

234− go (TypedValue _ ty) = [ty]

234+ go (TypedValue _ _ ty) = [ty]

235235 go _ = []

236236

237237skolemEscapeCheck :: Type -> Check ()

@@ -299,14 +299,14 @@ infer :: Value -> Subst Value

299299infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val

300300

301301infer' :: Value -> Subst Value

302−infer' v@(NumericLiteral _) = return $ TypedValue v Number

303−infer' v@(StringLiteral _) = return $ TypedValue v String

304−infer' v@(BooleanLiteral _) = return $ TypedValue v Boolean

302+infer' v@(NumericLiteral _) = return $ TypedValue True v Number

303+infer' v@(StringLiteral _) = return $ TypedValue True v String

304+infer' v@(BooleanLiteral _) = return $ TypedValue True v Boolean

305305infer' (ArrayLiteral vals) = do

306306 ts <- mapM infer vals

307307 els <- fresh

308− forM_ ts $ \(TypedValue _ t) -> els ~~ Array t

309− return $ TypedValue (ArrayLiteral ts) els

308+ forM_ ts $ \(TypedValue _ _ t) -> els ~~ Array t

309+ return $ TypedValue True (ArrayLiteral ts) els

310310infer' (Unary op val) = do

311311 v <- infer val

312312 inferUnary op v

@@ -317,43 +317,43 @@ infer' (Binary op left right) = do

317317infer' (ObjectLiteral ps) = do

318318 ensureNoDuplicateProperties ps

319319 ts <- mapM (infer . snd) ps

320− let fields = zipWith (\name (TypedValue _ t) -> (name, t)) (map fst ps) ts

320+ let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

321321 ty = Object $ rowFromList (fields, REmpty)

322− return $ TypedValue (ObjectLiteral (zip (map fst ps) ts)) ty

322+ return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

323323infer' (ObjectUpdate o ps) = do

324324 ensureNoDuplicateProperties ps

325325 row <- fresh

326326 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps

327− let newTys = map (\(name, TypedValue _ ty) -> (name, ty)) newVals

327+ let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals

328328 oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh

329329 o' <- check o $ Object $ rowFromList (oldTys, row)

330− return $ TypedValue (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

330+ return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

331331infer' (Indexer index val) = do

332332 el <- fresh

333333 index' <- check index Number

334334 val' <- check val (Array el)

335− return $ TypedValue (Indexer (TypedValue index' Number) (TypedValue val' (Array el))) el

335+ return $ TypedValue True (Indexer (TypedValue True index' Number) (TypedValue True val' (Array el))) el

336336infer' (Accessor prop val) = do

337− typed@(TypedValue _ objTy) <- infer val

337+ typed@(TypedValue _ _ objTy) <- infer val

338338 propTy <- inferProperty objTy prop

339339 case propTy of

340340 Nothing -> do

341341 field <- fresh

342342 rest <- fresh

343343 objTy `subsumes` Object (RCons prop field rest)

344− return $ TypedValue (Accessor prop typed) field

345− Just ty -> return $ TypedValue (Accessor prop typed) ty

344+ return $ TypedValue True (Accessor prop typed) field

345+ Just ty -> return $ TypedValue True (Accessor prop typed) ty

346346infer' (Abs args ret) = do

347347 ts <- replicateM (length args) fresh

348348 moduleName <- substCurrentModule <$> ask

349349 bindLocalVariables moduleName (zip args ts) $ do

350− body@(TypedValue _ bodyTy) <- infer' ret

351− return $ TypedValue (Abs args body) $ Function ts bodyTy

350+ body@(TypedValue _ _ bodyTy) <- infer' ret

351+ return $ TypedValue True (Abs args body) $ Function ts bodyTy

352352infer' (App f args) = do

353− f'@(TypedValue _ ft) <- infer f

353+ f'@(TypedValue _ _ ft) <- infer f

354354 ret <- fresh

355355 app <- checkFunctionApplication f' ft args ret

356− return $ TypedValue app ret

356+ return $ TypedValue True app ret

357357infer' (Var var) = do

358358 moduleName <- substCurrentModule <$> ask

359359 ty <- lookupVariable moduleName var

@@ -362,38 +362,38 @@ infer' (Var var) = do

362362 ConstrainedType constraints _ -> do

363363 env <- getEnv

364364 dicts <- getTypeClassDictionaries

365− return $ TypedValue (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

366− _ -> return $ TypedValue (Var var) ty'

365+ return $ TypedValue True (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

366+ _ -> return $ TypedValue True (Var var) ty'

367367infer' (Block ss) = do

368368 ret <- fresh

369369 (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

370370 guardWith "Block is missing a return statement" allCodePathsReturn

371− return $ TypedValue (Block ss') ret

371+ return $ TypedValue True (Block ss') ret

372372infer' v@(Constructor c) = do

373373 env <- getEnv

374374 moduleName <- substCurrentModule `fmap` ask

375375 case M.lookup (qualify moduleName c) (dataConstructors env) of

376376 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

377377 Just (ty, _) -> do ty' <- replaceAllTypeSynonyms ty

378− return $ TypedValue v ty'

378+ return $ TypedValue True v ty'

379379infer' (Case vals binders) = do

380380 ts <- mapM infer vals

381381 ret <- fresh

382− binders' <- checkBinders (map (\(TypedValue _ t) -> t) ts) ret binders

383− return $ TypedValue (Case ts binders') ret

382+ binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders

383+ return $ TypedValue True (Case ts binders') ret

384384infer' (IfThenElse cond th el) = do

385385 cond' <- check cond Boolean

386− v2@(TypedValue _ t2) <- infer th

387− v3@(TypedValue _ t3) <- infer el

386+ v2@(TypedValue _ _ t2) <- infer th

387+ v3@(TypedValue _ _ t3) <- infer el

388388 t2 ~~ t3

389− return $ TypedValue (IfThenElse cond' v2 v3) t2

390−infer' (TypedValue val ty) = do

389+ return $ TypedValue True (IfThenElse cond' v2 v3) t2

390+infer' (TypedValue checkType val ty) = do

391391 moduleName <- substCurrentModule <$> ask

392392 kind <- liftCheck $ kindOf moduleName ty

393393 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

394394 ty' <- replaceAllTypeSynonyms ty

395− val' <- check val ty'

396− return $ TypedValue val' ty

395+ val' <- if checkType then check val ty' else return val

396+ return $ TypedValue True val' ty

397397infer' _ = error "Invalid argument to infer"

398398

399399inferProperty :: Type -> String -> Subst (Maybe Type)

@@ -409,11 +409,11 @@ inferProperty (ForAll ident ty) prop = do

409409inferProperty _ _ = return Nothing

410410

411411inferUnary :: UnaryOperator -> Value -> Subst Value

412−inferUnary op (TypedValue val valTy) =

412+inferUnary op (TypedValue _ val valTy) =

413413 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

414414 (valTy', resTy) -> do

415415 valTy' ~~ valTy

416− return $ TypedValue (Unary op val) resTy

416+ return $ TypedValue True (Unary op val) resTy

417417inferUnary _ _ = error "Invalid arguments to inferUnary"

418418

419419checkUnary :: UnaryOperator -> Value -> Type -> Subst Value

@@ -431,22 +431,22 @@ unaryOps = [ (Negate, (Number, Number))

431431 ]

432432

433433inferBinary :: BinaryOperator -> Value -> Value -> Subst Value

434−inferBinary op left@(TypedValue _ leftTy) right@(TypedValue _ rightTy) | isEqualityTest op = do

434+inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do

435435 leftTy ~~ rightTy

436− return $ TypedValue (Binary op left right) Boolean

437−inferBinary op left@(TypedValue _ leftTy) right@(TypedValue _ rightTy) =

436+ return $ TypedValue True (Binary op left right) Boolean

437+inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =

438438 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

439439 (valTy, resTy) -> do

440440 leftTy ~~ valTy

441441 rightTy ~~ valTy

442− return $ TypedValue (Binary op left right) resTy

442+ return $ TypedValue True (Binary op left right) resTy

443443inferBinary _ _ _ = error "Invalid arguments to inferBinary"

444444

445445checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value

446446checkBinary op left right res | isEqualityTest op = do

447447 res ~~ Boolean

448− left'@(TypedValue _ t1) <- infer left

449− right'@(TypedValue _ t2) <- infer right

448+ left'@(TypedValue _ _ t1) <- infer left

449+ right'@(TypedValue _ _ t2) <- infer right

450450 t1 ~~ t2

451451 return $ Binary op left' right'

452452checkBinary op left right res =

@@ -564,10 +564,10 @@ assignVariable name = do

564564checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)

565565checkStatement mass _ (VariableIntroduction name val) = do

566566 assignVariable name

567− val'@(TypedValue _ t) <- infer val

567+ val'@(TypedValue _ _ t) <- infer val

568568 return (False, M.insert name t mass, VariableIntroduction name val')

569569checkStatement mass _ (Assignment ident val) = do

570− val'@(TypedValue _ t) <- infer val

570+ val'@(TypedValue _ _ t) <- infer val

571571 case M.lookup ident mass of

572572 Nothing -> throwError $ "No local variable with name " ++ show ident

573573 Just ty -> do t ~~ ty

@@ -648,7 +648,7 @@ check' val (ConstrainedType constraints ty) = do

648648 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty

649649 return $ Abs dictNames val'

650650check' val u@(TUnknown _) = do

651− val'@(TypedValue _ ty) <- infer val

651+ val'@(TypedValue _ _ ty) <- infer val

652652 -- Don't unify an unknown with an inferred polytype

653653 ty' <- replaceAllVarsWithUnknowns ty

654654 ty' ~~ u

@@ -669,7 +669,7 @@ check' (Abs args ret) (Function argTys retTy) = do

669669 ret' <- bindLocalVariables moduleName (zip args argTys) $ check ret retTy

670670 return $ Abs args ret'

671671check' (App f args) ret = do

672− f'@(TypedValue _ ft) <- infer f

672+ f'@(TypedValue _ _ ft) <- infer f

673673 app <- checkFunctionApplication f' ft args ret

674674 return $ app

675675check' (Var var) ty = do

@@ -678,16 +678,16 @@ check' (Var var) ty = do

678678 repl <- replaceAllTypeSynonyms ty1

679679 repl `subsumes` ty

680680 return $ Var var

681−check' (TypedValue val ty1) ty2 = do

681+check' (TypedValue checkType val ty1) ty2 = do

682682 moduleName <- substCurrentModule <$> ask

683683 kind <- liftCheck $ kindOf moduleName ty1

684684 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

685685 ty1 `subsumes` ty2

686− val' <- check val ty1

687− return $ TypedValue val' ty1

686+ val' <- if checkType then check val ty1 else return val

687+ return $ TypedValue True val' ty1

688688check' (Case vals binders) ret = do

689689 vals' <- mapM infer vals

690− let ts = map (\(TypedValue _ t) -> t) vals'

690+ let ts = map (\(TypedValue _ _ t) -> t) vals'

691691 binders' <- checkBinders ts ret binders

692692 return $ Case vals' binders'

693693check' (IfThenElse cond th el) ty = do

@@ -740,7 +740,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

740740 | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p

741741 go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row

742742 go ((p,v):ps') [] u@(TUnknown _) = do

743− v'@(TypedValue _ ty) <- infer v

743+ v'@(TypedValue _ _ ty) <- infer v

744744 rest <- fresh

745745 u ~~ RCons p ty rest

746746 ps'' <- go ps' [] rest

@@ -748,7 +748,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

748748 go ((p,v):ps') ts r =

749749 case lookup p ts of

750750 Nothing -> do

751− v'@(TypedValue _ ty) <- infer v

751+ v'@(TypedValue _ _ ty) <- infer v

752752 rest <- fresh

753753 r ~~ RCons p ty rest

754754 ps'' <- go ps' ts rest

@@ -777,8 +777,8 @@ checkFunctionApplication' fn (ForAll ident ty) args ret = do

777777 replaced <- replaceVarWithUnknown ident ty

778778 checkFunctionApplication fn replaced args ret

779779checkFunctionApplication' fn u@(TUnknown _) args ret = do

780− args' <- mapM (\arg -> infer arg >>= \(TypedValue v t) -> TypedValue v <$> replaceAllVarsWithUnknowns t) args

781− let tys = map (\(TypedValue _ t) -> t) args'

780+ args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args

781+ let tys = map (\(TypedValue _ _ t) -> t) args'

782782 u ~~ Function tys ret

783783 return $ App fn args'

784784checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

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

@@ -71,7 +71,7 @@ data Value

7171 | Block [Statement]

7272 | Constructor (Qualified ProperName)

7373 | Case [Value] [([Binder], Maybe Guard, Value)]

74− | TypedValue Value Type

74+ | TypedValue Bool Value Type

7575 | Do Value [DoNotationElement]

7676 | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

7777