Simplify representation of foreign declarations

garyb · garyb · commit 5cee1770deed · 2015-05-13T20:39:11.000+01:00
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
@@ -93,7 +93,6 @@ docgen (PSCDocsOptions fmt input output) =
                 let fp = fst (head grp)
                 createDirectoryIfMissing True (takeDirectory fp)
                 writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
-
   where
   guardMissing [] = return ()
   guardMissing [mn] = do
diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs
@@ -11,7 +11,7 @@ tags = concatMap dtags . P.exportedDeclarations
         names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames
           where consNames = map (\(cname, _) -> P.runProperName cname) dcons
         names (P.TypeDeclaration ident _) = [show ident]
-        names (P.ExternDeclaration _ ident _ _) = [show ident]
+        names (P.ExternDeclaration ident _) = [show ident]
         names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
         names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
         names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]
diff --git a/psci/Completion.hs b/psci/Completion.hs
@@ -199,7 +199,7 @@ identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
   where
   getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
   getDeclName d@(P.ValueDeclaration ident _ _ _)  = Just (ident, d)
-  getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)
+  getDeclName d@(P.ExternDeclaration ident _) = Just (ident, d)
   getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
   getDeclName _ = Nothing
 
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
@@ -65,7 +65,7 @@ supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
 
 -- | Support module, contains code to evaluate terms
 supportModule :: P.Module
-supportModule = 
+supportModule =
   case P.parseModulesFromFiles id [("", code)] of
     Right [(_, P.Module cs _ ds exps)] -> P.Module cs supportModuleName ds exps
     _ -> error "Support module could not be parsed"
@@ -245,8 +245,8 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
     moduleName = P.ModuleName [P.ProperName "$PSCI"]
     trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
     mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
-    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val
-    mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
+    itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
+    mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
     decls = if exec then [itDecl, mainDecl] else [itDecl]
   in
     P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
diff --git a/psci/Parser.hs b/psci/Parser.hs
@@ -122,13 +122,13 @@ discardPositionInfo (P.PositionedDeclaration _ _ d) = d
 discardPositionInfo d = d
 
 acceptable :: P.Declaration -> Bool
-acceptable (P.DataDeclaration _ _ _ _) = True
-acceptable (P.TypeSynonymDeclaration _ _ _) = True
-acceptable (P.ExternDeclaration _ _ _ _) = True
-acceptable (P.ExternDataDeclaration _ _) = True
-acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
-acceptable (P.TypeClassDeclaration _ _ _ _) = True
-acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
+acceptable P.DataDeclaration{} = True
+acceptable P.TypeSynonymDeclaration{} = True
+acceptable P.ExternDeclaration{} = True
+acceptable P.ExternDataDeclaration{} = True
+acceptable P.ExternInstanceDeclaration{} = True
+acceptable P.TypeClassDeclaration{} = True
+acceptable P.TypeInstanceDeclaration{} = True
 acceptable _ = False
 
 parseReplQuery' :: String -> Either String ReplQuery
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -26,7 +26,6 @@ import Language.PureScript.Names
 import Language.PureScript.Kinds
 import Language.PureScript.TypeClassDictionaries
 import Language.PureScript.Comments
-import Language.PureScript.CodeGen.JS.AST
 import Language.PureScript.Environment
 
 -- |
@@ -122,9 +121,9 @@ data Declaration
   --
   | BindingGroupDeclaration [(Ident, NameKind, Expr)]
   -- |
-  -- A foreign import declaration (type, name, optional inline Javascript, type)
+  -- A foreign import declaration (name, type)
   --
-  | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
+  | ExternDeclaration Ident Type
   -- |
   -- A data type foreign import (name, kind)
   --
@@ -255,7 +254,7 @@ data Expr
   --
   | StringLiteral String
   -- |
-  -- A character literal 
+  -- A character literal
   --
   | CharLiteral Char
   -- |
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
@@ -109,7 +109,7 @@ isExported (Just exps) decl = any (matches decl) exps
   where
   matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
   matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
-  matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
+  matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
   matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
   matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
   matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -387,7 +387,7 @@ accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder
 accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
   where
   forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
