83367bd · rowtype-yoga/purescript-native

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

on golang help sign in

Check Eff type of main when using --entry-point

83367bdGary Burgess13 years ago

src/Language/PureScript.hs+3−2

compare with golang

unifiedsplit

@@ -61,7 +61,7 @@ compile opts ms = do

61 desugared <- desugar sorted

62 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do

63 modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

64− Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

64+ Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66 let entryPoint = optionsEntryPoint opts <|> if (optionsRunMain opts) then Just "Main" else Nothing

67 let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint

@@ -69,10 +69,11 @@ compile opts ms = do

69 let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

70 js' <- case () of

71 _ | optionsRunMain opts -> do

72− when ((ModuleName (ProperName mainModuleName), Ident "main") `M.notMember` (names env)) $

72+ when ((mainModuleIdent, Ident "main") `M.notMember` (names env)) $

73 Left $ mainModuleName ++ ".main is undefined"

74 return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]

75 | otherwise -> return js

76 return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)

77 where

78 mainModuleName = fromMaybe "Main" (optionsEntryPoint opts)

79+ mainModuleIdent = ModuleName (ProperName mainModuleName)

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

@@ -111,16 +111,16 @@ checkTypeClassInstance _ _ = throwError "Type class instance must be of the form

111--

112-- * Process module imports

113--

114−typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]

114+typeCheckAll :: ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

115−typeCheckAll _ [] = return []

115+typeCheckAll _ _ [] = return []

116−typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do

116+typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

117 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

118 typeIsNotDefined moduleName name

119 ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

120 addDataType moduleName name args dctors ctorKind

121− ds <- typeCheckAll moduleName rest

121+ ds <- typeCheckAll mainModuleName moduleName rest

122 return $ d : ds

123−typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

123+typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

124 rethrow ("Error in data binding group:\n" ++) $ do

125 let syns = mapMaybe toTypeSynonym tys

126 let dataDecls = mapMaybe toDataDecl tys

@@ -131,48 +131,48 @@ typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

131 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

132 typeIsNotDefined moduleName name

133 addTypeSynonym moduleName name args ty kind

134− ds <- typeCheckAll moduleName rest

134+ ds <- typeCheckAll mainModuleName moduleName rest

135 return $ d : ds

136 where

137 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

138 toTypeSynonym _ = Nothing

139 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

140 toDataDecl _ = Nothing

141−typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

141+typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

142 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

143 typeIsNotDefined moduleName name

144 kind <- kindsOf moduleName name args [ty]

145 addTypeSynonym moduleName name args ty kind

146− ds <- typeCheckAll moduleName rest

146+ ds <- typeCheckAll mainModuleName moduleName rest

147 return $ d : ds

148−typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

148+typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

149−typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

149+typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : rest) = do

150 d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

151 valueIsNotDefined moduleName name

152− [(_, (val', ty))] <- typesOf moduleName [(name, val)]

152+ [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

153 addValue moduleName name ty

154 return $ ValueDeclaration name [] Nothing val'

155− ds <- typeCheckAll moduleName rest

155+ ds <- typeCheckAll mainModuleName moduleName rest

156 return $ d : ds

157−typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

157+typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

158−typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

158+typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do

159 d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

160 forM_ (map fst vals) $ \name ->

161 valueIsNotDefined moduleName name

162− tys <- typesOf moduleName vals

162+ tys <- typesOf mainModuleName moduleName vals

163 vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do

164 addValue moduleName name ty

165 return (name, val)

166 return $ BindingGroupDeclaration vals'

167− ds <- typeCheckAll moduleName rest

167+ ds <- typeCheckAll mainModuleName moduleName rest

168 return $ d : ds

169−typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do

169+typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

170 env <- getEnv

171 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

172 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

173− ds <- typeCheckAll moduleName rest

173+ ds <- typeCheckAll mainModuleName moduleName rest

174 return $ d : ds

175−typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

175+typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

176 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

177 env <- getEnv

178 kind <- kindOf moduleName ty

@@ -180,14 +180,14 @@ typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

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

181 Just _ -> throwError $ show name ++ " is already defined"

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

183− ds <- typeCheckAll moduleName rest

183+ ds <- typeCheckAll mainModuleName moduleName rest

184 return $ d : ds

185−typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do

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

186− ds <- typeCheckAll moduleName rest

186+ ds <- typeCheckAll mainModuleName moduleName rest

187 env <- getEnv

188 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

189 return $ d : ds

190−typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

190+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

191 env <- getEnv

192 rethrow errorMessage $ do

193 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

@@ -199,7 +199,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

199 shadowIdents (lefts idents') env

200 shadowTypes (rights idents') env

201 shadowTypeClassInstances env

202− ds <- typeCheckAll currentModule rest

202+ ds <- typeCheckAll mainModuleName currentModule rest

203 return $ d : ds

204 where

205 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

@@ -243,16 +243,16 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

243 constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

244 constructs (TypeApp ty _) pn = ty `constructs` pn

245 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

246−typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

246+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

247 env <- getEnv

248− ds <- typeCheckAll moduleName rest

248+ ds <- typeCheckAll mainModuleName moduleName rest

249 return $ qualifyAllUnqualifiedNames moduleName env d : ds

250−typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

250+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

251 env <- getEnv

252 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

253 checkTypeClassInstance moduleName ty

254 forM_ deps $ checkTypeClassInstance moduleName . snd

255 addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

256 [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])

257− ds <- typeCheckAll moduleName rest

257+ ds <- typeCheckAll mainModuleName moduleName rest

258 return $ qualifyAllUnqualifiedNames moduleName env d : ds

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

@@ -163,8 +163,8 @@ typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName

163-- Infer the types of multiple mutually-recursive values, and return elaborated values including

164-- type class dictionaries and type annotations.

165--

166−typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

166+typesOf :: ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

167−typesOf moduleName vals = do

167+typesOf mainModuleName moduleName vals = do

168 tys <- fmap tidyUp . liftUnify $ do

169 let

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

@@ -204,7 +204,7 @@ typesOf moduleName vals = do

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

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

206 -- If run-main is enabled, need to check that Main.main has type Eff eff a for some eff, a

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

207+ when (moduleName == mainModuleName && fst e == Ident "main") $ do

208 [eff, a] <- replicateM 2 fresh

209 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a

210 -- Make sure unification variables do not escape