cc947bd · rowtype-yoga/purescript-native

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

on golang help sign in

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

cc947bdPhil Freeman13 years ago

examples/passing/TypeClasses.purs−7

compare with golang

unifiedsplit

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

1module TypeClasses where

3−import Eff

4−import Trace

5−

6class Show a where

3class Show a where

7 show :: a -> String

4 show :: a -> String

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

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

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

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)

35compile opts ms = do

36 desugared <- desugar ms

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

38+ let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

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

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

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

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

40 js' <- case () of

41 js' <- case () of

41 _ | optionsRunMain opts -> do

42 _ | optionsRunMain opts -> do

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

43 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

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

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

104valueToJs 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)])

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

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

108valueToJs _ 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

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

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

112

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

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

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

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

161 , \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

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

164 ]

165 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

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

87typed = mkPattern match

88 where

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

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

90 match _ = Nothing

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

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

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

15module Language.PureScript.Sugar.BindingGroups (

16 createBindingGroups,

17− createBindingGroupsModule

17+ createBindingGroupsModule,

18+ collapseBindingGroups,

19+ collapseBindingGroupsModule

18) where

20) where

20import Data.Data

22import Data.Data

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

30createBindingGroupsModule :: [Module] -> [Module]

32createBindingGroupsModule :: [Module] -> [Module]

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

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

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

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

37+

33createBindingGroups :: [Declaration] -> [Declaration]

38createBindingGroups :: [Declaration] -> [Declaration]

34createBindingGroups ds =

39createBindingGroups ds =

35 let

40 let

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

45 in

50 in

46 dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

51 dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

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+

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

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

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

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

50 where

62 where

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

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

75typeInstanceDictionaryDeclaration mn deps name ty decls = do

76 entryName <- lift $ mkDictionaryValueName mn name ty

77 memberNames <- mapM memberToNameAndValue decls

78− return $ ExternDeclaration TypeClassDictionaryImport entryName

78+ return $ ValueDeclaration entryName [] Nothing

