363b03c · rowtype-yoga/purescript-native

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

on golang help sign in

isFunction, begone! #485

363b03cPhil Freeman12 years ago

psci/Main.hs+1−1

compare with golang

unifiedsplit

@@ -293,7 +293,7 @@ handleTypeOf value = do

293 Left err -> PSCI $ outputStrLn err

294 Right env' ->

295 case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of

296− Just (ty, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

296+ Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

297 Nothing -> PSCI $ outputStrLn "Could not find type"

298

299-- Commands

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -71,7 +71,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

71 exportToPs (ValueRef ident) =

72 case (moduleName, ident) `M.lookup` names env of

73 Nothing -> error $ show ident ++ " has no type in exportToPs"

74− Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->

74+ Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->

75 tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]

76 _ -> return ()

77 exportToPs (TypeClassRef className) =

src/Language/PureScript/Environment.hs+14−1

@@ -33,7 +33,7 @@ data Environment = Environment {

33 -- |

34 -- Value names currently in scope

35 --

36− names :: M.Map (ModuleName, Ident) (Type, NameKind)

36+ names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

37 -- |

38 -- Type names currently in scope

39 --

@@ -75,6 +75,19 @@ data ForeignImportType

75 --

76 | InlineJavascript deriving (Show, Eq, Data, Typeable)

78+-- |

79+-- The visibility of a name in scope

80+--

81+data NameVisibility

82+ -- |

83+ -- The name is defined in the current binding group, but is not visible

84+ --

85+ = Undefined

86+ -- |

87+ -- The name is defined in the another binding group, or has been made visible by a function binder

88+ --

89+ | Defined deriving (Show, Eq)

90+

78-- |

91-- |

79-- The kind of a name

92-- The kind of a name

80--

93--

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

@@ -71,7 +71,7 @@ valueIsNotDefined moduleName name = do

71addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()

72addValue moduleName name ty nameKind = do

73 env <- getEnv

74− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })

74+ putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

76addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

77addTypeClass moduleName pn args implies ds =

@@ -174,7 +174,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)

174 guardWith (strMsg "Expected kind *") $ kind == Star

175 case M.lookup (moduleName, name) (names env) of

176 Just _ -> throwError . strMsg $ show name ++ " is already defined"

177− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })

177+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })

178 ds <- typeCheckAll mainModuleName moduleName rest

179 return $ d : ds

180typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

src/Language/PureScript/TypeChecker/Monad.hs+35−4

@@ -39,7 +39,7 @@ import qualified Data.Map as M

39-- |

40-- Temporarily bind a collection of names to values

41--

42−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

42+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a

43bindNames newNames action = do

44 orig <- get

45 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -79,9 +79,9 @@ getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get

79-- |

80-- Temporarily bind a collection of names to local variables

81--

82−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

82+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

83bindLocalVariables moduleName bindings =

84− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))

84+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))

86-- |

87-- Temporarily bind a collection of names to local type variables

@@ -90,6 +90,17 @@ bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName ->

90bindLocalTypeVariables moduleName bindings =

91 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

93+-- |

94+-- Update the visibility of all names to Defined

95+--

96+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a

97+makeBindingGroupVisible action = do

98+ orig <- get

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

100+ a <- action

101+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

102+ return a

103+

93-- |

104-- |

94-- Lookup the type of a value by name in the @Environment@

105-- Lookup the type of a value by name in the @Environment@

95--

106--

@@ -98,7 +109,27 @@ lookupVariable currentModule (Qualified moduleName var) = do

98 env <- getEnv

109 env <- getEnv

99 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

110 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

100 Nothing -> throwError . strMsg $ show var ++ " is undefined"

111 Nothing -> throwError . strMsg $ show var ++ " is undefined"

101− Just (ty, _) -> return ty

112+ Just (ty, _, _) -> return ty

113+

114+-- |

115+-- Lookup the visibility of a value by name in the @Environment@

116+--

117+getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

118+getVisibility currentModule (Qualified moduleName var) = do

119+ env <- getEnv

120+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

121+ Nothing -> throwError . strMsg $ show var ++ " is undefined"

122+ Just (_, _, vis) -> return vis

123+

124+-- |

125+-- Assert that a name is visible

126+--

127+checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

128+checkVisibility currentModule name@(Qualified _ var) = do

129+ vis <- getVisibility currentModule name

130+ case vis of

131+ Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."

132+ _ -> return ()

102

133

103-- |

134-- |

104-- Lookup the kind of a type by name in the @Environment@

135-- Lookup the kind of a type by name in the @Environment@

src/Language/PureScript/TypeChecker/Types.hs+20−28

@@ -194,7 +194,7 @@ typesOf mainModuleName moduleName vals = do

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

195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

196

197−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])

197+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])

198typeDictionaryForBindingGroup moduleName vals = do

199 let

200 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

@@ -212,15 +212,14 @@ typeDictionaryForBindingGroup moduleName vals = do

212 -- Make a map of names to the unification variables of untyped declarations

213 untypedDict = zip (map fst untyped) untypedNames

214 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

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

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

216 return (es, dict, untypedDict)

217

218−typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))

218+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))

219−typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do

219+typeForBindingGroupElement moduleName el dict untypedDict =

220 -- If the declaration is a function, it has access to other values in the binding group.

221 -- If not, the generated code might fail at runtime since those values might be undefined.

222− let dict' = if isFunction val then dict else M.empty

223− case e of

222+ case el of

224 -- Typed declarations

