packages feed

purescript 0.2.11 → 0.2.11.1

raw patch · 7 files changed

+52/−43 lines, 7 files

Files

libraries/prelude/prelude.purs view
@@ -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 }
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.11+version: 0.2.11.1 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript/Pretty/JS.hs view
@@ -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
src/Language/PureScript/Sugar/Operators.hs view
@@ -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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -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
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -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"