-  forDecls (ExternDeclaration _ _ _ ty) = f ty
+  forDecls (ExternDeclaration _ ty) = f ty
   forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
   forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
   forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
@@ -90,7 +90,7 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
     exportToPs (ValueRef ident) =
       case (moduleName, ident) `M.lookup` names env of
         Nothing -> error $ show ident ++ " has no type in exportToPs"
-        Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
+        Just (ty, Public, _) ->
           tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
         _ -> return ()
     exportToPs (TypeClassRef className) =
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
@@ -26,7 +26,6 @@ module Language.PureScript.CodeGen.JS
   ) where
 
 import Data.List ((\\), delete)
-import Data.Maybe (mapMaybe)
 import qualified Data.Traversable as T (traverse)
 
 import Control.Applicative
@@ -54,7 +53,7 @@ moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode)
 moduleToJs (Module coms mn imps exps foreigns decls) = do
   additional <- asks optionsAdditional
   jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
-  let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
+  let foreigns' = [] -- TODO: Update this. mapMaybe (\(_, js, _) -> js) foreigns
   jsDecls <- mapM bindToJs decls
   optimized <- T.traverse (T.traverse optimize) jsDecls
   let isModuleEmpty = null exps
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -198,7 +198,7 @@ findQualModules decls =
   fqValues (A.Var (Qualified (Just mn) _)) = [mn]
   fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
   fqValues _ = []
-  
+
   fqBinders :: A.Binder -> [ModuleName]
   fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
   fqBinders _ = []
@@ -215,8 +215,8 @@ importToCoreFn _ = Nothing
 -- Desugars foreign declarations from AST to CoreFn representation.
 --
 externToCoreFn :: A.Declaration -> Maybe ForeignDecl
-externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
-externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
+externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)
+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject)
 externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
 externToCoreFn _ = Nothing
 
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
@@ -14,7 +14,6 @@
 
 module Language.PureScript.CoreFn.Module where
 
-import Language.PureScript.CodeGen.JS.AST
 import Language.PureScript.Comments
 import Language.PureScript.CoreFn.Expr
 import Language.PureScript.Names
@@ -29,4 +28,4 @@ data Module a = Module
   , moduleDecls :: [Bind a]
   } deriving (Show)
 
-type ForeignDecl = (Ident, Maybe JS, Type)
+type ForeignDecl = (Ident, Type)
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
@@ -50,7 +50,7 @@ bindIdents (Rec names) = map fst names
 -- Extract the ident for a foreign declaration.
 --
 foreignIdent :: ForeignDecl -> Ident
-foreignIdent (name, _, _) = name
+foreignIdent = fst
 
 -- |
 -- Key type to use in graph
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
@@ -74,7 +74,7 @@ groupChildren (partitionEithers -> (children, toplevels)) =
 
 getDeclarationTitle :: P.Declaration -> Maybe String
 getDeclarationTitle (P.TypeDeclaration name _)               = Just (show name)
-getDeclarationTitle (P.ExternDeclaration _ name _ _)         = Just (show name)
+getDeclarationTitle (P.ExternDeclaration name _)             = Just (show name)
 getDeclarationTitle (P.DataDeclaration _ name _ _)           = Just (show name)
 getDeclarationTitle (P.ExternDataDeclaration name _)         = Just (show name)
 getDeclarationTitle (P.TypeSynonymDeclaration name _ _)      = Just (show name)