79− (Just (JSFunction (Just entryName)

79+ (TypedValue False

80+ (Abs

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

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

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

82+ (ObjectLiteral memberNames))

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

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

84+ )

83 where

85 where

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

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

85 memberToNameAndValue (ValueDeclaration ident _ _ _) = do

87 memberToNameAndValue (ValueDeclaration ident _ _ _) = do

86 memberName <- mkDictionaryEntryName mn name ty ident

88 memberName <- mkDictionaryEntryName mn name ty ident

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

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

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

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

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

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

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

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

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

97 return $ replaceTypeVars arg ty ty'

99 return $ replaceTypeVars arg ty ty'

98 entryName <- mkDictionaryEntryName mn name ty ident

100 entryName <- mkDictionaryEntryName mn name ty ident

99 return $ ValueDeclaration entryName [] Nothing

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

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

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

102

104

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

105qualifiedToString :: 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 <$

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

31desugarTypeDeclarations (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)

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

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

35desugarTypeDeclarations [] = return []

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

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

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

152 untypedNames <- replicateM (length untyped) fresh

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

155 forM es $ \e -> do

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

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

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

158 kind <- liftCheck $ kindOf moduleName ty

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

160 ty' <- replaceAllTypeSynonyms ty

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

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

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

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

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

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

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

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

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

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

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

176 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

177

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

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

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

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

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

181

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

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

231findAllTypes :: Value -> [Type]

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

233 where

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

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

235 go _ = []

236

237skolemEscapeCheck :: Type -> Check ()

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

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

300

301infer' :: Value -> Subst Value

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

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

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

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

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

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

305infer' (ArrayLiteral vals) = do

306 ts <- mapM infer vals

307 els <- fresh

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

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

309− return $ TypedValue (ArrayLiteral ts) els

309+ return $ TypedValue True (ArrayLiteral ts) els

310infer' (Unary op val) = do

311 v <- infer val

312 inferUnary op v

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

317infer' (ObjectLiteral ps) = do

318 ensureNoDuplicateProperties ps

319 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

321 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

323infer' (ObjectUpdate o ps) = do

324 ensureNoDuplicateProperties ps

325 row <- fresh

326 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

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

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

331infer' (Indexer index val) = do

332 el <- fresh

333 index' <- check index Number

334 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

336infer' (Accessor prop val) = do

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

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

338 propTy <- inferProperty objTy prop

339 case propTy of

340 Nothing -> do

341 field <- fresh

342 rest <- fresh

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

344− return $ TypedValue (Accessor prop typed) field

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

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

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

346infer' (Abs args ret) = do

347 ts <- replicateM (length args) fresh

348 moduleName <- substCurrentModule <$> ask

349 bindLocalVariables moduleName (zip args ts) $ do

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

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

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

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

352infer' (App f args) = do

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

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

354 ret <- fresh

355 app <- checkFunctionApplication f' ft args ret

356− return $ TypedValue app ret

356+ return $ TypedValue True app ret

357infer' (Var var) = do

358 moduleName <- substCurrentModule <$> ask

359 ty <- lookupVariable moduleName var

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

362 ConstrainedType constraints _ -> do

363 env <- getEnv

364 dicts <- getTypeClassDictionaries

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

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

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

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

367infer' (Block ss) = do

368 ret <- fresh

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

370 guardWith "Block is missing a return statement" allCodePathsReturn

371− return $ TypedValue (Block ss') ret

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

372infer' v@(Constructor c) = do

373 env <- getEnv

374 moduleName <- substCurrentModule `fmap` ask

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

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

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

378− return $ TypedValue v ty'

378+ return $ TypedValue True v ty'

379infer' (Case vals binders) = do

380 ts <- mapM infer vals

381 ret <- fresh

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

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

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

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

384infer' (IfThenElse cond th el) = do

385 cond' <- check cond Boolean

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

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

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

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

388 t2 ~~ t3

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

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

390−infer' (TypedValue val ty) = do

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

391 moduleName <- substCurrentModule <$> ask

392 kind <- liftCheck $ kindOf moduleName ty

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

394 ty' <- replaceAllTypeSynonyms ty

395− val' <- check val ty'

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

396− return $ TypedValue val' ty

396+ return $ TypedValue True val' ty

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

398

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

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

409inferProperty _ _ = return Nothing

410

411inferUnary :: UnaryOperator -> Value -> Subst Value

412−inferUnary op (TypedValue val valTy) =

412+inferUnary op (TypedValue _ val valTy) =

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

414 (valTy', resTy) -> do

415 valTy' ~~ valTy

416− return $ TypedValue (Unary op val) resTy

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

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

418

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

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

431 ]

432

433inferBinary :: 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

435 leftTy ~~ rightTy

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

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

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

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

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

439 (valTy, resTy) -> do

440 leftTy ~~ valTy

441 rightTy ~~ valTy

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

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

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

444

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

446checkBinary op left right res | isEqualityTest op = do

447 res ~~ Boolean

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

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

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

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

450 t1 ~~ t2

451 return $ Binary op left' right'

452checkBinary op left right res =

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

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

565checkStatement mass _ (VariableIntroduction name val) = do

566 assignVariable name

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

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

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

569checkStatement mass _ (Assignment ident val) = do

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

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

571 case M.lookup ident mass of

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

573 Just ty -> do t ~~ ty

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

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

649 return $ Abs dictNames val'

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

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

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

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

653 ty' <- replaceAllVarsWithUnknowns ty

654 ty' ~~ u

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

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

670 return $ Abs args ret'

671check' (App f args) ret = do

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

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

673 app <- checkFunctionApplication f' ft args ret

674 return $ app

675check' (Var var) ty = do

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

678 repl <- replaceAllTypeSynonyms ty1

679 repl `subsumes` ty

680 return $ Var var

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

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

682 moduleName <- substCurrentModule <$> ask

683 kind <- liftCheck $ kindOf moduleName ty1

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

685 ty1 `subsumes` ty2

686− val' <- check val ty1

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

687− return $ TypedValue val' ty1

687+ return $ TypedValue True val' ty1

688check' (Case vals binders) ret = do

689 vals' <- mapM infer vals

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

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

691 binders' <- checkBinders ts ret binders

692 return $ Case vals' binders'

693check' (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

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

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

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

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

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

744 rest <- fresh

745 u ~~ RCons p ty rest

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

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

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

749 case lookup p ts of

750 Nothing -> do

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

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

752 rest <- fresh

753 r ~~ RCons p ty rest

754 ps'' <- go ps' ts rest

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

777 replaced <- replaceVarWithUnknown ident ty

778 checkFunctionApplication fn replaced args ret

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

780− args' <- mapM (\arg -> infer arg >>= \(TypedValue v t) -> TypedValue v <$> replaceAllVarsWithUnknowns 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'

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

782 u ~~ Function tys ret

783 return $ App fn args'

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

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

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

71 | Block [Statement]

72 | Constructor (Qualified ProperName)

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

74− | TypedValue Value Type

74+ | TypedValue Bool Value Type

75 | Do Value [DoNotationElement]

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