summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-11 19:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-11 19:15:00 (GMT)
commitc0ea5d653b03b2cb45ecb3eeae60899e51847d41 (patch)
treea650f55a85c5ed7772794123ea1dbb2bd582ebe8
parenta09bc6d8dc8e4f8abaae75e60c5e1af321c2b250 (diff)
version 0.2.11.10.2.11.1
-rw-r--r--libraries/prelude/prelude.purs2
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs4
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs35
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs12
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs19
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs21
7 files changed, 52 insertions, 43 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index 4183cf2..8b1a0ae 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -275,7 +275,7 @@ module Eff where
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
index 957a8d3..dc868db 100644
--- 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
index 2fa9680..02ebf1c 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -73,7 +73,7 @@ literals = mkPattern' match
, 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 :: [JS] -> String
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
index 56c9ca0..0eae3a2 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -34,11 +34,14 @@ import qualified Text.Parsec.Pos as P
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 @@ matchOp moduleName op = do
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
index 140d7d8..0afabc9 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -95,6 +95,18 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
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
index a415f20..92d99bb 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -19,6 +19,7 @@ module Language.PureScript.TypeChecker.Synonyms (
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 Data.Generics.Extras
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
index b5bc04f..a69247c 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -44,6 +44,7 @@ import Control.Applicative
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 t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
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 r1 r2 =
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 :: (Functor m, MonadState CheckState m, MonadReader Subst
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 :: Qualified ProperName -> [Type] -> Subst Type
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"