51eced9 · rowtype-yoga/purescript-native

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

on golang help sign in

Initial CommonJS modules commit

51eced9Phil Freeman13 years ago

src/Language/PureScript.hs+7−7

compare with golang

unifiedsplit

@@ -37,7 +37,7 @@ import Data.List (find, sortBy, groupBy, intercalate)

37import Data.Time.Clock

38import Data.Function (on)

39import Data.Generics (mkQ, everything)

40−import Data.Maybe (fromMaybe, mapMaybe)

40+import Data.Maybe (fromMaybe)

41import Control.Monad.Error

42import Control.Monad.State.Lazy

43import Control.Arrow ((&&&))

@@ -78,10 +78,11 @@ compile' env opts ms = do

78 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

79 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

80 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim

81+ let js = JSVariableIntroduction (optionsBrowserNamespace opts) (Just (JSObjectLiteral []))

81− let js = mapMaybe (flip (moduleToJs opts) env') modulesToCodeGen

82+ : concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen

82 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

83 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

83 js' <- generateMain env' opts js

84 js' <- generateMain env' opts js

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

85+ return (prettyPrintJS js', exts, env')

85 where

86 where

86 mainModuleIdent = moduleNameFromString <$> optionsMain opts

87 mainModuleIdent = moduleNameFromString <$> optionsMain opts

@@ -128,7 +129,7 @@ generateMain env opts js =

128 Just mmi -> do

129 Just mmi -> do

129 when ((mmi, Ident C.main) `M.notMember` names env) $

130 when ((mmi, Ident C.main) `M.notMember` names env) $

130 Left $ show mmi ++ "." ++ C.main ++ " is undefined"

131 Left $ show mmi ++ "." ++ C.main ++ " is undefined"

131− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]

132+ return $ js ++ [JSApp (JSAccessor C.main (JSVar (moduleNameToJs mmi))) []]

132 _ -> return js

133 _ -> return js

133

134

134-- |

135-- |

@@ -206,11 +207,10 @@ make opts ms = do

206 regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

207 regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

207

208

208 let mod' = Module moduleName' regrouped exps

209 let mod' = Module moduleName' regrouped exps

209− js = moduleToJs opts mod' env'

210+ js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'

210 exts = moduleToPs mod' env'

211 exts = moduleToPs mod' env'

211− js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js

212

213− writeTextFile jsFile js'

213+ writeTextFile jsFile js

214 writeTextFile externsFile exts

215

216 go env' ms'

src/Language/PureScript/CodeGen/JS.hs+41−38

@@ -17,14 +17,16 @@

18module Language.PureScript.CodeGen.JS (

19 module AST,

20+ ModuleType(..),

20 declToJs,

21 declToJs,

21 moduleToJs,

22 moduleToJs,

22− wrapExportsContainer,

23 isIdent

24) where

26import Data.Maybe (fromMaybe, mapMaybe)

27import Data.Function (on)

28+import Data.List (nub, (\\))

29+import Data.Generics (mkQ, everything)

29import Control.Arrow (second)

31import Control.Arrow (second)

30import Control.Monad (replicateM, forM)

32import Control.Monad (replicateM, forM)

@@ -41,26 +43,45 @@ import Language.PureScript.Types

41import Language.PureScript.Optimizer

43import Language.PureScript.Optimizer

42import Language.PureScript.CodeGen.Common

44import Language.PureScript.CodeGen.Common

43import Language.PureScript.Environment

45import Language.PureScript.Environment

44−import qualified Language.PureScript.Constants as C

46+

47+-- |

48+-- Different types of modules which are supported

49+--

50+data ModuleType = CommonJS | Globals

46-- |

52-- |

47-- Generate code in the simplified Javascript intermediate representation for all declarations in a

53-- Generate code in the simplified Javascript intermediate representation for all declarations in a

48-- module.

54-- module.

49--

55--

50−moduleToJs :: Options -> Module -> Environment -> Maybe JS

56+moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]

51−moduleToJs opts (Module name decls (Just exps)) env =

57+moduleToJs mt opts (Module name decls (Just exps)) env = case mt of

52− case jsDecls of

58+ CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

53− [] -> Nothing

59+ Globals ->

54− _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $

60+ [ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (optionsBrowserNamespace opts))) (

55− JSApp (JSFunction Nothing [] (JSBlock $

61+ JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) []

56− JSVariableIntroduction "module" (Just $ JSObjectLiteral []) :

62+ )

57− jsDecls ++

63+ ]

58− jsExports ++

59− [JSReturn $ JSVar "module"])) []

60 where

64 where

65+ moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls

66+ moduleExports = JSObjectLiteral $ concatMap exportToJs exps

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

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

62− jsExports = concatMap exportToJs exps

68+ jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls

63−moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"

69+moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"

70+

71+importToJs :: ModuleType -> Options -> ModuleName -> JS

72+importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

73+ where

74+ moduleBody = case mt of

75+ CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

76+ Globals -> JSAccessor (runModuleName mn) (JSVar (optionsBrowserNamespace opts))

77+

78+imports :: Declaration -> [ModuleName]

79+imports = everything (++) (mkQ [] collect)

80+ where

81+ collect :: Value -> [ModuleName]

82+ collect (Var (Qualified (Just mn) _)) = [mn]

83+ collect (Constructor (Qualified (Just mn) _)) = [mn]

84+ collect _ = []

65-- |

86-- |

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

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

@@ -87,22 +108,14 @@ declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

87declToJs _ _ _ _ = Nothing

108declToJs _ _ _ _ = Nothing

109

89-- |

110-- |

90−-- Generate code in the simplified Javascript intermediate representation for an export from a

111+-- Generate key//value pairs for an object literal exporting values from a module.

91−-- module.

92--

112--

93−exportToJs :: DeclarationRef -> [JS]

113+exportToJs :: DeclarationRef -> [(String, JS)]

94−exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)

114+exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors

95−exportToJs (ValueRef name) = [export name]

115+exportToJs (ValueRef name) = [(runIdent name, var name)]

96−exportToJs (TypeInstanceRef name) = [export name]

116+exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]

97exportToJs _ = []

117exportToJs _ = []

118

99−-- |

100−-- Generate code in the simplified Javascript intermediate representation for assigning an exported

101−-- value to the current module object.

102−--

103−export :: Ident -> JS

104−export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)

105−

106-- |

119-- |

107-- Generate code in the simplified Javascript intermediate representation for a variable based on a

120-- Generate code in the simplified Javascript intermediate representation for a variable based on a

108-- PureScript identifier.

121-- PureScript identifier.

@@ -225,7 +238,7 @@ varToJs m qual = qualifiedToJS m id qual

225-- variable that may have a qualified name.

238-- variable that may have a qualified name.

226--

239--

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

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

228−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar C._ps)

241+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))

229qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

242qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

230

243

231-- |

244-- |

@@ -328,13 +341,3 @@ isOnlyConstructor e ctor =

328 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

341 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

329 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

342 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

330 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

343 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

331−

332−wrapExportsContainer :: Options -> [JS] -> JS

333−wrapExportsContainer opts modules = JSApp (JSFunction Nothing [C._ps] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]

334− where

335− exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))

336− (JSAccessor "exports" (JSVar "module"))

337− (JSConditional (JSBinary NotEqualTo (JSTypeOf $ JSVar "window") (JSStringLiteral "undefined"))

338− (JSAssignment (JSAccessor browserNamespace (JSVar "window")) (JSBinary Or (JSAccessor browserNamespace (JSVar "window")) (JSObjectLiteral [])))

339− (JSApp (JSFunction Nothing [] $ JSBlock [JSThrow $ JSStringLiteral "PureScript doesn't know how to export modules in the current environment"]) []))

340− browserNamespace = optionsBrowserNamespace opts

src/Language/PureScript/Constants.hs−3

@@ -180,9 +180,6 @@ main = "main"

180

181-- Code Generation

182

183−_ps :: String

184−_ps = "_ps"

185−

186__superclasses :: String

183__superclasses :: String

187__superclasses = "__superclasses"

184__superclasses = "__superclasses"

188

185

src/Language/PureScript/Names.hs+4

@@ -33,6 +33,10 @@ data Ident

33 --

34 | Op String deriving (Eq, Ord, Data, Typeable)

36+runIdent :: Ident -> String

37+runIdent (Ident i) = i

38+runIdent (Op op) = op

39+

36instance Show Ident where

40instance Show Ident where

37 show (Ident s) = s

41 show (Ident s) = s

38 show (Op op) = '(':op ++ ")"

42 show (Op op) = '(':op ++ ")"

src/Language/PureScript/Optimizer/Inliner.hs+7−20

@@ -81,12 +81,8 @@ inlineOperator (m, op) f = everywhere (mkT convert)

81 convert :: JS -> JS

82 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

83 convert other = other