@@ -93,7 +93,7 @@ renderDeclaration (P.TypeDeclaration ident' ty) title =
   code = ident (show ident')
           <> sp <> syntax "::" <> sp
           <> renderType ty
-renderDeclaration (P.ExternDeclaration _ ident' _ ty) title =
+renderDeclaration (P.ExternDeclaration ident' ty) title =
   basicDeclaration title code
   where
   code = ident (show ident')
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -62,19 +62,6 @@ data Environment = Environment {
 initEnvironment :: Environment
 initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
 
--- |
--- The type of a foreign import
---
-data ForeignImportType
-  -- |
-  -- A regular foreign import
-  --
-  = ForeignImport
-  -- |
-  -- A foreign import which contains inline Javascript as a string literal
-  --
-  | InlineJavascript deriving (Show, Eq, Data, Typeable)
-
 -- |
 -- The visibility of a name in scope
 --
@@ -89,33 +76,19 @@ data NameVisibility
   | Defined deriving (Show, Eq)
 
 -- |
--- The kind of a name
+-- A flag for whether a name is for an private or public value - only public values will be
+-- included in a generated externs file.
 --
 data NameKind
   -- |
-  -- A value introduced as a binding in a module
-  --
-  = Value
-  -- |
-  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
-  --
-  | TypeClassAccessorImport
-  -- |
-  -- A foreign import
-  --
-  | Extern ForeignImportType
-  -- |
-  -- A local name introduced using a lambda abstraction, variable introduction or binder
-  --
-  | LocalVariable
-  -- |
-  -- A data constructor
+  -- A private value introduced as an artifact of code generation (class instances, class member
+  -- accessors, etc.)
   --
-  | DataConstructor
+  = Private
   -- |
-  -- A type class dictionary, generated during desugaring of type class declarations
+  -- A public value for a module member or foreing import declaration
   --
-  | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
+  | Public deriving (Show, Eq, Data, Typeable)
 
 -- |
 -- The kinds of a type
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
@@ -39,35 +39,35 @@ lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ li
   where
   moduleNames :: S.Set Ident
   moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
-  
+
   getDeclIdent :: Declaration -> Maybe Ident
   getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
   getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
-  getDeclIdent (ExternDeclaration _ ident _ _) = Just ident
+  getDeclIdent (ExternDeclaration ident _) = Just ident
   getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
   getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
   getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
   getDeclIdent _ = Nothing
 
   lintDeclaration :: Declaration -> m ()
-  lintDeclaration d = 
+  lintDeclaration d =
     let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def
     in tell (f d)
     where
     def s _ = (s, mempty)
-    
+
     stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
     stepE s (Abs (Left name) _) = bind s name
-    stepE s (Let ds' _) = 
+    stepE s (Let ds' _) =
       case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
         (s', es) -> (s', mconcat es)
     stepE s _ = (s, mempty)
-    
+
     stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
     stepB s (VarBinder name) = bind s name
     stepB s (NamedBinder name _) = bind s name
     stepB s _ = (s, mempty)
-    
+
     bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
     bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
-                | otherwise = (S.insert name s, mempty)
+                | otherwise = (S.insert name s, mempty)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -30,22 +30,21 @@ module Language.PureScript.Parser.Declarations (
 
 import Prelude hiding (lex)
 
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe (fromMaybe)
 import Data.Traversable (forM)
 
 import Control.Applicative
 import Control.Arrow ((+++))
 
-import Language.PureScript.Kinds
 import Language.PureScript.AST
 import Language.PureScript.Comments
+import Language.PureScript.Environment
+import Language.PureScript.Kinds
+import Language.PureScript.Names
 import Language.PureScript.Parser.Common
-import Language.PureScript.Parser.Types
 import Language.PureScript.Parser.Kinds
 import Language.PureScript.Parser.Lexer
-import Language.PureScript.Names
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.Environment
+import Language.PureScript.Parser.Types
 
 import qualified Language.PureScript.Parser.Common as C
 import qualified Text.Parsec as P
@@ -99,7 +98,7 @@ parseValueDeclaration = do
                                     <*> (indented *> equals *> parseValueWithWhereClause)
                                ))
        <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
-  return $ ValueDeclaration name Value binders value
+  return $ ValueDeclaration name Public binders value
   where
   parseValueWithWhereClause :: TokenParser Expr
   parseValueWithWhereClause = do
@@ -126,9 +125,8 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp
            tys <- P.many (indented *> noWildcards parseTypeAtom)
            return $ ExternInstanceDeclaration name deps className tys)
    <|> (do ident <- parseIdent
-           js <- P.optionMaybe (JSRaw <$> stringLiteral)
            ty <- indented *> doubleColon *> noWildcards parsePolyType
-           return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
+           return $ ExternDeclaration ident ty))
 
 parseAssociativity :: TokenParser Associativity
 parseAssociativity =
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
