fba4b71 · rowtype-yoga/purescript-native

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

on golang help sign in

Read foreign values from $foreign

fba4b71Gary Burgess11 years ago

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

compare with golang

unifiedsplit

@@ -24,13 +24,13 @@ import qualified Data.Map as M

24import Control.Monad.Writer

26import Language.PureScript.AST

27+import Language.PureScript.Comments

27import Language.PureScript.Environment

28import Language.PureScript.Environment

28import Language.PureScript.Kinds

29import Language.PureScript.Kinds

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Pretty

31import Language.PureScript.Pretty

31import Language.PureScript.TypeClassDictionaries

32import Language.PureScript.TypeClassDictionaries

32import Language.PureScript.Types

33import Language.PureScript.Types

33−import Language.PureScript.Comments

35-- |

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

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

54 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

55 exportsOp (ValueRef ident') = ident' == Op op

56 exportsOp _ = False

57− declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d

57+ declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d

58 declToPs _ = return ()

60 commentToPs :: Comment -> Writer [String] ()

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

64 exportToPs :: DeclarationRef -> Writer [String] ()

65 exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r

66− exportToPs (TypeRef pn dctors) = do

66+ exportToPs (TypeRef pn dctors) =

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

68 Nothing -> error $ show pn ++ " has no kind in exportToPs"

69 Just (kind, ExternData) ->

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

90 exportToPs (ValueRef ident) =

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

92 Nothing -> error $ show ident ++ " has no type in exportToPs"

93− Just (ty, Public, _) ->

93+ Just (ty, nk, _) | nk == Public || nk == External ->

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

95 _ -> return ()

96 exportToPs (TypeClassRef className) =

src/Language/PureScript/CodeGen/JS.hs+15−4

@@ -25,7 +25,7 @@ module Language.PureScript.CodeGen.JS

25 , mainCall

26 ) where

28−import Data.List ((\\), delete)

28+import Data.List ((\\), delete, intersect)

29import qualified Data.Traversable as T (traverse)

31import Control.Applicative

@@ -53,15 +53,17 @@ moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode)

53moduleToJs (Module coms mn imps exps foreigns decls) = do

54 additional <- asks optionsAdditional

55 jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps

56− let foreigns' = [] -- TODO: Update this. mapMaybe (\(_, js, _) -> js) foreigns

57 jsDecls <- mapM bindToJs decls

56 jsDecls <- mapM bindToJs decls

58 optimized <- T.traverse (T.traverse optimize) jsDecls

57 optimized <- T.traverse (T.traverse optimize) jsDecls

59 let isModuleEmpty = null exps

58 let isModuleEmpty = null exps

60 comments <- not <$> asks optionsNoComments

59 comments <- not <$> asks optionsNoComments

61 let strict = JSStringLiteral "use strict"

60 let strict = JSStringLiteral "use strict"

62 let header = if comments && not (null coms) then JSComment coms strict else strict

61 let header = if comments && not (null coms) then JSComment coms strict else strict

63− let moduleBody = header : jsImports ++ foreigns' ++ concat optimized

62+ let moduleBody = header : jsImports ++ concat optimized

63+ let foreignExps = exps `intersect` (fst `map` foreigns)

64+ let standardExps = exps \\ foreignExps

64− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

65+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps

66+ ++ map (runIdent &&& foreignIdent) foreignExps

65 return $ case additional of

67 return $ case additional of

66 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

68 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

67 CompileOptions ns _ _ | not isModuleEmpty ->

69 CompileOptions ns _ _ | not isModuleEmpty ->

@@ -171,6 +173,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) = do

171 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

173 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

172 unApp (App _ val arg) args = unApp val (arg : args)

174 unApp (App _ val arg) args = unApp val (arg : args)

173 unApp other args = (other, args)

175 unApp other args = (other, args)

176+ valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =

177+ return $ if mn' == mn

178+ then foreignIdent ident

179+ else varToJs qi

180+ valueToJs (Var (_, _, _, Just IsForeign) ident) =

181+ error $ "Encountered an unqualified reference to a foreign ident " ++ show ident

174 valueToJs (Var _ ident) =

182 valueToJs (Var _ ident) =

175 return $ varToJs ident

183 return $ varToJs ident

176 valueToJs (Case (maybeSpan, _, _, _) values binders) = do

184 valueToJs (Case (maybeSpan, _, _, _) values binders) = do

@@ -247,6 +255,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) = do

247 qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))

255 qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))

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

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

249

257

258+ foreignIdent :: Ident -> JS

259+ foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")

260+

250 -- |

261 -- |

251 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

262 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

252 -- and guards.

263 -- and guards.

src/Language/PureScript/CoreFn/Desugar.hs+10−1

@@ -102,7 +102,7 @@ moduleToCoreFn env (A.Module coms mn decls (Just exps)) =

102 exprToCoreFn ss com ty (A.App v1 v2) =

103 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

104 exprToCoreFn ss com ty (A.Var ident) =

105− Var (ss, com, ty, Nothing) ident

105+ Var (ss, com, ty, getValueMeta ident) ident

106 exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =

107 Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]

108 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

@@ -167,6 +167,15 @@ moduleToCoreFn env (A.Module coms mn decls (Just exps)) =

167 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

168 binderToCoreFn (Just ss) (com ++ com1) b

169

170+ -- |

171+ -- Gets metadata for values.

172+ --

173+ getValueMeta :: Qualified Ident -> Maybe Meta

174+ getValueMeta name =

175+ case lookupValue env name of

176+ Just (_, External, _) -> Just IsForeign

177+ _ -> Nothing

178+

170 -- |

179 -- |

171 -- Gets metadata for data constructors.

180 -- Gets metadata for data constructors.

172 --

181 --

src/Language/PureScript/CoreFn/Meta.hs+5−1

@@ -35,7 +35,11 @@ data Meta

35 -- |

36 -- The contained value is a typeclass dictionary constructor

37 --

38− | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)

38+ | IsTypeClassConstructor

39+ -- |

40+ -- The contained reference is for a foreign member

41+ --

42+ | IsForeign deriving (Show, D.Data, D.Typeable)

40-- |

44-- |

41-- Data constructor metadata

45-- Data constructor metadata

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

@@ -88,7 +88,11 @@ data NameKind

88 -- |

89 -- A public value for a module member or foreing import declaration

90 --

91+ | Public

92+ -- |

93+ -- A name for member introduced by foreign import

94+ --

91− | Public deriving (Show, Eq, Data, Typeable)

95+ | External deriving (Show, Eq, Data, Typeable)

93-- |

97-- |

94-- The kinds of a type

98-- The kinds of a type

@@ -234,3 +238,10 @@ isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

234isNewtypeConstructor e ctor = case lookupConstructor e ctor of

238isNewtypeConstructor e ctor = case lookupConstructor e ctor of

235 (Newtype, _, _, _) -> True

239 (Newtype, _, _, _) -> True

236 (Data, _, _, _) -> False

240 (Data, _, _, _) -> False

241+

242+-- |

243+-- Finds information about values from the current environment.

244+--

245+lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)

246+lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env

247+lookupValue _ _ = Nothing

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

@@ -214,7 +214,7 @@ typeCheckAll mainModuleName moduleName exps = go

214 guardWith (errorMessage (ExpectedType kind)) $ kind == Star

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

216 Just _ -> throwError . errorMessage $ RedefinedIdent name

217− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Public, Defined) (names env) })

217+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

218 ds <- go rest

219 return $ d : ds

220 go (d@(FixityDeclaration _ name) : rest) = do