packages feed

purescript 0.1.7 → 0.1.8

raw patch · 22 files changed

+356/−218 lines, 22 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.1.7+version: 0.1.8 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript/CodeGen/Externs.hs view
@@ -17,19 +17,26 @@ ) where  import Data.List (intercalate)+import Data.Maybe (mapMaybe) import qualified Data.Map as M import Language.PureScript.Declarations import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty+import Language.PureScript.Names -externToPs :: Environment -> Declaration -> Maybe String-externToPs env (ValueDeclaration name _) = do-  (ty, _) <- M.lookup name $ names env-  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 $ "foreign import data " ++ name ++ " :: " ++ prettyPrintKind kind-externToPs env (TypeSynonymDeclaration name args ty) =-  return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty-externToPs _ _ = Nothing+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String+externToPs indent path env (ValueDeclaration name _) = do+  (ty, _) <- M.lookup (path, name) $ names env+  return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty+externToPs indent path env (DataDeclaration name _ _) = do+  (kind, _) <- M.lookup (path, name) $ types env+  return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind+externToPs indent path env (ExternMemberDeclaration member name ty) =+  return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty+externToPs indent path env (ExternDataDeclaration name kind) =+  return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind+externToPs indent path env (TypeSynonymDeclaration name args ty) =+  return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty+externToPs indent path env (ModuleDeclaration name decls) =+  return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)+externToPs _ _ _ _ = Nothing
src/Language/PureScript/CodeGen/JS.hs view
@@ -18,7 +18,7 @@ ) where  import Data.Char-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.List (intercalate) import qualified Control.Arrow as A import Control.Arrow ((<+>), second)@@ -33,76 +33,100 @@ import Language.PureScript.CodeGen.Monad 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-      Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])-      Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]-                  (JSBlock [JSReturn-                    (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)-                                     , ("value", JSVar (Ident "value")) ])])-declToJs _ = Nothing+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Maybe [JS]+declToJs mod mp (ValueDeclaration ident (Abs args ret)) =+  Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :+         maybe [] (return . setProperty (show ident) (JSVar ident)) mod+declToJs mod mp (ValueDeclaration ident val) =+  Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :+         maybe [] (return . setProperty (show ident) (JSVar ident)) mod+declToJs mod _ (ExternMemberDeclaration member ident _) =+  Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :+         maybe [] (return . setProperty (show ident) (JSVar ident)) mod+declToJs mod mp (DataDeclaration _ _ ctors) =+  Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->+    let+      ctorJs =+        case maybeTy of+          Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))+          Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]+                      (JSBlock [JSReturn+                        (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))+                                         , ("value", JSVar (Ident "value")) ])])+    in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod+declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) =+  Just $ [ JSVariableIntroduction (Ident name) Nothing+         , JSApp (JSFunction Nothing [Ident name]+                             (JSBlock (concat $ mapMaybe (declToJs (Just (Ident name)) (subModule mp pn)) decls)))+                 [JSAssignment (JSAssignVariable (Ident name) )+                               (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] +++         maybe [] (return . setProperty name (JSVar (Ident name))) mod+declToJs _ _ _ = Nothing -valueToJs :: Value -> JS-valueToJs (NumericLiteral n) = JSNumericLiteral n-valueToJs (StringLiteral s) = JSStringLiteral s-valueToJs (BooleanLiteral b) = JSBooleanLiteral b-valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)-valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)-valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]-valueToJs (Constructor name) = JSVar (Ident name)-valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []-valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))-valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)-valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)-valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)-valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)-valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])-valueToJs (Unary op val) = JSUnary op (valueToJs val)-valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)-valueToJs (Var ident) = JSVar ident-valueToJs (TypedValue val _) = valueToJs val+setProperty :: String -> JS -> Ident -> JS+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val -bindersToJs ::  [(Binder, Value)] -> JS -> Gen JS-bindersToJs binders val = do+valueToJs :: ModulePath -> Value -> JS+valueToJs _ (NumericLiteral n) = JSNumericLiteral n+valueToJs _ (StringLiteral s) = JSStringLiteral s+valueToJs _ (BooleanLiteral b) = JSBooleanLiteral b+valueToJs m (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m) xs)+valueToJs m (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m)) ps)+valueToJs m (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m o, JSObjectLiteral (map (second (valueToJs m)) ps)]+valueToJs m (Constructor name) = qualifiedToJS runProperName name+valueToJs m (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m) sts))) []+valueToJs m (Case value binders) = runGen (bindersToJs m binders (valueToJs m value))+valueToJs m (IfThenElse cond th el) = JSConditional (valueToJs m cond) (valueToJs m th) (valueToJs m el)+valueToJs m (Accessor prop val) = JSAccessor prop (valueToJs m val)+valueToJs m (Indexer index val) = JSIndexer (valueToJs m index) (valueToJs m val)+valueToJs m (App val args) = JSApp (valueToJs m val) (map (valueToJs m) args)+valueToJs m (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m val)])+valueToJs m (Unary op val) = JSUnary op (valueToJs m val)+valueToJs m (Binary op v1 v2) = JSBinary op (valueToJs m v1) (valueToJs m v2)+valueToJs m (Var ident) = qualifiedToJS identToJs ident+valueToJs m (TypedValue val _) = valueToJs m val++qualifiedToJS :: (a -> String) -> Qualified a -> JS+qualifiedToJS f (Qualified (ModulePath parts) a) = delimited (f a : reverse (map show parts))+  where+  delimited [part] = JSVar (Ident (part))+  delimited (part:parts) = JSAccessor part (delimited parts)++bindersToJs :: ModulePath -> [(Binder, Value)] -> JS -> Gen JS+bindersToJs m binders val = do   valName <- fresh-  jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder+  jss <- forM binders $ \(binder, result) -> binderToJs m valName [JSReturn (valueToJs m result)] binder   return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))                  [val] -binderToJs :: String -> [JS] -> Binder -> Gen [JS]-binderToJs varName done NullBinder = return done-binderToJs varName done (StringBinder str) =+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]+binderToJs _ varName done NullBinder = return done+binderToJs _ varName done (StringBinder str) =   return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]-binderToJs varName done (NumberBinder num) =+binderToJs _ varName done (NumberBinder num) =   return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]-binderToJs varName done (BooleanBinder True) =+binderToJs _ varName done (BooleanBinder True) =   return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]-binderToJs varName done (BooleanBinder False) =+binderToJs _ varName done (BooleanBinder False) =   return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]-binderToJs varName done (VarBinder ident) =-  return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)-binderToJs varName done (NullaryBinder ctor) =-  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing]-binderToJs varName done (UnaryBinder ctor b) = do+binderToJs _ varName done (VarBinder ident) =+  return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)+binderToJs m varName done (NullaryBinder ctor) =+  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]+binderToJs m varName done (UnaryBinder ctor b) = do   value <- fresh-  js <- binderToJs value done b-  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js)) Nothing]-binderToJs varName done (ObjectBinder bs) = go done bs+  js <- binderToJs m value done b+  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]+binderToJs m varName done (ObjectBinder bs) = go done bs   where   go :: [JS] -> [(String, Binder)] -> Gen [JS]   go done [] = return done   go done ((prop, binder):bs) = do     propVar <- fresh     done' <- go done bs-    js <- binderToJs propVar done' binder-    return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)-binderToJs varName done (ArrayBinder bs rest) = do+    js <- binderToJs m propVar done' binder+    return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)+binderToJs m varName done (ArrayBinder bs rest) = do   js <- go done rest 0 bs   return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]   where@@ -112,31 +136,31 @@   go done Nothing _ [] = return done   go done (Just binder) index [] = do     restVar <- fresh-    js <- binderToJs restVar done binder-    return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)+    js <- binderToJs m restVar done binder+    return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)   go done rest index (binder:bs) = do     elVar <- fresh     done' <- go done rest (index + 1) bs-    js <- binderToJs elVar done' binder-    return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js)-binderToJs varName done (NamedBinder ident binder) = do-  js <- binderToJs varName done binder-  return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)-binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder+    js <- binderToJs m elVar done' binder+    return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)+binderToJs m varName done (NamedBinder ident binder) = do+  js <- binderToJs m varName done binder+  return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder   where-  done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]+  done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing] -statementToJs :: Statement -> JS-statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)-statementToJs (Assignment target value) = JSAssignment target (valueToJs value)-statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))-statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))-statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]-statementToJs (If ifst) = ifToJs ifst+statementToJs :: ModulePath -> Statement -> JS+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]+statementToJs m (If ifst) = ifToJs ifst   where   ifToJs :: IfStatement -> JS-  ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (JSBlock (map statementToJs thens)) (fmap elseToJs elses)+  ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)   elseToJs :: ElseStatement -> JS-  elseToJs (Else sts) = JSBlock (map statementToJs sts)+  elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)   elseToJs (ElseIf ifst) = ifToJs ifst-statementToJs (Return value) = JSReturn (valueToJs value)+statementToJs m (Return value) = JSReturn (valueToJs m value)
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -36,10 +36,14 @@   | JSVar Ident   | JSConditional JS JS JS   | JSBlock [JS]-  | JSVariableIntroduction Ident JS-  | JSAssignment Ident JS+  | JSVariableIntroduction Ident (Maybe JS)+  | JSAssignment JSAssignment JS   | JSWhile JS JS   | JSFor Ident JS JS JS   | JSIfElse JS JS (Maybe JS)   | JSReturn JS   | JSThrow JS deriving (Show, Data, Typeable)++data JSAssignment+  = JSAssignVariable Ident+  | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
src/Language/PureScript/Declarations.hs view
@@ -30,11 +30,12 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)  data Declaration-  = DataDeclaration String [String] [(String, Maybe Type)]-  | TypeSynonymDeclaration String [String] Type+  = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]+  | TypeSynonymDeclaration ProperName [String] Type   | 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)+  | ExternDataDeclaration ProperName Kind+  | FixityDeclaration Fixity String+  | ModuleDeclaration ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Names.hs view
@@ -17,6 +17,7 @@ module Language.PureScript.Names where  import Data.Data+import Data.List (intercalate)  data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable) @@ -24,3 +25,24 @@   show (Ident s) = s   show (Op op) = '(':op ++ ")" +newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)++instance Show ProperName where+  show = runProperName++data ModulePath = ModulePath [ProperName] deriving (Show, Eq, Ord, Data, Typeable)++subModule :: ModulePath -> ProperName -> ModulePath+subModule (ModulePath mp) name = ModulePath (mp ++ [name])++global :: ModulePath+global = ModulePath []++data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)++instance (Show a) => Show (Qualified a) where+  show (Qualified (ModulePath names) a) = intercalate ":" (map show names ++ [show a])++qualify :: ModulePath -> Qualified a -> (ModulePath, a)+qualify mp (Qualified (ModulePath []) a) = (mp, a)+qualify _ (Qualified mp a) = (mp, a)
src/Language/PureScript/Optimize.hs view
@@ -35,7 +35,7 @@ isReassigned var1 = everything (||) (mkQ False check)   where   check :: JS -> Bool-  check (JSAssignment var2 _) | var1 == var2 = True+  check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True   check _ = False  isUsed :: (Data d) => Ident -> d -> Bool@@ -43,8 +43,11 @@   where   check :: JS -> Bool   check (JSVar var2) | var1 == var2 = True-  check (JSAssignment var2 _) | var1 == var2 = True+  check (JSAssignment target _) | var1 == targetVariable target = True   check _ = False+  targetVariable :: JSAssignment -> Ident+  targetVariable (JSAssignVariable var) = var+  targetVariable (JSAssignProperty _ tgt) = targetVariable tgt  shouldInline :: JS -> Bool shouldInline (JSVar _) = True@@ -63,7 +66,7 @@   removeFromBlock js = js   go :: [JS] -> [JS]   go [] = []-  go (JSVariableIntroduction var js : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)+  go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)   go (s:sts) = s : go sts  removeUnusedVariables :: JS -> JS
src/Language/PureScript/Parser/Common.hs view
@@ -72,7 +72,8 @@                 , "String"                 , "Boolean"                 , "infixl"-                , "infixr" ]+                , "infixr"+                , "module" ]  reservedOpNames :: [String] reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"@@ -133,8 +134,16 @@ tick :: P.Parsec String u Char tick = lexeme $ P.char '`' -properName :: P.Parsec String u String-properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")+properName :: P.Parsec String u ProperName+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")++parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)+parseQualified parser = part global+  where+  part path = (do name <- P.try (properName <* delimiter)+                  part (subModule path name))+              <|> (Qualified path <$> P.try parser)+  delimiter = indented *> colon <* P.notFollowedBy colon  integerOrFloat :: P.Parsec String u (Either Integer Double) integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
src/Language/PureScript/Parser/Declarations.hs view
@@ -90,6 +90,15 @@   P.modifyState $ \st -> st { fixities = M.insert name fixity current }   return $ FixityDeclaration fixity name +parseModuleDeclaration :: P.Parsec String ParseState Declaration+parseModuleDeclaration = do+  reserved "module"+  indented+  name <- properName+  lexeme $ P.string "where"+  decls <- mark (P.many (same *> parseDeclaration))+  return $ ModuleDeclaration name decls+ parseDeclaration :: P.Parsec String ParseState Declaration parseDeclaration = P.choice                    [ parseDataDeclaration@@ -97,7 +106,8 @@                    , parseTypeSynonymDeclaration                    , parseValueDeclaration                    , parseExternDeclaration-                   , parseFixityDeclaration ] P.<?> "declaration"+                   , parseFixityDeclaration+                   , parseModuleDeclaration ] P.<?> "declaration"  parseDeclarations :: P.Parsec String ParseState [Declaration]-parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof+parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof
src/Language/PureScript/Parser/Types.hs view
@@ -52,7 +52,7 @@ parseTypeVariable = TypeVar <$> identifier  parseTypeConstructor :: P.Parsec String ParseState Type-parseTypeConstructor = TypeConstructor <$> properName+parseTypeConstructor = TypeConstructor <$> parseQualified properName  parseTypeAtom :: P.Parsec String ParseState Type parseTypeAtom = indented *> P.choice (map P.try
src/Language/PureScript/Parser/Values.hs view
@@ -59,20 +59,30 @@ parseAbs :: P.Parsec String ParseState Value parseAbs = do   C.lexeme $ P.char '\\'-  args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)+  args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))   C.lexeme $ C.indented *> P.string "->"   value <- parseValue-  return $ Abs args value+  return $ toFunction args value+  where+  manyArgs :: P.Parsec String ParseState (Value -> Value)+  manyArgs = do+    args <- C.parens ((C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma))+    return $ Abs args+  singleArg :: P.Parsec String ParseState (Value -> Value)+  singleArg = Abs . return <$> C.parseIdent+  toFunction :: [Value -> Value] -> Value -> Value+  toFunction [] value = Abs [] value+  toFunction args value = foldr (($)) value args  parseApp :: P.Parsec String ParseState Value parseApp = App <$> parseValue                <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))  parseVar :: P.Parsec String ParseState Value-parseVar = Var <$> C.parseIdent+parseVar = Var <$> C.parseQualified C.parseIdent  parseConstructor :: P.Parsec String ParseState Value-parseConstructor = Constructor <$> C.properName+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@@ -102,8 +112,8 @@             , parseArrayLiteral             , parseObjectLiteral             , parseAbs-            , P.try parseVar             , P.try parseConstructor+            , P.try parseVar             , parseBlock             , parseCase             , parseIfThenElse@@ -135,7 +145,7 @@                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)                 , 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.parseQualified 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 ]@@ -171,7 +181,7 @@         C.lexeme $ P.try $ do           C.indented           C.reservedOp name P.<?> "operator"-          return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2])+          return $ \t1 t2 -> App (App (Var (Qualified global (Op name))) [t1]) [t2])       levels  toAssoc :: Associativity -> Assoc@@ -247,10 +257,10 @@ parseVarBinder = VarBinder <$> C.parseIdent  parseNullaryBinder :: P.Parsec String ParseState Binder-parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)  parseUnaryBinder :: P.Parsec String ParseState Binder-parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)+parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)  parseObjectBinder :: P.Parsec String ParseState Binder parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
src/Language/PureScript/Pretty/JS.hs view
@@ -37,8 +37,8 @@   match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"   match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"   match (JSVar ident) = Just (identToJs ident)-  match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value-  match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value+  match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value+  match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value   match (JSWhile cond sts) = Just $ "while ("     ++ prettyPrintJS cond ++ ") "     ++ prettyPrintJS sts@@ -55,6 +55,10 @@   match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value   match _ = Nothing +targetToJs :: JSAssignment -> String+targetToJs (JSAssignVariable ident) = identToJs ident+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop+ conditional :: Pattern JS ((JS, JS), JS) conditional = Pattern $ A.Kleisli match   where@@ -115,7 +119,7 @@                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]                   , [ Wrap lam $ \(name, args) ret -> "function "                         ++ maybe "" identToJs name-                        ++ "(" ++ intercalate "," (map identToJs args) ++ ") "+                        ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "                         ++ ret ]                   , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]                   , [ binary    LessThan             "<" ]
src/Language/PureScript/Pretty/Types.hs view
@@ -41,9 +41,9 @@   match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"   match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"   match (TypeVar var) = Just var-  match (TypeConstructor ctor) = Just ctor+  match (TypeConstructor ctor) = Just $ show ctor   match (TUnknown u) = Just $ 'u' : show u-  match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"+  match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"   match _ = Nothing  prettyPrintRow :: Row -> String
src/Language/PureScript/Pretty/Values.hs view
@@ -38,7 +38,7 @@   match (BooleanLiteral False) = Just "false"   match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"   match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"-  match (Constructor name) = Just name+  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 (Var ident) = Just $ show ident@@ -146,8 +146,8 @@ prettyPrintBinder (BooleanBinder True) = "true" prettyPrintBinder (BooleanBinder False) = "false" prettyPrintBinder (VarBinder ident) = show ident-prettyPrintBinder (NullaryBinder ctor) = ctor-prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b+prettyPrintBinder (NullaryBinder ctor) = show ctor+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ prettyPrintBinder b prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }" prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]" prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
src/Language/PureScript/TypeChecker.hs view
@@ -42,27 +42,29 @@ typeCheckAll :: [Declaration] -> Check () typeCheckAll [] = return () typeCheckAll (DataDeclaration name args dctors : rest) = do-  rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do+  rethrow (("Error in type constructor " ++ show name ++ ": ") ++) $ do     env <- getEnv-    guardWith (name ++ " is already defined") $ not $ M.member name (types env)+    modulePath <- checkModulePath `fmap` get+    guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)     ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)-    putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }+    putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }     forM_ dctors $ \(dctor, maybeTy) ->-      rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do+      rethrow (("Error in data constructor " ++ show name ++ ": ") ++) $ do         env' <- getEnv-        guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')-        let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)+        guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')+        let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)         let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy         let polyType = PolyType args dctorTy-        putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }+        putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }   typeCheckAll rest typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do-  rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do+  rethrow (("Error in type synonym " ++ show name ++ ": ") ++) $ do     env <- getEnv-    guardWith (name ++ " is already defined") $ not $ M.member name (types env)+    modulePath <- checkModulePath `fmap` get+    guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)     kind <- kindsOf (Just name) args [ty]-    putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)-                 , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }+    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)@@ -70,40 +72,48 @@ typeCheckAll (ValueDeclaration name val : rest) = do   rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do     env <- getEnv-    case M.lookup name (names env) of+    modulePath <- checkModulePath `fmap` get+    case M.lookup (modulePath, name) (names env) of       Just ty -> throwError $ show name ++ " is already defined"       Nothing -> do         ty <- typeOf name val-        putEnv (env { names = M.insert name (ty, Value) (names env) })+        putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })   typeCheckAll rest typeCheckAll (ExternDataDeclaration name kind : rest) = do   env <- getEnv-  guardWith (name ++ " is already defined") $ not $ M.member name (types env)-  putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }+  modulePath <- checkModulePath `fmap` get+  guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)+  putEnv $ env { types = M.insert (modulePath, 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+    modulePath <- checkModulePath `fmap` get     kind <- kindOf ty     guardWith "Expected kind *" $ kind == Star-    case M.lookup name (names env) of+    case M.lookup (modulePath, 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) })+          putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)+                      , members = M.insert (modulePath, 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 foreign import declaration " ++ show name ++ ": ") ++) $ do     env <- getEnv+    modulePath <- checkModulePath `fmap` get     kind <- kindOf ty     guardWith "Expected kind *" $ kind == Star-    case M.lookup name (names env) of+    case M.lookup (modulePath, name) (names env) of       Just _ -> throwError $ show name ++ " is already defined"-      Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })+      Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })   typeCheckAll rest typeCheckAll (FixityDeclaration _ name : rest) = do   typeCheckAll rest   env <- getEnv-  guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env+  modulePath <- checkModulePath `fmap` get+  guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env+typeCheckAll (ModuleDeclaration name decls : rest) = do+  withModule name $ typeCheckAll decls+  typeCheckAll rest
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -28,6 +28,7 @@  import Language.PureScript.Types import Language.PureScript.Kinds+import Language.PureScript.Names import Language.PureScript.Declarations import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty@@ -61,15 +62,15 @@ kindOf :: PolyType -> Check Kind kindOf (PolyType idents ty) = do   ns <- replicateM (length idents) fresh-  (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty+  (cs, n, m) <- kindConstraints Nothing (M.fromList (zip idents ns)) ty   solution <- solveKindConstraints cs emptyKindSolution   return $ starIfUnknown $ runKindSolution solution n -kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind+kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind kindsOf name args ts = do   tyCon <- fresh   nargs <- replicateM (length args) fresh-  (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts+  (cs, ns, m) <- kindConstraintsAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args nargs)) ts   let extraConstraints =         KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin         : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts@@ -81,61 +82,65 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k -kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)-kindConstraintsAll m [] = return ([], [], m)-kindConstraintsAll m (t:ts) = do-  (cs, n1, m') <- kindConstraints m t-  (cs', ns, m'') <- kindConstraintsAll m' ts+kindConstraintsAll :: Maybe (ProperName, Int) -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)+kindConstraintsAll _ m [] = return ([], [], m)+kindConstraintsAll name m (t:ts) = do+  (cs, n1, m') <- kindConstraints name m t+  (cs', ns, m'') <- kindConstraintsAll name m' ts   return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'') -kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)-kindConstraints m a@(Array t) = do+kindConstraints :: Maybe (ProperName, Int) -> M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)+kindConstraints name m a@(Array t) = do   me <- fresh-  (cs, n1, m') <- kindConstraints m t+  (cs, n1, m') <- kindConstraints name m t   return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')-kindConstraints m o@(Object row) = do+kindConstraints name m o@(Object row) = do   me <- fresh-  (cs, r, m') <- kindConstraintsForRow m row+  (cs, r, m') <- kindConstraintsForRow name m row   return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')-kindConstraints m f@(Function args ret) = do+kindConstraints name m f@(Function args ret) = do   me <- fresh-  (cs, ns, m') <- kindConstraintsAll m args-  (cs', retN, m'') <- kindConstraints m' ret+  (cs, ns, m') <- kindConstraintsAll name m args+  (cs', retN, m'') <- kindConstraints name m' ret   return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'')-kindConstraints m (TypeVar v) =+kindConstraints _ m (TypeVar v) =   case M.lookup v m of     Just u -> return ([], u, m)     Nothing -> throwError $ "Unbound type variable " ++ v-kindConstraints m c@(TypeConstructor v) = do+kindConstraints (Just (name, u)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = do   env <- getEnv   me <- fresh-  case M.lookup v m of-    Nothing -> case M.lookup v (types env) of-      Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"-      Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)-    Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)-kindConstraints m a@(TypeApp t1 t2) = do+  modulePath <- checkModulePath `fmap` get+  return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)+kindConstraints name m c@(TypeConstructor v) = do+  env <- getEnv   me <- fresh-  (cs1, n1, m1) <- kindConstraints m t1-  (cs2, n2, m2) <- kindConstraints m1 t2+  modulePath <- checkModulePath `fmap` get+  case M.lookup (qualify modulePath v) (types env) of+    Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"+    Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)+kindConstraints name m a@(TypeApp t1 t2) = do+  me <- fresh+  (cs1, n1, m1) <- kindConstraints name m t1+  (cs2, n2, m2) <- kindConstraints name m1 t2   return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)-kindConstraints m t = do+kindConstraints _ m t = do   me <- fresh   return ([KindConstraint me Star (TypeOrigin t)], me, m) -kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)-kindConstraintsForRow m r@(RowVar v) = do+kindConstraintsForRow :: Maybe (ProperName, Int) -> M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)+kindConstraintsForRow _ m r@(RowVar v) = do   me <- case M.lookup v m of     Just u -> return u     Nothing -> fresh   return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)-kindConstraintsForRow m r@REmpty = do+kindConstraintsForRow _ m r@REmpty = do   me <- fresh   return ([KindConstraint me Row (RowOrigin r)], me, m)-kindConstraintsForRow m r@(RCons _ ty row) = do+kindConstraintsForRow name m r@(RCons _ ty row) = do   me <- fresh-  (cs1, n1, m1) <- kindConstraints m ty-  (cs2, n2, m2) <- kindConstraintsForRow m1 row+  (cs1, n1, m1) <- kindConstraints name m ty+  (cs2, n2, m2) <- kindConstraintsForRow name m1 row   return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)  solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -33,32 +33,38 @@ data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show  data Environment = Environment-  { names :: M.Map Ident (PolyType, NameKind)-  , types :: M.Map String (Kind, TypeDeclarationKind)-  , dataConstructors :: M.Map String PolyType-  , typeSynonyms :: M.Map String ([String], Type)-  , members :: M.Map Ident String-  }+  { names :: M.Map (ModulePath, Ident) (PolyType, NameKind)+  , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)+  , dataConstructors :: M.Map (ModulePath, ProperName) PolyType+  , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)+  , members :: M.Map (ModulePath, Ident) String+  } deriving (Show)  emptyEnvironment :: Environment 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)+data CheckState = CheckState { checkEnv :: Environment+                             , checkNextVar :: Int+                             , checkModulePath :: ModulePath+                             } deriving (Show) +newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }+  deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)+ getEnv :: Check Environment-getEnv = fmap fst get+getEnv = fmap checkEnv get  putEnv :: Environment -> Check ()-putEnv env = fmap (first (const env)) get >>= put+putEnv env = modify (\s -> s { checkEnv = env })  fresh :: Check Int fresh = do-  (env, n) <- get-  put (env, n + 1)-  return n+  st <- get+  put $ st { checkNextVar = checkNextVar st + 1 }+  return $ checkNextVar st  check :: Check a -> Either String (a, Environment)-check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck+check = fmap (second checkEnv) . flip runStateT (CheckState emptyEnvironment 0 global) . unCheck  guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return ()@@ -66,3 +72,11 @@  rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e)++withModule :: ProperName -> Check a -> Check a+withModule name act = do+  original <- checkModulePath `fmap` get+  modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }+  a <- act+  modify $ \s -> s { checkModulePath = original }+  return a
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -21,6 +21,7 @@  import Language.PureScript.Types import Language.PureScript.Declarations+import Language.PureScript.Names  import Data.Maybe (fromMaybe) import Data.Data@@ -30,12 +31,12 @@ import Control.Monad.Error import qualified Data.Map as M -buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type) buildTypeSubstitution name n = go n []   where   go :: Int -> [Type] -> Type -> Either String (Maybe Type)   go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)-  go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name+  go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name   go n args (TypeApp f arg) = go (n - 1) (arg:args) f   go _ _ _ = return Nothing @@ -44,12 +45,12 @@   y <- f x   gmapM (everywhereM' f) y -saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d saturateTypeSynonym name n = everywhereM' (mkM replace)   where   replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t -saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
src/Language/PureScript/TypeChecker/Types.hs view
@@ -192,7 +192,7 @@ replaceAllTypeSynonyms :: (D.Data d) => d -> Check d replaceAllTypeSynonyms d = do   env <- getEnv-  let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env+  let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env   either throwError return $ saturateAllTypeSynonyms syns d  desaturateAllTypeSynonyms :: (D.Data d) => d -> d@@ -306,19 +306,25 @@   let (cs2, ns) = (concatMap fst &&& map snd) all   me <- fresh   return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)-typeConstraints m v@(Var var) =-  case M.lookup var m of-    Nothing -> do-      env <- getEnv-      case M.lookup var (names env) of-        Nothing -> throwError $ show var ++ " is undefined"-        Just (PolyType idents ty, _) -> do+typeConstraints m v@(Var var@(Qualified mp name)) = do+  case mp of+    ModulePath [] ->+      case M.lookup name m of+        Just u -> do           me <- fresh-          replaced <- replaceVarsWithUnknowns idents ty-          return ([TypeConstraint me replaced (ValueOrigin v)], me)-    Just u -> do-      me <- fresh-      return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)+          return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)+        Nothing -> lookupGlobal+    _ -> lookupGlobal+  where+  lookupGlobal = do+    env <- getEnv+    modulePath <- checkModulePath `fmap` get+    case M.lookup (qualify modulePath var) (names env) of+      Nothing -> throwError $ show var ++ " is undefined"+      Just (PolyType idents ty, _) -> do+        me <- fresh+        replaced <- replaceVarsWithUnknowns idents ty+        return ([TypeConstraint me replaced (ValueOrigin v)], me) typeConstraints m (Block ss) = do   ret <- fresh   (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss@@ -326,8 +332,9 @@   return (cs, ret) typeConstraints m v@(Constructor c) = do   env <- getEnv-  case M.lookup c (dataConstructors env) of-    Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"+  modulePath <- checkModulePath `fmap` get+  case M.lookup (qualify modulePath c) (dataConstructors env) of+    Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"     Just (PolyType idents ty) -> do       me <- fresh       replaced <- replaceVarsWithUnknowns idents ty@@ -394,21 +401,23 @@   return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me) typeConstraintsForBinder val b@(NullaryBinder ctor) = do   env <- getEnv-  case M.lookup ctor (dataConstructors env) of+  modulePath <- checkModulePath `fmap` get+  case M.lookup (qualify modulePath ctor) (dataConstructors env) of     Just (PolyType args ret) -> do       ret' <- replaceVarsWithUnknowns args ret       return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)-    _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"+    _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do   env <- getEnv-  case M.lookup ctor (dataConstructors env) of+  modulePath <- checkModulePath `fmap` get+  case M.lookup (qualify modulePath ctor) (dataConstructors env) of     Just (PolyType idents f@(Function [_] _)) -> do       obj <- fresh       (Function [ty] ret) <- replaceVarsWithUnknowns idents f       (cs, m1) <- typeConstraintsForBinder obj binder       return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)-    Just _ -> throwError $ ctor ++ " is not a unary constructor"-    _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"+    Just _ -> throwError $ show ctor ++ " is not a unary constructor"+    _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" typeConstraintsForBinder val b@(ObjectBinder props) = do   row <- fresh   rest <- fresh@@ -573,7 +582,8 @@   fmap concat $ zipWithM (unifyTypes o) args1 args2 unifyTypes o (SaturatedTypeSynonym name args) ty = do   env <- getEnv-  case M.lookup name (typeSynonyms env) of+  modulePath <- checkModulePath `fmap` get+  case M.lookup (qualify modulePath name) (typeSynonyms env) of     Just (synArgs, body) -> do       let m = M.fromList $ zip synArgs args       let replaced = replaceTypeVars m body@@ -591,7 +601,10 @@   cs2 <- unifyTypes o ret1 ret2   return $ cs1 ++ cs2 unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []-unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) = do+  modulePath <- checkModulePath `fmap` get+  guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)+  return [] unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do   cs1 <- unifyTypes o t1 t3   cs2 <- unifyTypes o t2 t4
src/Language/PureScript/Types.hs view
@@ -17,6 +17,7 @@ module Language.PureScript.Types where  import Data.Data+import Language.PureScript.Names  data Type   = TUnknown Int@@ -27,9 +28,9 @@   | Object Row   | Function [Type] Type   | TypeVar String-  | TypeConstructor String+  | TypeConstructor (Qualified ProperName)   | TypeApp Type Type-  | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)+  | SaturatedTypeSynonym (Qualified ProperName) [Type] deriving (Show, Eq, Data, Typeable)  data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/Values.hs view
@@ -61,10 +61,10 @@   | ObjectUpdate Value [(String, Value)]   | Abs [Ident] Value   | App Value [Value]-  | Var Ident+  | Var (Qualified Ident)   | IfThenElse Value Value Value   | Block [Statement]-  | Constructor String+  | Constructor (Qualified ProperName)   | Case Value [(Binder, Value)]   | TypedValue Value PolyType deriving (Show, Data, Typeable) @@ -89,8 +89,8 @@   | StringBinder String   | NumberBinder (Either Integer Double)   | VarBinder Ident-  | NullaryBinder String-  | UnaryBinder String Binder+  | NullaryBinder (Qualified ProperName)+  | UnaryBinder (Qualified ProperName) Binder   | ObjectBinder [(String, Binder)]   | ArrayBinder [Binder] (Maybe Binder)   | NamedBinder Ident Binder
src/Main.hs view
@@ -40,13 +40,13 @@           U.putStrLn typeError           exitFailure         Right (_, env) -> do-          let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs) $ decls+          let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs Nothing global) $ decls           case outputFile of             Just path -> U.writeFile path js             Nothing -> U.putStrLn js           case externsFile of             Nothing -> return ()-            Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls+            Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs 0 global env) decls           exitSuccess  inputFiles :: Term [FilePath]