84− isOp (JSAccessor longForm (JSAccessor m' (JSVar _ps))) | m == m' &&

85− _ps == C._ps &&

86− longForm == identToJs (Op op) = True

84+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)

87− isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

85+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'

88− _ps == C._ps &&

89− op == op' = True

90 isOp _ = False

86 isOp _ = False

92inlineCommonOperators :: JS -> JS

88inlineCommonOperators :: JS -> JS

@@ -131,11 +127,8 @@ inlineCommonOperators = applyAll

131 convert :: JS -> JS

127 convert :: JS -> JS

132 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

128 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

133 convert other = other

129 convert other = other

134− isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&

130+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)

135− longForm == identToJs (Op opString) = True

136− isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

131+ isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'

137− _ps == C._ps &&

138− opString == op' = True

139 isOp _ = False

132 isOp _ = False

140 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

133 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

141 binaryFunction dictName fnName op = everywhere (mkT convert)

134 binaryFunction dictName fnName op = everywhere (mkT convert)

@@ -143,9 +136,7 @@ inlineCommonOperators = applyAll

143 convert :: JS -> JS

136 convert :: JS -> JS

144 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

137 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

145 convert other = other

138 convert other = other

146− isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

139+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'

147− _ps == C._ps &&

148− fnName == fnName' = True

149 isOp _ = False

140 isOp _ = False

150 unary :: String -> String -> UnaryOperator -> JS -> JS

141 unary :: String -> String -> UnaryOperator -> JS -> JS

151 unary dictName fnName op = everywhere (mkT convert)

142 unary dictName fnName op = everywhere (mkT convert)

@@ -153,11 +144,7 @@ inlineCommonOperators = applyAll

153 convert :: JS -> JS

144 convert :: JS -> JS

154 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

145 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

155 convert other = other

146 convert other = other

156− isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

147+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

157− _ps == C._ps &&

158− fnName' == fnName = True

159 isOp _ = False

148 isOp _ = False

160− isOpDict dictName (JSApp (JSAccessor prop (JSAccessor prelude (JSVar _ps))) [JSObjectLiteral []]) | prelude == C.prelude &&

149+ isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName

161− _ps == C._ps &&

162− prop == dictName = True

163 isOpDict _ _ = False

150 isOpDict _ _ = False

src/Language/PureScript/Optimizer/MagicDo.hs+7−21

@@ -80,31 +80,19 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

80 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True

81 isReturn _ = False

82 -- Check if an expression represents the polymorphic >>= function

83− isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

83+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))

84− _ps == C._ps &&

85− prop == identToJs (Op (C.>>=)) = True

86− isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

84+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)

87− _ps == C._ps &&

88− bind == (C.>>=) = True

89 isBindPoly _ = False

85 isBindPoly _ = False

90 -- Check if an expression represents the polymorphic return function

86 -- Check if an expression represents the polymorphic return function

91− isRetPoly (JSAccessor returnEscaped (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

87+ isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped

92− _ps == C._ps &&

93− returnEscaped == C.returnEscaped = True

94− isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

88+ isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return

95− _ps == C._ps &&

96− return' == C.return = True

97 isRetPoly _ = False

89 isRetPoly _ = False

98 -- Check if an expression represents a function in the Ef module

90 -- Check if an expression represents a function in the Ef module

99− isEffFunc name (JSAccessor name' (JSAccessor eff (JSVar _ps))) | eff == C.eff &&

91+ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

100− _ps == C._ps &&

101− name == name' = True

102 isEffFunc _ _ = False

92 isEffFunc _ _ = False

103 -- Check if an expression represents the Monad Eff dictionary

93 -- Check if an expression represents the Monad Eff dictionary

104 isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True

94 isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True

105− isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&

95+ isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name

106− _ps == C._ps &&

107− prop == name = True

108 isEffDict _ _ = False

96 isEffDict _ _ = False

109 -- Remove __do function applications which remain after desugaring

97 -- Remove __do function applications which remain after desugaring

110 undo :: JS -> JS

98 undo :: JS -> JS

@@ -147,9 +135,7 @@ inlineST = everywhere (mkT convertBlock)

147 JSAssignment (JSIndexer i arr) val

135 JSAssignment (JSIndexer i arr) val

148 convert _ other = other

136 convert _ other = other

149 -- Check if an expression represents a function in the ST module

137 -- Check if an expression represents a function in the ST module

150− isSTFunc name (JSAccessor name' (JSAccessor st (JSVar _ps))) | st == C.st &&

138+ isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'

151− _ps == C._ps &&

152− name == name' = True

153 isSTFunc _ _ = False

139 isSTFunc _ _ = False

154 -- Find all ST Refs initialized in this block

140 -- Find all ST Refs initialized in this block

155 findSTRefsIn = everything (++) (mkQ [] isSTRef)

141 findSTRefsIn = everything (++) (mkQ [] isSTRef)