223 -- Typed declarations

225 (ident, (val', Just (ty, checkType))) -> do

224 (ident, (val', Just (ty, checkType))) -> do

226 -- Kind check

225 -- Kind check

@@ -228,26 +227,17 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do

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

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

229 -- Check the type with the new names in scope

228 -- Check the type with the new names in scope

230 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

229 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

231− val'' <- bindNames dict' $ if checkType

230+ val'' <- bindNames dict $ if checkType

232− then TypedValue True <$> check val' ty' <*> pure ty'

231+ then TypedValue True <$> check val' ty' <*> pure ty'

233− else return (TypedValue False val' ty')

232+ else return (TypedValue False val' ty')

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

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

235 -- Untyped declarations

234 -- Untyped declarations

236 (ident, (val', Nothing)) -> do

235 (ident, (val', Nothing)) -> do

237 -- Infer the type with the new names in scope

236 -- Infer the type with the new names in scope

238− TypedValue _ val'' ty <- bindNames dict' $ infer val'

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

239 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

238 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

240 return (ident, (TypedValue True val'' ty, ty))

239 return (ident, (TypedValue True val'' ty, ty))

241

240

242−-- |

243−-- Check if a value introduces a function

244−--

245−isFunction :: Value -> Bool

246−isFunction (Abs _ _) = True

247−isFunction (TypedValue _ val _) = isFunction val

248−isFunction (PositionedValue _ val) = isFunction val

249−isFunction _ = False

250−

251-- |

241-- |

252-- Check if a value contains a type annotation

242-- Check if a value contains a type annotation

253--

243--

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

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

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

631 ty <- fresh

621 ty <- fresh

632 Just moduleName <- checkCurrentModule <$> get

622 Just moduleName <- checkCurrentModule <$> get

633− bindLocalVariables moduleName [(arg, ty)] $ do

623+ makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

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

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

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

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

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

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

@@ -640,6 +630,7 @@ infer' (App f arg) = do

640 return $ TypedValue True app ret

630 return $ TypedValue True app ret

641infer' (Var var) = do

631infer' (Var var) = do

642 Just moduleName <- checkCurrentModule <$> get

632 Just moduleName <- checkCurrentModule <$> get

633+ checkVisibility moduleName var

643 ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

634 ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

644 case ty of

635 case ty of

645 ConstrainedType constraints ty' -> do

636 ConstrainedType constraints ty' -> do

@@ -680,22 +671,22 @@ infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

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

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

681

672

682inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

673inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

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

674+inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

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

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

685 Just moduleName <- checkCurrentModule <$> get

676 Just moduleName <- checkCurrentModule <$> get

686 kind <- liftCheck $ kindOf moduleName ty

677 kind <- liftCheck $ kindOf moduleName ty

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

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

688− let dict = if isFunction val then M.singleton (moduleName, ident) (ty, nameKind) else M.empty

679+ let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

689 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

680 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

690 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

681 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

691− bindNames (M.singleton (moduleName, ident) (ty'', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j

682+ bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Undefined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j

692inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do

683inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do

693 valTy <- fresh

684 valTy <- fresh

694 Just moduleName <- checkCurrentModule <$> get

685 Just moduleName <- checkCurrentModule <$> get

695− let dict = if isFunction val then M.singleton (moduleName, ident) (valTy, nameKind) else M.empty

686+ let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)

696 TypedValue _ val' valTy' <- bindNames dict $ infer val

687 TypedValue _ val' valTy' <- bindNames dict $ infer val

697 valTy =?= valTy'

688 valTy =?= valTy'

698− bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

689+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Undefined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

699inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

690inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

700 Just moduleName <- checkCurrentModule <$> get

691 Just moduleName <- checkCurrentModule <$> get

701 (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

692 (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

@@ -786,7 +777,7 @@ checkBinders _ _ [] = return []

786checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

777checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

787 Just moduleName <- checkCurrentModule <$> get

778 Just moduleName <- checkCurrentModule <$> get

788 m1 <- M.unions <$> zipWithM inferBinder nvals binders

779 m1 <- M.unions <$> zipWithM inferBinder nvals binders

789− r <- bindLocalVariables moduleName (M.toList m1) $ do

780+ r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do

790 val' <- TypedValue True <$> check val ret <*> pure ret

781 val' <- TypedValue True <$> check val ret <*> pure ret

791 case grd of

782 case grd of

792 Nothing -> return $ CaseAlternative binders Nothing val'

783 Nothing -> return $ CaseAlternative binders Nothing val'

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

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

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

862 n <- liftCheck freshDictionaryName

853 n <- liftCheck freshDictionaryName

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

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

864− val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

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

865 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

856 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

866 constraints) $ check val ty

857 constraints) $ check val ty

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

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

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

886 return $ TypedValue True array t

877 return $ TypedValue True array t

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

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

888 Just moduleName <- checkCurrentModule <$> get

879 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

892check' (App f arg) ret = do

883check' (App f arg) ret = do

@@ -895,6 +886,7 @@ check' (App f arg) ret = do

895 return $ TypedValue True app ret

886 return $ TypedValue True app ret

896check' v@(Var var) ty = do

887check' v@(Var var) ty = do

897 Just moduleName <- checkCurrentModule <$> get

888 Just moduleName <- checkCurrentModule <$> get

889+ checkVisibility moduleName var

898 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

890 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

899 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

891 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

900 v' <- subsumes (Just v) repl ty'

892 v' <- subsumes (Just v) repl ty'