d3f368b · rowtype-yoga/purescript-native

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

Change ModuleName to accept [ProperName]

commitd3f368b99668e1905b4e73d4c0cbe754922dca02 authorGary Burgess <gary.burgess@gmail.com> dateMon 17 Feb 2014, 21:27 (13 years ago) parent1e3c158

19 files changed+70−63

compare with golang

unifiedsplit

docgen/Main.hs+2−2

@@ -59,8 +59,8 @@ renderModules ms = do

5959 mapM_ renderModule ms

6060

6161renderModule :: P.Module -> Docs

62−renderModule (P.Module (P.ProperName moduleName) ds) = do

63− headerLevel 2 $ "Module " ++ moduleName

62+renderModule (P.Module moduleName ds) = do

63+ headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)

6464 spacer

6565 headerLevel 3 "Types"

6666 spacer

psci/Main.hs+4−4

@@ -51,7 +51,7 @@ completion ms = completeWord Nothing " \t\n\r" findCompletions

5151 | P.Module moduleName ds <- ms

5252 , ident <- mapMaybe getDeclName ds

5353 , qual <- [ P.Qualified Nothing ident

54− , P.Qualified (Just (P.ModuleName moduleName)) ident]

54+ , P.Qualified (Just moduleName) ident]

5555 ]

5656 let matches = filter (isPrefixOf str) names

5757 return $ map simpleCompletion matches ++ files

@@ -62,16 +62,16 @@ completion ms = completeWord Nothing " \t\n\r" findCompletions

6262createTemporaryModule :: [P.ProperName] -> P.Value -> P.Module

6363createTemporaryModule imports value =

6464 let

65− moduleName = P.ProperName "Main"

65+ moduleName = P.ModuleName [P.ProperName "Main"]

6666 importDecl m = P.ImportDeclaration m Nothing

67− traceModule = P.ModuleName (P.ProperName "Trace")

67+ traceModule = P.ModuleName [P.ProperName "Trace"]

6868 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

6969 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

7070 (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

7171 , P.DoNotationValue (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) )

7272 ])

7373 in

74− P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

74+ P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl]

7575

7676handleDeclaration :: [P.Module] -> [P.ProperName] -> P.Value -> InputT IO ()

7777handleDeclaration loadedModules imports value = do

src/Language/PureScript.hs+5−5

@@ -60,19 +60,19 @@ compile opts ms = do

6060 sorted <- sortModules ms

6161 desugared <- desugar sorted

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

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

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

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

64+ Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls

6565 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66− let entryPoints = optionsModules opts

66+ let entryPoints = (ModuleName . return . ProperName) `map` optionsModules opts

6767 let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

6868 let js = mapMaybe (flip (moduleToJs opts) env) elim

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

7070 js' <- case optionsMain opts of

7171 Just mainModuleName -> do

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

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

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

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

7575 _ -> return js

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

7777 where

78− mainModuleIdent = ModuleName . ProperName <$> (optionsMain opts)

78+ mainModuleIdent = (ModuleName . return . ProperName) <$> optionsMain opts

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

@@ -29,9 +29,9 @@ import Data.List (intercalate)

2929-- Generate foreign imports for all declarations in a module

3030--

3131moduleToPs :: Module -> Environment -> String

32−moduleToPs (Module pname@(ProperName moduleName) decls) env =

33− "module " ++ moduleName ++ " where\n" ++

34− (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)

32+moduleToPs (Module mn decls) env =

33+ "module " ++ (runModuleName mn) ++ " where\n" ++

34+ (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

3535

3636declToPs :: ModuleName -> Environment -> Declaration -> [String]

3737declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

src/Language/PureScript/CodeGen/JS.hs+9−6

@@ -23,7 +23,7 @@ module Language.PureScript.CodeGen.JS (

2323) where

2424

2525import Data.Maybe (fromMaybe, mapMaybe)

26−import Data.List (sortBy)

26+import Data.List (sortBy, intercalate)

2727import Data.Function (on)

2828import Data.Data (Data)

2929import Data.Generics (mkQ, everything)

@@ -52,14 +52,17 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

5252-- module.

5353--

5454moduleToJs :: Options -> Module -> Environment -> Maybe JS

55−moduleToJs opts (Module pname@(ProperName name) decls) env =

55+moduleToJs opts (Module name decls) env =

5656 case jsDecls of

5757 [] -> Nothing

58− _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $

58+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJS name) (JSVar "_ps")) $

5959 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

60− [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

60+ [(JSBinary Or (JSAccessor (moduleNameToJS name) (JSVar "_ps")) (JSObjectLiteral []))]

6161 where

62− jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))

62+ jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))

63+

64+moduleNameToJS :: ModuleName -> String

65+moduleNameToJS (ModuleName pns) = intercalate "_" (runProperName `map` pns)

6366

6467-- |

6568-- Generate code in the simplified Javascript intermediate representation for a declaration

@@ -212,7 +215,7 @@ varToJs m e qual@(Qualified _ ident) = go qual

