fba4b71 · rowtype-yoga/purescript-native

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

Read foreign values from $foreign

commitfba4b7177f9ed73ee17bf10160b6d32f418c2fde authorGary Burgess <gary.burgess@gmail.com> dateSun 3 May 2015, 21:51 (11 years ago) parent5cee177

6 files changed+47−12

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+4−4 src/Language/PureScript/CodeGen/JS.hs+15−4 src/Language/PureScript/CoreFn/Desugar.hs+10−1 src/Language/PureScript/CoreFn/Meta.hs+5−1 src/Language/PureScript/Environment.hs+12−1 src/Language/PureScript/TypeChecker.hs+1−1

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

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

2424import Control.Monad.Writer

2525

2626import Language.PureScript.AST

27+import Language.PureScript.Comments

2728import Language.PureScript.Environment

2829import Language.PureScript.Kinds

2930import Language.PureScript.Names

3031import Language.PureScript.Pretty

3132import Language.PureScript.TypeClassDictionaries

3233import Language.PureScript.Types

33−import Language.PureScript.Comments

3434

3535-- |

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

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

5454 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

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

5656 exportsOp _ = False

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

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

5858 declToPs _ = return ()

5959

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

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

6363

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

6565 exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r

66− exportToPs (TypeRef pn dctors) = do

66+ exportToPs (TypeRef pn dctors) =

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

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

6969 Just (kind, ExternData) ->

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

9090 exportToPs (ValueRef ident) =

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

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

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

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

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

9595 _ -> return ()

9696 exportToPs (TypeClassRef className) =

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

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

2525 , mainCall

2626 ) where

2727

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

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

2929import qualified Data.Traversable as T (traverse)

3030

3131import Control.Applicative

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

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

5454 additional <- asks optionsAdditional

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

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

5756 jsDecls <- mapM bindToJs decls

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

5958 let isModuleEmpty = null exps

6059 comments <- not <$> asks optionsNoComments

6160 let strict = JSStringLiteral "use strict"

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

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

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

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

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

64+ let standardExps = exps \\ foreignExps

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

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

6567 return $ case additional of

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

6769 CompileOptions ns _ _ | not isModuleEmpty ->

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

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

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

173175 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

174182 valueToJs (Var _ ident) =

175183 return $ varToJs ident

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

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

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

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

249257

258+ foreignIdent :: Ident -> JS

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

260+

250261 -- |

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

252263 -- and guards.

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

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

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

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

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

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

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

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

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

108108 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

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

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

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

169169

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+

170179 -- |

171180 -- Gets metadata for data constructors.

172181 --

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

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

3535 -- |

3636 -- The contained value is a typeclass dictionary constructor

3737 --

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)

3943

4044-- |

4145-- Data constructor metadata

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

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

8888 -- |

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

9090 --

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

91+ | Public

92+ -- |

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

94+ --

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

9296

9397-- |

9498-- The kinds of a type

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

234238isNewtypeConstructor e ctor = case lookupConstructor e ctor of

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

236240 (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

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

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

216216 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) })

218218 ds <- go rest

219219 return $ d : ds

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