git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #1012
commitfd49d972084d4971f72d308b951a602c52bb1630 authorPhil Freeman <paf31@cantab.net> dateMon 30 Mar 2015, 11:03 (12 years ago) parent879a030
3 files changed+34−10
compare with golang
unifiedsplit
examples/passing/Let2.purs+15 src/Language/PureScript/TypeChecker/Monad.hs+12−5 src/Language/PureScript/TypeChecker/Types.hs+7−5
examples/passing/Let2.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+test =
4+ let f :: Number -> Boolean
5+ f 0 = false
6+ f n = g (n - 1)
7+
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 =
9696-- |
9797-- Update the visibility of all names to Defined
9898--
99−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
100−makeBindingGroupVisible action = do
101− orig <- get
102− modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
99+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
100+makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
101+
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)
103110 a <- action
104− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
111+ modifyEnv $ \e -> e { names = orig }
105112 return a
106113
107114-- |
src/Language/PureScript/TypeChecker/Types.hs+7−5
@@ -247,7 +247,7 @@ infer' (Accessor prop val) = do
247247infer' (Abs (Left arg) ret) = do
248248 ty <- fresh
249249 Just moduleName <- checkCurrentModule <$> get
250− makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
250+ withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
251251 body@(TypedValue _ _ bodyTy) <- infer' ret
252252 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
253253infer' (Abs (Right _) _) = error "Binder was not desugared"
@@ -298,7 +298,7 @@ infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val
298298infer' _ = error "Invalid argument to infer"
299299
300300inferLetBinding :: [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)
302302inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
303303 Just moduleName <- checkCurrentModule <$> get
304304 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
@@ -320,7 +320,9 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
320320 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
321321 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
322322 let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
323− makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
323+ bindNames dict $ do
324+ makeBindingGroupVisible
325+ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
324326inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do
325327 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
326328 return (PositionedDeclaration pos com d' : ds', val')
@@ -442,7 +444,7 @@ check' val t@(ConstrainedType constraints ty) = do
442444 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
443445 n <- liftCheck freshDictionaryName
444446 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
445− val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
447+ val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
446448 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
447449 constraints) $ check val ty
448450 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
@@ -468,7 +470,7 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) = do
468470check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
469471 t =?= tyFunction
470472 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
472474 return $ TypedValue True (Abs (Left arg) ret') ty
473475check' (Abs (Right _) _) _ = error "Binder was not desugared"
474476check' (App f arg) ret = do