diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs --- a/libraries/prelude/prelude.purs +++ b/libraries/prelude/prelude.purs @@ -275,7 +275,7 @@ type Pure a = forall e. Eff e a - foreign import runPure :: forall a. Pure a -> a + foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a eff = { ret: retEff, bind: bindEff } diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.2.11 +version: 0.2.11.1 cabal-version: >=1.8 build-type: Simple license: MIT diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -73,7 +73,7 @@ , withIndent $ do jss <- forM sts prettyPrintJS' indentString <- currentIndent - return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss + return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss , return "\n" , currentIndent , return "}" @@ -194,7 +194,7 @@ prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do jss <- forM sts prettyPrintJS' indentString <- currentIndent - return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss + return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss prettyPrintJS' :: JS -> StateT PrinterState Maybe String prettyPrintJS' = A.runKleisli $ runPattern matchValue diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -34,11 +34,14 @@ import qualified Text.Parsec.Expr as P rebracket :: [Module] -> Either String [Module] -rebracket ms = forM ms $ \(Module name ds) -> do - m <- collectFixities (ModuleName name) ds - let opTable = customOperatorTable m - ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds - return $ Module name $ G.everywhere (G.mkT removeParens) ds' +rebracket = go M.empty [] + where + go _ rb [] = return . reverse $ rb + go m rb (Module name ds : ms) = do + m' <- M.union m <$> collectFixities m (ModuleName name) ds + let opTable = customOperatorTable m' + ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds + go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms removeParens :: Value -> Value removeParens (Parens val) = val @@ -85,16 +88,20 @@ ident <- parseOp guard (qualify moduleName ident == qualify moduleName op) -collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) -collectFixities = go M.empty - where - go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) - go m _ [] = return m - go m moduleName (FixityDeclaration fixity name : rest) = do - let qual = Qualified (Just moduleName) (Op name) +collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) +collectFixities m _ [] = return m +collectFixities m moduleName (FixityDeclaration fixity name : rest) = do + let qual = Qualified (Just moduleName) (Op name) + when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name) + collectFixities (M.insert qual fixity m) moduleName rest +collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do + let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ] + forM_ fs $ \(name, _) -> do + let qual = Qualified (Just moduleName) name when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name) - go (M.insert qual fixity m) moduleName rest - go m moduleName (_:ds) = go m moduleName ds + let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs) + collectFixities (M.union m' m) moduleName rest +collectFixities m moduleName (_:ds) = collectFixities m moduleName ds globalOp :: String -> Qualified Ident globalOp = Qualified Nothing . Op 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 @@ -95,6 +95,18 @@ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined" Just (k, _) -> return k +canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident) +canonicalize _ _ (Qualified (Just mn) i) = (mn, i) +canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of + Just (_, Alias mn' i') -> (mn', i') + _ -> (mn, i) + +canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName) +canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm) +canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of + Just (_, DataAlias mn' pn') -> (mn', pn') + _ -> (mn, nm) + data AnyUnifiable where AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -19,6 +19,7 @@ import Language.PureScript.Types import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType) import Data.Maybe (fromMaybe) import Data.Data @@ -27,22 +28,22 @@ import Control.Monad.Writer import Control.Monad.Error -buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type) -buildTypeSubstitution moduleName name n = go n [] +buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type) +buildTypeSubstitution env moduleName name n = go n [] where go :: Int -> [Type] -> Type -> Either String (Maybe Type) - go 0 args (TypeConstructor ctor) | qualify moduleName name == qualify moduleName ctor = return (Just $ SaturatedTypeSynonym ctor args) - go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name + go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args) + go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name go m args (TypeApp f arg) = go (m - 1) (arg:args) f go _ _ _ = return Nothing -saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d -saturateTypeSynonym moduleName name n = everywhereM' (mkM replace) +saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d +saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace) where - replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t + replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t -saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d -saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns +saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d +saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -44,6 +44,7 @@ import Control.Arrow (Arrow(..)) import qualified Data.Map as M +import Data.Function (on) instance Unifiable Type where unknown = TUnknown @@ -76,8 +77,6 @@ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () unifyTypes' (TUnknown u) t = replace u t unifyTypes' t (TUnknown u) = replace u t - unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) - | name1 == name2 = zipWithM_ unifyTypes args1 args2 unifyTypes' (SaturatedTypeSynonym name args) ty = do ty1 <- expandTypeSynonym name args ty1 `unifyTypes` ty @@ -141,17 +140,7 @@ unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "." typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool -typeConstructorsAreEqual env moduleName c1 c2 = - let - c1' = qualify moduleName c1 - c2' = qualify moduleName c2 - in - canonicalize env c1' == canonicalize env c2' - where - canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName) - canonicalize _ key = case key `M.lookup` types env of - Just (_, DataAlias mn' pn') -> (mn', pn') - _ -> key +typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type] typesOf moduleName vals = do @@ -242,8 +231,8 @@ replaceAllTypeSynonyms d = do env <- getEnv moduleName <- substCurrentModule <$> ask - let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env - either throwError return $ saturateAllTypeSynonyms moduleName syns d + let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env + either throwError return $ saturateAllTypeSynonyms env moduleName syns d desaturateAllTypeSynonyms :: (D.Data d) => d -> d desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym) @@ -255,7 +244,7 @@ expandTypeSynonym name args = do env <- getEnv moduleName <- substCurrentModule `fmap` ask - case M.lookup (qualify moduleName name) (typeSynonyms env) of + case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body Nothing -> error "Type synonym was not defined"