summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-07 18:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-07 18:07:00 (GMT)
commit9bb222fbb8deef49596dc954ec459b44adf89599 (patch)
treeff84d24937b77cd00e936d082d362bec1ee7cf69
parent185f7bf62d9482c2b1253e2fdd47510dca2aee62 (diff)
version 0.1.60.1.6
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs2
-rw-r--r--src/Language/PureScript/Declarations.hs1
-rw-r--r--src/Language/PureScript/Parser/Common.hs6
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs9
-rw-r--r--src/Language/PureScript/Parser/Values.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/TypeChecker.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs3
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)