212215-- variable that may have a qualified name.

213216--

214217qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

215−qualifiedToJS m f (Qualified (Just m'@(ModuleName (ProperName mn))) a) | m /= m' = accessor (f a) (JSAccessor mn $ JSVar "_ps")

218+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJS m') $ JSVar "_ps")

216219qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)

217220

218221-- |

src/Language/PureScript/CodeGen/Optimize.hs+4−4

@@ -284,8 +284,8 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

284284 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True

285285 isRetPoly _ = False

286286

287− prelude = ModuleName (ProperName "Prelude")

288− effModule = ModuleName (ProperName "Eff")

287+ prelude = ModuleName [ProperName "Prelude"]

288+ effModule = ModuleName [ProperName "Eff"]

289289

290290 Right (Ident effDictName) = mkDictionaryValueName

291291 effModule

@@ -382,7 +382,7 @@ inlineCommonOperators = applyAll

382382 isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

383383 where

384384 Right (Ident dictName) = mkDictionaryValueName

385− (ModuleName (ProperName "Prim"))

386− (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))

385+ (ModuleName [ProperName "Prim"])

386+ (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))

387387 ty

388388 isOpDict _ _ _ = False

src/Language/PureScript/DeadCodeElimination.hs+7−7

@@ -30,12 +30,12 @@ import Language.PureScript.TypeChecker.Monad

3030-- |

3131-- Eliminate all declarations which are not a transitive dependency of the entry point module

3232--

33−eliminateDeadCode :: Environment -> [String] -> [Module] -> [Module]

33+eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module]

3434eliminateDeadCode env entryPoints ms =

3535 let declarations = concatMap (declarationsByModule env) ms

3636 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn `elem` entryPoints) $ declarations

38− in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)

37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)

3939

4040type Key = (ModuleName, Either Ident ProperName)

4141

@@ -43,10 +43,10 @@ declarationsByModule :: Environment -> Module -> [(Key, [Key])]

4343declarationsByModule env (Module moduleName ds) = concatMap go $ ds

4444 where

4545 go :: Declaration -> [(Key, [Key])]

46− go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]

47− go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors

48− go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]

49− go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names

46+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]

47+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

48+ go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

49+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names

5050 go (DataBindingGroupDeclaration ds) = concatMap go ds

5151 go _ = []

5252

src/Language/PureScript/Declarations.hs+1−1

@@ -42,7 +42,7 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable

4242-- |

4343-- A module declaration, consisting of a module name and a list of declarations

4444--

45−data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

45+data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)

4646

4747-- |

4848-- The type of a foreign import

src/Language/PureScript/ModuleDependencies.hs+9−9

@@ -40,21 +40,21 @@ sortModules ms = do

4040-- |

4141-- Calculate a list of used modules based on explicit imports and qualified names

4242--

43−usedModules :: (Data d) => d -> [ProperName]

43+usedModules :: (Data d) => d -> [ModuleName]

4444usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)

4545 where

46− qualifiedIdents :: Qualified Ident -> [ProperName]

47− qualifiedIdents (Qualified (Just (ModuleName pn)) _) = [pn]

46+ qualifiedIdents :: Qualified Ident -> [ModuleName]

47+ qualifiedIdents (Qualified (Just mn) _) = [mn]

4848 qualifiedIdents _ = []

49− qualifiedProperNames :: Qualified ProperName -> [ProperName]

50− qualifiedProperNames (Qualified (Just (ModuleName pn)) _) = [pn]

49+ qualifiedProperNames :: Qualified ProperName -> [ModuleName]

50+ qualifiedProperNames (Qualified (Just mn) _) = [mn]

5151 qualifiedProperNames _ = []

52− imports :: Declaration -> [ProperName]

53− imports (ImportDeclaration (ModuleName pn) _) = [pn]

52+ imports :: Declaration -> [ModuleName]

53+ imports (ImportDeclaration mn _) = [mn]

5454 imports _ = []

5555

56−getModuleName :: Module -> ProperName

57−getModuleName (Module pn _) = pn

56+getModuleName :: Module -> ModuleName

57+getModuleName (Module mn _) = mn

5858

5959-- |

6060-- Convert a strongly connected component of the module graph to a module

src/Language/PureScript/Names.hs+6−2

@@ -17,6 +17,7 @@

1717

1818module Language.PureScript.Names where

1919

20+import Data.List

2021import Data.Data

2122import Data.Function (on)

2223

@@ -64,10 +65,13 @@ instance Show ProperName where

6465-- |

6566-- Module names

6667--

67−data ModuleName = ModuleName { runModuleName :: ProperName } deriving (Eq, Ord, Data, Typeable)

68+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)

69+

70+runModuleName :: ModuleName -> String

71+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

6872

6973instance Show ModuleName where

70− show (ModuleName name) = show name

74+ show = runModuleName

7175

7276-- |

7377-- A qualified name, i.e. a name with an optional module name

src/Language/PureScript/Parser/Common.hs+1−1

