summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-12-26 23:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-12-26 23:08:00 (GMT)
commit54641b0699750354c3726520d3d0dbc6c5a13242 (patch)
tree8939cee02345250d47a973f41bd6b8808dd31e9c
parentffeeca8afd412c527d80ce9b6d65299d859d34d0 (diff)
version 0.2.10.2.1
-rw-r--r--purescript.cabal15
-rw-r--r--src/Language/PureScript.hs8
-rw-r--r--src/Language/PureScript/CaseDeclarations.hs62
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs33
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs2
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs8
-rw-r--r--src/Language/PureScript/Declarations.hs2
-rw-r--r--src/Language/PureScript/Optimize.hs10
-rw-r--r--src/Language/PureScript/Parser/Common.hs4
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs10
-rw-r--r--src/Language/PureScript/Parser/Values.hs32
-rw-r--r--src/Language/PureScript/Pretty/Values.hs9
-rw-r--r--src/Language/PureScript/Scope.hs71
-rw-r--r--src/Language/PureScript/TypeChecker.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs44
-rw-r--r--src/Language/PureScript/Values.hs7
17 files changed, 256 insertions, 70 deletions
diff --git a/purescript.cabal b/purescript.cabal
index ef94abd..a7a8af8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.0
+version: 0.2.1
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -15,11 +15,12 @@ data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
- directory -any, filepath -any, mtl -any, parsec -any,
- syb -any, transformers -any, utf8-string -any
- exposed-modules: Data.Generics.Extras Language.PureScript
- Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
- Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
+ directory -any, filepath -any, mtl -any, parsec -any, syb -any,
+ transformers -any, utf8-string -any
+ exposed-modules: Language.PureScript.Scope Data.Generics.Extras
+ Language.PureScript Language.PureScript.CodeGen
+ Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
+ Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
Language.PureScript.Kinds Language.PureScript.Names
Language.PureScript.Operators Language.PureScript.Optimize
@@ -36,6 +37,7 @@ library
Language.PureScript.TypeChecker.Synonyms
Language.PureScript.TypeChecker.Types Language.PureScript.Types
Language.PureScript.Unknown Language.PureScript.Values Main
+ Language.PureScript.CaseDeclarations
exposed: True
buildable: True
hs-source-dirs: src
@@ -47,6 +49,7 @@ executable psc
main-is: Main.hs
buildable: True
hs-source-dirs: src
+ other-modules:
ghc-options: -Wall -O2 -fno-warn-unused-do-bind
test-suite tests
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 9a40e30..4df2b55 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -25,6 +25,7 @@ import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
import Language.PureScript.Optimize as P
import Language.PureScript.Operators as P
+import Language.PureScript.CaseDeclarations as P
import Data.List (intercalate)
import Data.Maybe (mapMaybe)
@@ -32,7 +33,8 @@ import Data.Maybe (mapMaybe)
compile :: [Declaration] -> Either String (String, String, Environment)
compile decls = do
bracketted <- rebracket decls
- (_, env) <- runCheck (typeCheckAll bracketted)
- let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted
- let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
+ desugared <- desugarCases bracketted
+ (_, env) <- runCheck (typeCheckAll desugared)
+ let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared
+ let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared
return (js, exts, env)
diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/CaseDeclarations.hs
new file mode 100644
index 0000000..b482c1d
--- /dev/null
+++ b/src/Language/PureScript/CaseDeclarations.hs
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CaseDeclarations
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CaseDeclarations (
+ desugarCases
+) where
+
+import Data.List (groupBy)
+import Control.Monad (join, unless)
+import Control.Monad.Error.Class
+
+import Language.PureScript.Names
+import Language.PureScript.Values
+import Language.PureScript.Declarations
+import Language.PureScript.Scope
+
+desugarCases :: [Declaration] -> Either String [Declaration]
+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
+
+inSameGroup :: Declaration -> Declaration -> Bool
+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
+inSameGroup _ _ = False
+
+toDecls :: [Declaration] -> Either String [Declaration]
+toDecls d@[ValueDeclaration _ [] Nothing _] = return d
+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
+ let tuples = map toTuple ds
+ unless (all ((== map length bs) . map length . fst) tuples) $
+ throwError $ "Argument list lengths differ in declaration " ++ show ident
+ return [makeCaseDeclaration ident tuples]
+toDecls ds = return ds
+
+toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
+toTuple _ = error "Not a value declaration"
+
+makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
+makeCaseDeclaration ident alternatives =
+ let
+ argPattern = map length . fst . head $ alternatives
+ args = take (sum argPattern) $ unusedNames (ident, alternatives)
+ vars = map (\arg -> Var (Qualified global arg)) args
+ binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
+ value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
+ in
+ ValueDeclaration ident [] Nothing value
+
+rearrange :: [Int] -> [a] -> [[a]]
+rearrange [] _ = []
+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)
+
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index b5bcc28..1375d85 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -24,7 +24,7 @@ import Language.PureScript.Pretty
import Language.PureScript.Names
externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
-externToPs indent path env (ValueDeclaration name _) = do
+externToPs indent path env (ValueDeclaration name _ _ _) = do
(ty, _) <- M.lookup (path, name) $ names env
return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
externToPs indent path env (DataDeclaration name _ _) = do
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index a3b0ec8..9fbbfe4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -20,11 +20,12 @@ module Language.PureScript.CodeGen.JS (
import Data.Maybe (mapMaybe)
import qualified Data.Map as M
import Control.Arrow (second)
-import Control.Monad (forM)
+import Control.Monad (replicateM, forM)
import Language.PureScript.TypeChecker (Environment, names)
import Language.PureScript.Values
import Language.PureScript.Names
+import Language.PureScript.Scope
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
@@ -32,10 +33,10 @@ import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.TypeChecker.Monad (NameKind(..))
declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
-declToJs curMod mp (ValueDeclaration ident (Abs args ret)) e =
+declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :
maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
-declToJs curMod mp (ValueDeclaration ident val) e =
+declToJs curMod mp (ValueDeclaration ident _ _ val) e =
Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
@@ -73,7 +74,7 @@ valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e))
valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
-valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value))
+valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
@@ -94,12 +95,21 @@ qualifiedToJS f (Qualified (ModulePath parts) a) =
delimited (part:parts') = JSAccessor part (delimited parts')
delimited _ = error "Invalid argument to delimited"
-bindersToJs :: ModulePath -> Environment -> [(Binder, Value)] -> JS -> Gen JS
-bindersToJs m e binders val = do
- valName <- fresh
- jss <- forM binders $ \(binder, result) -> binderToJs m e valName [JSReturn (valueToJs m e result)] binder
- return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
- [val]
+bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
+bindersToJs m e binders vals = do
+ setNextName $ firstUnusedName (binders, vals)
+ valNames <- replicateM (length vals) fresh
+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
+ return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+ vals
+ where
+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+ go _ done [] Nothing = return done
+ go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
+ go (v:vs) done' (b:bs) grd = do
+ done'' <- go vs done' bs grd
+ binderToJs m e v done'' b
+ go _ _ _ _ = error "Invalid arguments to bindersToJs"
binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]
binderToJs _ _ _ done NullBinder = return done
@@ -152,9 +162,6 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
-binderToJs m e varName done (GuardedBinder cond binder) = binderToJs m e varName done' binder
- where
- done' = [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
statementToJs :: ModulePath -> Environment -> Statement -> JS
statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 59d34b5..ee8ad50 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -47,3 +47,5 @@ data JS
data JSAssignment
= JSAssignVariable Ident
| JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
+
+
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 5cf876e..0ea9f5d 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -19,7 +19,7 @@ module Language.PureScript.CodeGen.Monad where
import Control.Monad.State
import Control.Applicative
-newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)
runGen :: Gen a -> a
runGen = flip evalState 0 . unGen
@@ -29,3 +29,9 @@ fresh = do
n <- get
modify (+ 1)
return $ '_' : show n
+
+getNextName :: Gen Int
+getNextName = get
+
+setNextName :: Int -> Gen ()
+setNextName = put
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 5457a73..21242d2 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -33,7 +33,7 @@ data Declaration
= DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
| TypeSynonymDeclaration ProperName [String] PolyType
| TypeDeclaration Ident PolyType
- | ValueDeclaration Ident Value
+ | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
| ExternDeclaration Ident PolyType
| ExternMemberDeclaration String Ident PolyType
| ExternDataDeclaration ProperName Kind
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index 537a1ae..b9e2790 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Optimize (
) where
import Data.Data
+import Data.Maybe (fromMaybe)
import Data.Generics
import Language.PureScript.Names
@@ -31,6 +32,12 @@ replaceIdent var1 js = everywhere (mkT replace)
replace (JSVar var2) | var1 == var2 = js
replace other = other
+replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
+replaceIdents vars = everywhere (mkT replace)
+ where
+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
+ replace other = other
+
isReassigned :: (Data d) => Ident -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
where
@@ -84,7 +91,8 @@ etaConvert :: JS -> JS
etaConvert = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
+ | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
convert js = js
unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 95326c1..c21fa56 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -74,10 +74,10 @@ reservedNames = [ "case"
builtInOperators :: [String]
builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
- , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ]
+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "->" ]
+reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
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 0345ce0..751d185 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -27,6 +27,7 @@ import Language.PureScript.Declarations
import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
+import Language.PureScript.Values
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
@@ -50,8 +51,13 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
- ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))
- <*> parseValue
+ ValueDeclaration <$> parseIdent
+ <*> P.many parseTopLevelBinder
+ <*> P.optionMaybe parseGuard
+ <*> ((lexeme (indented *> P.char '=')) *> parseValue)
+
+parseTopLevelBinder :: P.Parsec String ParseState [Binder]
+parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index f2e7ad4..465b5f2 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -14,7 +14,9 @@
module Language.PureScript.Parser.Values (
parseValue,
- parseBinder
+ parseGuard,
+ parseBinder,
+ parseBinderNoParens
) where
import Language.PureScript.Values
@@ -72,13 +74,14 @@ parseConstructor :: P.Parsec String ParseState Value
parseConstructor = Constructor <$> C.parseQualified C.properName
parseCase :: P.Parsec String ParseState Value
-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
-parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
- <*> parseValue
- P.<?> "case alternative"
+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
+parseCaseAlternative = (,,) <$> (return <$> parseBinder)
+ <*> P.optionMaybe parseGuard
+ <*> (C.lexeme (P.string "->") *> parseValue)
+ P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
@@ -263,6 +266,19 @@ parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expressio
where
operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
-parseGuardedBinder :: P.Parsec String ParseState Binder
-parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
+parseBinderNoParens :: P.Parsec String ParseState Binder
+parseBinderNoParens = P.choice (map P.try
+ [ parseNullBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseNamedBinder
+ , parseVarBinder
+ , parseNullaryBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , C.parens parseBinder ]) P.<?> "binder"
+
+parseGuard :: P.Parsec String ParseState Guard
+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index de6b030..f9c6d81 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -37,12 +37,14 @@ literals = mkPattern match
match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
match (Constructor name) = Just $ show name
match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
- match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
+ match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
+ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
match (Var ident) = Just $ show ident
match _ = Nothing
-prettyPrintCaseAlternative :: Binder -> Value -> String
-prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
+ (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
ifThenElse :: Pattern () Value ((Value, Value), Value)
ifThenElse = mkPattern match
@@ -158,7 +160,6 @@ prettyPrintBinderAtom = mkPattern match
match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
- match (GuardedBinder cond binder) = Just $ prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
match _ = Nothing
prettyPrintBinder :: Binder -> String
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
new file mode 100644
index 0000000..5b3e73b
--- /dev/null
+++ b/src/Language/PureScript/Scope.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Scope
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Scope (
+ usedNames,
+ unusedNames,
+ firstUnusedName
+) where
+
+import Data.Data
+import Data.List ((\\), nub)
+import Data.Generics (extQ, mkQ, everything)
+
+import Language.PureScript.Values
+import Language.PureScript.Names
+import Language.PureScript.CodeGen.JS.AST
+import Data.Maybe (mapMaybe)
+import Text.Read (readMaybe)
+
+usedNames :: (Data d) => d -> [Ident]
+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
+ where
+ namesV :: Value -> [Ident]
+ namesV (Abs args _) = args
+ namesV (Var (Qualified (ModulePath []) name)) = [name]
+ namesV _ = []
+ namesS :: Statement -> [Ident]
+ namesS (VariableIntroduction name _) = [name]
+ namesS (For name _ _ _) = [name]
+ namesS _ = []
+ namesB :: Binder -> [Ident]
+ namesB (VarBinder name) = [name]
+ namesB _ = []
+ namesJS :: JS -> [Ident]
+ namesJS (JSVar name) = [name]
+ namesJS (JSFunction (Just name) args _) = name : args
+ namesJS (JSFunction Nothing args _) = args
+ namesJS (JSVariableIntroduction name _) = [name]
+ namesJS (JSFor name _ _ _) = [name]
+ namesJS _ = []
+
+unusedNames :: (Data d) => d -> [Ident]
+unusedNames val =
+ let
+ allNames = usedNames val
+ varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
+ in
+ varNames \\ allNames
+
+firstUnusedName :: (Data d) => d -> Int
+firstUnusedName val =
+ let
+ allNames = usedNames val
+ varNames = mapMaybe toUnknown allNames
+ in
+ 1 + maximum (0 : varNames)
+ where
+ toUnknown :: Ident -> Maybe Int
+ toUnknown (Ident ('_' : s)) = readMaybe s
+ toUnknown _ = Nothing
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8a9e6da..85b48df 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -63,10 +63,10 @@ typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
, typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
typeCheckAll rest
-typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
- typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
+ typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)
typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
-typeCheckAll (ValueDeclaration name val : rest) = do
+typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do
rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
env <- getEnv
modulePath <- checkModulePath `fmap` get
@@ -76,6 +76,7 @@ typeCheckAll (ValueDeclaration name val : rest) = do
ty <- typeOf (Just name) val
putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
typeCheckAll rest
+typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
typeCheckAll (ExternDataDeclaration name kind : rest) = do
env <- getEnv
modulePath <- checkModulePath `fmap` get
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 15f1cad..c48804b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -331,10 +331,10 @@ infer' (Constructor c) = do
case M.lookup (qualify modulePath c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just ty -> replaceAllTypeSynonyms ty
-infer' (Case val binders) = do
- t1 <- infer val
+infer' (Case vals binders) = do
+ ts <- mapM infer vals
ret <- fresh
- checkBinders t1 ret binders
+ checkBinders ts ret binders
return ret
infer' (IfThenElse cond th el) = do
check cond Boolean
@@ -451,9 +451,12 @@ inferBinder val (UnaryBinder ctor binder) = do
modulePath <- checkModulePath <$> get
case M.lookup (qualify modulePath ctor) (dataConstructors env) of
Just ty -> do
- Function [obj] ret <- replaceAllVarsWithUnknowns ty
- val `subsumes` ret
- inferBinder obj binder
+ fn <- replaceAllVarsWithUnknowns ty
+ case fn of
+ Function [obj] ret -> do
+ val `subsumes` ret
+ inferBinder obj binder
+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
row <- fresh
@@ -483,21 +486,17 @@ inferBinder val (ConsBinder headBinder tailBinder) = do
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
-inferBinder _ _ = error "Invalid argument to inferBinder"
-inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)
-inferGuardedBinder val (GuardedBinder cond binder) = do
- m1 <- inferBinder val binder
- bindLocalVariables (M.toList m1) $ check cond Boolean
- return m1
-inferGuardedBinder val b = inferBinder val b
-
-checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()
+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
checkBinders _ _ [] = return ()
-checkBinders nval ret ((binder, val):bs) = do
- m1 <- inferGuardedBinder nval binder
- bindLocalVariables (M.toList m1) $ check val ret
- checkBinders nval ret bs
+checkBinders nvals ret ((binders, grd, val):bs) = do
+ m1 <- M.unions <$> zipWithM inferBinder nvals binders
+ bindLocalVariables (M.toList m1) $ do
+ check val ret
+ case grd of
+ Nothing -> return ()
+ Just g -> check g Boolean
+ checkBinders nvals ret bs
assignVariable :: Ident -> Subst ()
assignVariable name = do
@@ -618,9 +617,9 @@ check' (TypedValue val ty1) ty2 = do
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty1 `subsumes` ty2
check val ty1
-check' (Case val binders) ret = do
- t1 <- infer val
- checkBinders t1 ret binders
+check' (Case vals binders) ret = do
+ ts <- mapM infer vals
+ checkBinders ts ret binders
check' (IfThenElse cond th el) ty = do
check cond Boolean
check th ty
@@ -712,6 +711,7 @@ inferFunctionApplication (ForAll ident ty) args = do
replaced <- replaceVarWithUnknown ident ty
inferFunctionApplication replaced args
inferFunctionApplication u@(TUnknown _) args = do
+
ret <- fresh
args' <- mapM replaceAllVarsWithUnknowns args
u ~~ Function args' ret
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 108b733..1e57a74 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -21,6 +21,8 @@ import Language.PureScript.Names
import Data.Data
+type Guard = Value
+
data UnaryOperator
= Negate
| Not
@@ -67,7 +69,7 @@ data Value
| IfThenElse Value Value Value
| Block [Statement]
| Constructor (Qualified ProperName)
- | Case Value [(Binder, Value)]
+ | Case [Value] [([Binder], Maybe Guard, Value)]
| TypedValue Value PolyType deriving (Show, Data, Typeable)
data Statement
@@ -97,5 +99,4 @@ data Binder
| ObjectBinder [(String, Binder)]
| ArrayBinder [Binder]
| ConsBinder Binder Binder
- | NamedBinder Ident Binder
- | GuardedBinder Value Binder deriving (Show, Data, Typeable)
+ | NamedBinder Ident Binder deriving (Show, Data, Typeable)