fd49d97 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #1012

fd49d97Phil Freeman12 years ago

examples/passing/Let2.pursnew file+15

compare with golang

unifiedsplit

@@ -0,0 +1,15 @@

1+module Main where

3+test =

4+ let f :: Number -> Boolean

5+ f 0 = false

6+ f n = g (n - 1)

8+ g :: Number -> Boolean

9+ g 0 = true

10+ g n = f (n - 1)

11+

12+ x = f 1

13+ in not x

14+

15+main = Debug.Trace.print test

src/Language/PureScript/TypeChecker/Monad.hs+12−5

@@ -96,12 +96,19 @@ bindLocalTypeVariables moduleName bindings =

96-- |

97-- Update the visibility of all names to Defined

98--

99−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a

99+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()

100−makeBindingGroupVisible action = do

100+makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }

101− orig <- get

101+

102− modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }

102+-- | Update the visibility of all names to Defined in the scope of the provided action

103+withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a

104+withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action

105+

106+-- | Perform an action while preserving the names from the @Environment@.

107+preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a

108+preservingNames action = do

109+ orig <- gets (names . checkEnv)

103 a <- action

110 a <- action

104− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

111+ modifyEnv $ \e -> e { names = orig }

105 return a

112 return a

106

113

107-- |

114-- |

src/Language/PureScript/TypeChecker/Types.hs+7−5

@@ -247,7 +247,7 @@ infer' (Accessor prop val) = do

247infer' (Abs (Left arg) ret) = do

248 ty <- fresh

249 Just moduleName <- checkCurrentModule <$> get

250− makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

250+ withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

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

252 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

253infer' (Abs (Right _) _) = error "Binder was not desugared"

@@ -298,7 +298,7 @@ infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

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

299

300inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

301−inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

301+inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

302inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do

303 Just moduleName <- checkCurrentModule <$> get

304 (kind, args) <- liftCheck $ kindOfWithScopedVars ty

@@ -320,7 +320,9 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

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

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

322 let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']

323+ bindNames dict $ do

324+ makeBindingGroupVisible

323− makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

325+ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

324inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do

326inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do

325 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

327 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

326 return (PositionedDeclaration pos com d' : ds', val')

328 return (PositionedDeclaration pos com d' : ds', val')

@@ -442,7 +444,7 @@ check' val t@(ConstrainedType constraints ty) = do

442 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

444 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

443 n <- liftCheck freshDictionaryName

445 n <- liftCheck freshDictionaryName

444 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

446 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

445− val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

447+ val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

446 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)

448 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)

447 constraints) $ check val ty

449 constraints) $ check val ty

448 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

450 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

@@ -468,7 +470,7 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) = do

468check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

470check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

469 t =?= tyFunction

471 t =?= tyFunction

470 Just moduleName <- checkCurrentModule <$> get

472 Just moduleName <- checkCurrentModule <$> get

471− ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

473+ ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

472 return $ TypedValue True (Abs (Left arg) ret') ty

474 return $ TypedValue True (Abs (Left arg) ret') ty

473check' (Abs (Right _) _) _ = error "Binder was not desugared"

475check' (Abs (Right _) _) _ = error "Binder was not desugared"

474check' (App f arg) ret = do

476check' (App f arg) ret = do