363b03c · rowtype-yoga/purescript-native

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

isFunction, begone! #485

commit363b03cfccf7612a005241cef3ce5f9c7c8afe15 authorPhil Freeman <paf31@cantab.net> dateWed 16 Jul 2014, 16:29 (12 years ago) parent8b357ff

6 files changed+73−37

compare with golang

unifiedsplit

psci/Main.hs+1−1 src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Environment.hs+14−1 src/Language/PureScript/TypeChecker.hs+2−2 src/Language/PureScript/TypeChecker/Monad.hs+35−4 src/Language/PureScript/TypeChecker/Types.hs+20−28

psci/Main.hs+1−1

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

293293 Left err -> PSCI $ outputStrLn err

294294 Right env' ->

295295 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

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

298298

299299-- Commands

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

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

7171 exportToPs (ValueRef ident) =

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

7373 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 ->

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

7676 _ -> return ()

7777 exportToPs (TypeClassRef className) =

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

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

3333 -- |

3434 -- Value names currently in scope

3535 --

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

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

3737 -- |

3838 -- Type names currently in scope

3939 --

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

7575 --

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

7777

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+

7891-- |

7992-- The kind of a name

8093--

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

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

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

7272addValue moduleName name ty nameKind = do

7373 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) })

7575

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

7777addTypeClass moduleName pn args implies ds =

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

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

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

176176 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) })

178178 ds <- typeCheckAll mainModuleName moduleName rest

179179 return $ d : ds

180180typeCheckAll 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

3939-- |

4040-- Temporarily bind a collection of names to values

4141--

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

4343bindNames newNames action = do

4444 orig <- get

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

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

7979-- |

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

8181--

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

8383bindLocalVariables 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)))

8585

8686-- |

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

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

9090bindLocalTypeVariables moduleName bindings =

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

9292

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+

93104-- |

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

95106--

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

98109 env <- getEnv

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

100111 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 ()

102133

103134-- |

104135-- 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

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

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

196196

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

198198typeDictionaryForBindingGroup moduleName vals = do

199199 let

200200 -- 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

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

213213 untypedDict = zip (map fst untyped) untypedNames

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

216216 return (es, dict, untypedDict)

217217

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

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

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 el dict untypedDict =

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

221221 -- 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

224223 -- Typed declarations

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

226225 -- Kind check

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

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

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

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

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

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

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

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

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

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

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

235234 -- Untyped declarations

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

237236 -- 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'

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

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

241240

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−

251241-- |

252242-- Check if a value contains a type annotation

253243--

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

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

631621 ty <- fresh

632622 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

640630 return $ TypedValue True app ret

641631infer' (Var var) = do

642632 Just moduleName <- checkCurrentModule <$> get

633+ checkVisibility moduleName var

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

644635 case ty of

645636 ConstrainedType constraints ty' -> do

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

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

681672

682673inferLetBinding :: [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)

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

685676 Just moduleName <- checkCurrentModule <$> get

686677 kind <- liftCheck $ kindOf moduleName ty

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

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

690681 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

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

693684 valTy <- fresh

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

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

697688 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

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

700691 Just moduleName <- checkCurrentModule <$> get

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

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

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

787778 Just moduleName <- checkCurrentModule <$> get

788779 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

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

791782 case grd of

792783 Nothing -> return $ CaseAlternative binders Nothing val'

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

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

862853 n <- liftCheck freshDictionaryName

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

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

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

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

866857 constraints) $ check val ty

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

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

886877 return $ TypedValue True array t

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

888879 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

892883check' (App f arg) ret = do

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

895886 return $ TypedValue True app ret

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

897888 Just moduleName <- checkCurrentModule <$> get

889+ checkVisibility moduleName var

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

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

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