version 0.1.60.1.6

10 files changed, 38 insertions, 16 deletions

diff --git a/purescript.cabal b/purescript.cabal
index 795fa61..ef67e73 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.1.5
+version: 0.1.6
 cabal-version: >=1.8
 build-type: Simple
 license: MIT
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 2d5e069..d2ea0ff 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -25,11 +25,11 @@ import Language.PureScript.Pretty
 externToPs :: Environment -> Declaration -> Maybe String
 externToPs env (ValueDeclaration name _) = do
   (ty, _) <- M.lookup name $ names env
-  return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
-externToPs env (ExternDeclaration name ty) =
-  return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+  return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+externToPs env (ExternMemberDeclaration member name ty) =
+  return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
 externToPs env (ExternDataDeclaration name kind) =
-  return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind
+  return $ "foreign import data " ++ name ++ " :: " ++ prettyPrintKind kind
 externToPs env (TypeSynonymDeclaration name args ty) =
   return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
 externToPs _ _ = Nothing
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 97a72f4..1a25e13 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -36,6 +36,8 @@ import Language.PureScript.CodeGen.JS.AST as AST
 declToJs :: Declaration -> Maybe [JS]
 declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]
 declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
+declToJs (ExternMemberDeclaration member ident _) =
+  Just [JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))])]
 declToJs (DataDeclaration _ _ ctors) =
   Just $ flip map ctors $ \(ctor, maybeTy) ->
     case maybeTy of
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 2b580d1..23c57b0 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -35,5 +35,6 @@ data Declaration
   | TypeDeclaration Ident PolyType
   | ValueDeclaration Ident Value
   | ExternDeclaration Ident PolyType
+  | ExternMemberDeclaration String Ident PolyType
   | ExternDataDeclaration String Kind
   | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 8a26ed7..729b9bb 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -44,7 +44,9 @@ reservedNames = [ "case"
                 , "return"
                 , "true"
                 , "false"
-                , "extern"
+                , "foreign"
+                , "import"
+                , "member"
                 , "forall"
                 , "do"
                 , "until"
@@ -74,7 +76,7 @@ reservedNames = [ "case"
 
 reservedOpNames :: [String]
 reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
-                  , "==", "!=", "&", "^", "|", "&&", "||", "->" ]
+                  , "==", "!=", "&", "^", "|", "&&", "||", "->", "!" ]
 
 identStart :: P.Parsec String u Char
 identStart = P.lower <|> P.oneOf "_$"
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 282dc30..f32885d 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -63,10 +63,13 @@ parseValueDeclaration =
                    <*> parseValue
 
 parseExternDeclaration :: P.Parsec String ParseState Declaration
-parseExternDeclaration = P.try (reserved "extern") *> indented *>
-  (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
-                        <*> (lexeme (indented *> P.string "::") *> parseKind)
+parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
+   (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
+                             <*> (lexeme (indented *> P.string "::") *> parseKind)
    <|> ExternDeclaration <$> parseIdent
+                        <*> (lexeme (indented *> P.string "::") *> parsePolyType)
+   <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral)
+                        <*> (indented *> parseIdent)
                         <*> (lexeme (indented *> P.string "::") *> parsePolyType))
 
 parseAssociativity :: P.Parsec String ParseState Associativity
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 42df017..baa1007 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -125,7 +125,6 @@ parseValue = do
   where
   indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
   postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
-                  , P.try $ Indexer <$> (C.indented *> C.squares parseValue)
                   , P.try $ flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]
   postfixTable2 = [ P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]))
                   , P.try $ flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
@@ -137,6 +136,7 @@ parseValue = do
                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
               ] ++ customOperatorTable user ++
               [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
+              , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (flip Indexer)) AssocRight ]
               , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
                 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
               , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index d30c63e..83d3ea5 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -59,10 +59,10 @@ accessor = Pattern $ A.Kleisli match
   match (Accessor prop val) = Just (prop, val)
   match _ = Nothing
 
-indexer :: Pattern Value (String, Value)
+indexer :: Pattern Value (Value, Value)
 indexer = Pattern $ A.Kleisli match
   where
-  match (Indexer index val) = Just (prettyPrintValue index, val)
+  match (Indexer index val) = Just (index, val)
   match _ = Nothing
 
 objectUpdate :: Pattern Value ([String], Value)
@@ -109,11 +109,11 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
   operators :: OperatorTable Value String
   operators =
     OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
-                  , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
                   , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
                   , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]
                   , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
+                  , [ AssocR indexer (\index val -> val ++ " ! " ++ index) ]
                   , [ binary    LessThan             "<" ]
                   , [ binary    LessThanOrEqualTo    "<=" ]
                   , [ binary    GreaterThan          ">" ]
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 4ba1c27..79fe476 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -81,8 +81,21 @@ typeCheckAll (ExternDataDeclaration name kind : rest) = do
   guardWith (name ++ " is already defined") $ not $ M.member name (types env)
   putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
   typeCheckAll rest
+typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
+  rethrow (("Error in foreign import member declaration " ++ show name ++ ": ") ++) $ do
+    env <- getEnv
+    kind <- kindOf ty
+    guardWith "Expected kind *" $ kind == Star
+    case M.lookup name (names env) of
+      Just _ -> throwError $ show name ++ " is already defined"
+      Nothing -> case ty of
+        (PolyType _ (Function [_] _)) -> do
+          putEnv (env { names = M.insert name (ty, Extern) (names env)
+                      , members = M.insert name member (members env) })
+        _ -> throwError "Foreign member declarations must have function types, with an single argument."
+  typeCheckAll rest
 typeCheckAll (ExternDeclaration name ty : rest) = do
-  rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do
+  rethrow (("Error in foreign import declaration " ++ show name ++ ": ") ++) $ do
     env <- getEnv
     kind <- kindOf ty
     guardWith "Expected kind *" $ kind == Star
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 071d3a1..b296e25 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -37,10 +37,11 @@ data Environment = Environment
   , types :: M.Map String (Kind, TypeDeclarationKind)
   , dataConstructors :: M.Map String PolyType
   , typeSynonyms :: M.Map String ([String], Type)
+  , members :: M.Map Ident String
   }
 
 emptyEnvironment :: Environment
-emptyEnvironment = Environment M.empty M.empty M.empty M.empty
+emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
 
 newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)