@@ -209,7 +209,7 @@ properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum

209209parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

210210parseQualified parser = qual

211211 where

212− qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)

212+ qual = (Qualified <$> (Just . ModuleName . pure <$> P.try (properName <* delimiter)) <*> parser)

213213 <|> (Qualified Nothing <$> P.try parser)

214214 delimiter = indented *> dot

215215

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -89,7 +89,7 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration

8989parseImportDeclaration = do

9090 reserved "import"

9191 indented

92− moduleName <- ModuleName <$> properName

92+ moduleName <- ModuleName . pure <$> properName

9393 idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

9494 return $ ImportDeclaration moduleName idents

9595

@@ -141,7 +141,7 @@ parseModule = do

141141 name <- properName

142142 _ <- lexeme $ P.string "where"

143143 decls <- mark (P.many (same *> parseDeclaration))

144− return $ Module name decls

144+ return $ Module (ModuleName [name]) decls

145145

146146-- |

147147-- Parse a collection of modules

src/Language/PureScript/Sugar/BindingGroups.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.Types

3636-- Replace all sets of mutually-recursive declarations in a module with binding groups

3737--

3838createBindingGroupsModule :: [Module] -> Either String [Module]

39−createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups (ModuleName name) ds

39+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds

4040

4141-- |

4242-- Collapse all binding groups in a module to individual declarations

src/Language/PureScript/Sugar/DoNotation.hs+1−1

@@ -33,7 +33,7 @@ desugarDo :: (Data d) => d -> Either String d

3333desugarDo = everywhereM (mkM replace)

3434 where

3535 prelude :: ModuleName

36− prelude = ModuleName (ProperName "Prelude")

36+ prelude = ModuleName [ProperName "Prelude"]

3737 ret :: Value

3838 ret = Var (Qualified (Just prelude) (Ident "ret"))

3939 bind :: Value

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -46,9 +46,9 @@ rebracket = go M.empty []

4646 where

4747 go _ rb [] = return . reverse $ rb

4848 go m rb (Module name ds : ms) = do

49− m' <- M.union m <$> collectFixities m (ModuleName name) ds

49+ m' <- M.union m <$> collectFixities m name ds

5050 let opTable = customOperatorTable m'

51− ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds

51+ ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds

5252 go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms

5353

5454removeParens :: Value -> Value

src/Language/PureScript/Sugar/TypeClasses.hs+2−2

@@ -50,7 +50,7 @@ desugarTypeClasses :: [Module] -> Either String [Module]

5050desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

5151

5252desugarModule :: Module -> Desugar Module

53−desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

53+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls

5454

5555-- |

5656-- Desugar type class and type class instance declarations

@@ -159,7 +159,7 @@ typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in

159159

160160qualifiedToString :: ModuleName -> Qualified ProperName -> String

161161qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

162−qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn

162+qualifiedToString _ (Qualified (Just mn) pn) = runModuleName mn ++ "_" ++ runProperName pn

163163

164164-- |

165165-- Generate a name for a type class dictionary, based on the module name, class name and type name

src/Language/PureScript/TypeChecker/Monad.hs+5−5

@@ -118,11 +118,11 @@ data Environment = Environment {

118118-- The basic types existing in the external javascript environment

119119--

120120jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

121−jsTypes = M.fromList [ ((ModuleName $ ProperName "Prim", ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

122− , ((ModuleName $ ProperName "Prim", ProperName "Array"), (FunKind Star Star, ExternData))

123− , ((ModuleName $ ProperName "Prim", ProperName "String"), (Star, ExternData))

124− , ((ModuleName $ ProperName "Prim", ProperName "Number"), (Star, ExternData))

125− , ((ModuleName $ ProperName "Prim", ProperName "Boolean"), (Star, ExternData)) ]

121+jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

122+ , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))

123+ , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))

124+ , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))

125+ , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]

126126

127127-- |

128128-- The initial environment with no values and only the default javascript types defined

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

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

208208 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

209209 when (Just moduleName == mainModuleName && fst e == Ident "main") $ do

210210 [eff, a] <- replicateM 2 fresh

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

211+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a

212212 -- Make sure unification variables do not escape

213213 escapeCheck val ty

214214 return triple

src/Language/PureScript/Types.hs+5−5

@@ -92,31 +92,31 @@ data Type

9292-- Type constructor for functions

9393--

9494tyFunction :: Type

95−tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Function")

95+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")

9696

9797-- |

9898-- Type constructor for strings

9999--

100100tyString :: Type

101−tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "String")

101+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")

102102

103103-- |

104104-- Type constructor for numbers

105105--

106106tyNumber :: Type

107−tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Number")

107+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")

108108

109109-- |

110110-- Type constructor for booleans

111111--

112112tyBoolean :: Type

113−tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Boolean")

113+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")

114114

115115-- |

116116-- Type constructor for arrays

117117--

118118tyArray :: Type

119−tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Array")

119+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

120120

121121-- |

122122-- Smart constructor for function types