diff --git a/purescript.cabal b/purescript.cabal --- 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 --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -25,11 +25,11 @@ 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 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -36,6 +36,8 @@ 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 --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -35,5 +35,6 @@ | 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 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -44,7 +44,9 @@ , "return" , "true" , "false" - , "extern" + , "foreign" + , "import" + , "member" , "forall" , "do" , "until" @@ -74,7 +76,7 @@ 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 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -63,10 +63,13 @@ <*> 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 --- a/src/Language/PureScript/Parser/Values.hs +++ b/src/Language/PureScript/Parser/Values.hs @@ -125,7 +125,6 @@ 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 @@ , 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 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -59,10 +59,10 @@ 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 @@ 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 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -81,8 +81,21 @@ 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 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -37,10 +37,11 @@ , 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)