d906c3c · rowtype-yoga/purescript-native

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

Adding some comments and type signatures to aid my understanding a little

commitd906c3c9830f0bad7695c27ff7325f1b20b1b028 authorPhil Freeman <paf31@cantab.net> dateSun 2 Mar 2014, 12:55 (13 years ago) parent64fde97

3 files changed+49−27

compare with golang

unifiedsplit

examples/shouldfail/ImportExplicit2.purs+7 src/Language/PureScript/Sugar/Names.hs+41−12 src/Language/PureScript/TypeChecker.hs+1−15

examples/shouldfail/ImportExplicit2.pursnew file+7

@@ -0,0 +1,7 @@

1+module M1 where

3+ foo = "foo"

5+module Main where

7+ import M1 (X)

src/Language/PureScript/Sugar/Names.hs+41−12

@@ -16,8 +16,8 @@ module Language.PureScript.Sugar.Names (

1616 rename

1717) where

1818

19−import Control.Applicative ((<$>))

20−import Control.Monad (foldM, liftM)

19+import Control.Applicative ((<$>), (<*>))

20+import Control.Monad (forM_, unless, foldM, liftM)

2121import Data.Generics (extM, mkM, everywhereM)

2222import Data.List (intersect)

2323import qualified Data.Map as M

@@ -178,24 +178,53 @@ findImports = foldl findImports' M.empty

178178-- TODO: check explicit imports actually exist

179179--

180180resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

181−resolveImports env (Module currentModule decls) = do

182− types <- resolve exportedTypes (resolveDefs typeImports)

183− dataConstructors <- resolve exportedDataConstructors resolveDcons

184− typeClasses <- resolve exportedTypeClasses (resolveDefs classImports)

185− return $ ImportEnvironment types dataConstructors typeClasses

181+resolveImports env (Module currentModule decls) = ImportEnvironment

182+ <$> resolve (exportedTypes env) (resolveDefs typeImports)

183+ <*> resolve (exportedDataConstructors env) resolveDcons

184+ <*> resolve (exportedTypeClasses env) (resolveDefs classImports)

186185 where

186+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

187+ scope :: M.Map ModuleName (Maybe ExplicitImports)

187188 scope = M.insert currentModule Nothing (findImports decls)

188− resolve get f = foldM f M.empty (M.toList $ get env)

189− resolveDefs filt result (mn, names) = case M.lookup mn scope of

190− Just Nothing -> foldM (resolveDef mn) result (S.toList names)

191− Just (Just expl) -> foldM (resolveDef mn) result (S.toList names `intersect` filt expl)

192− Nothing -> Right result

189+

190+ -- Resolve all exported names in a set by applying a type-specific resolver function

191+ resolve :: M.Map ModuleName (S.Set id) ->

192+ (M.Map ProperName (Qualified ProperName) -> (ModuleName, S.Set id) -> Either String (M.Map ProperName (Qualified ProperName))) ->

193+ Either String (M.Map ProperName (Qualified ProperName))

194+ resolve m f = foldM f M.empty (M.toList m)

195+

196+ -- Resolve a single name by adding it to the Map with a specified ModuleName, checking first

197+ -- that the name does not currently exist in scope.

198+ resolveDef :: (Ord id, Show id) => ModuleName ->

199+ M.Map id (Qualified id) ->

200+ id ->

201+ Either String (M.Map id (Qualified id))

193202 resolveDef mn result name = case M.lookup name result of

194203 Nothing -> return $ M.insert name (Qualified (Just mn) name) result

195204 Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++

196205 if mn' == currentModule || mn == currentModule

197206 then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

198207 else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

208+

209+ -- Resolve a set of ProperName exports for a specific imported set of names

210+ -- This function is used to resolve both types and type classes, hence the filter function as

211+ -- its first argument

212+ resolveDefs :: (ExplicitImports -> [ProperName]) ->

213+ M.Map ProperName (Qualified ProperName) ->

214+ (ModuleName, S.Set ProperName) ->

215+ Either String (M.Map ProperName (Qualified ProperName))

216+ resolveDefs filt result (mn, names) = case M.lookup mn scope of

217+ Just Nothing -> foldM (resolveDef mn) result (S.toList names)

218+ Just (Just expl) -> do

219+ forM_ (filt expl) $ \name ->

220+ unless (name `S.member` names) $ Left $ runProperName name ++ " is explicitly imported but not defined"

221+ foldM (resolveDef mn) result (S.toList names `intersect` filt expl)

222+ Nothing -> Right result

223+

224+ -- Resolve a set of data constructors keyed by their type constructor

225+ resolveDcons :: M.Map ProperName (Qualified ProperName) ->

226+ (ModuleName, S.Set (ProperName, [ProperName])) ->

227+ Either String (M.Map ProperName (Qualified ProperName))

199228 resolveDcons result (mn, tcons) = case M.lookup mn scope of

200229 Just Nothing -> foldM (foldM $ resolveDef mn) result (snd `map` S.toList tcons)

201230 Just (Just expl) -> foldM (foldM $ resolveDef mn) result (snd `map` selectedTcons)

src/Language/PureScript/TypeChecker.hs+1−15

@@ -111,7 +111,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

111111 let syns = mapMaybe toTypeSynonym tys

112112 let dataDecls = mapMaybe toDataDecl tys

113113 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

114− forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->

114+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->

115115 addDataType moduleName name args dctors ctorKind

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

117117 addTypeSynonym moduleName name args ty kind

@@ -176,10 +176,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

176176 case idents of

177177 Nothing -> do

178178 shadowIdents (map snd $ filterModule (names env)) env

179− shadowTypes (map (\(Qualified _ name) -> name) $ filterModuleQ (types env)) env

180179 Just idents' -> do

181180 shadowIdents (nameImports idents') env

182− shadowTypes (typeImports idents') env

183181 shadowTypeClassInstances env

184182 ds <- typeCheckAll mainModuleName currentModule rest

185183 return $ d : ds

@@ -196,18 +194,6 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

196194 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

197195 modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

198196 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

199− shadowTypes pns env =

200− forM_ pns $ \pn ->

201− case Qualified (Just moduleName) pn `M.lookup` types env of

202− Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

203− Just k -> do

204− modifyEnv (\e -> e { types = M.insert (Qualified (Just currentModule) pn) k (types e) })

205− let keys = map fst . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

206− forM_ keys $ \dctor ->

207− case dctor `M.lookup` dataConstructors env of

208− Just ctorTy ->

209− modifyEnv (\e -> e { dataConstructors = M.insert dctor ctorTy (dataConstructors e) })

210− Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

211197 shadowTypeClassInstances env = do

212198 let instances = filter (\tcd ->

213199 let Qualified (Just mn) _ = tcdName tcd in