version 0.5.10.5.1

10 files changed, 97 insertions, 31 deletions

diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 9001fbf..c7137fd 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -1,4 +1,28 @@
-module Prelude where
+module Prelude
+  ( flip
+  , const
+  , asTypeOf
+  , Semigroupoid, (<<<), (>>>)
+  , Category, id
+  , ($), (#)
+  , (:), cons
+  , Show, show
+  , Functor, (<$>)
+  , Apply, (<*>)
+  , Applicative, pure, liftA1
+  , Alternative, empty, (<|>)
+  , Bind, (>>=)
+  , Monad, return, liftM1, ap
+  , Num, (+), (-), (*), (/), (%)
+  , negate
+  , Eq, (==), (/=), refEq, refIneq
+  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
+  , Bits, (&), (|), (^), shl, shr, zshr, complement
+  , BoolLike, (&&), (||)
+  , not
+  , Semigroup, (<>), (++)
+  , Unit(..), unit
+  ) where
 
   flip :: forall a b c. (a -> b -> c) -> b -> a -> c
   flip f b a = f a b
@@ -56,6 +80,9 @@ module Prelude where
     \  return JSON.stringify(s);\
     \}" :: String -> String
 
+  instance showUnit :: Show Unit where
+    show (Unit {}) = "Unit {}"
+
   instance showString :: Show String where
     show = showStringImpl
 
@@ -184,6 +211,11 @@ module Prelude where
     (%) = numMod
     negate = numNegate
 
+  data Unit = Unit {}
+
+  unit :: Unit
+  unit = Unit {}
+
   infix 4 ==
   infix 4 /=
 
@@ -205,6 +237,10 @@ module Prelude where
     \  };\
     \}" :: forall a. a -> a -> Boolean
 
+  instance eqUnit :: Eq Unit where
+    (==) (Unit {}) (Unit {}) = true
+    (/=) (Unit {}) (Unit {}) = false
+
   instance eqString :: Eq String where
     (==) = refEq
     (/=) = refIneq
@@ -268,15 +304,35 @@ module Prelude where
     LT -> false
     _ -> true
 
-  foreign import numCompare
-    "function numCompare(n1) {\
+  foreign import unsafeCompare
+    "function unsafeCompare(n1) {\
     \  return function(n2) {\
     \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
     \  };\
-    \}" :: Number -> Number -> Ordering
-
+    \}" :: forall a. a -> a -> Ordering
+
+  instance ordUnit :: Ord Unit where
+    compare (Unit {}) (Unit {}) = EQ
+    
+  instance ordBoolean :: Ord Boolean where
+    compare false false = EQ
+    compare false true  = LT
+    compare true  true  = EQ
+    compare true  false = GT
+    
   instance ordNumber :: Ord Number where
-    compare = numCompare
+    compare = unsafeCompare
+    
+  instance ordString :: Ord String where
+    compare = unsafeCompare
+    
+  instance ordArray :: (Ord a) => Ord [a] where
+    compare [] [] = EQ
+    compare [] _ = LT
+    compare _ [] = GT
+    compare (x:xs) (y:ys) = case compare x y of
+      EQ -> compare xs ys
+      other -> other
 
   infixl 10 &
   infixl 10 |
@@ -381,6 +437,9 @@ module Prelude where
     \  };\
     \}" :: String -> String -> String
 
+  instance semigroupUnit :: Semigroup Unit where
+    (<>) (Unit {}) (Unit {}) = Unit {}
+
   instance semigroupString :: Semigroup String where
     (<>) = concatString
 
diff --git a/purescript.cabal b/purescript.cabal
index 316193c..9058539 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.5.0
+version: 0.5.1
 cabal-version: >=1.8
 build-type: Custom
 license: MIT
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index d25ae77..687128f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -73,11 +73,7 @@ data ForeignImportType
   -- |
   -- A foreign import which contains inline Javascript as a string literal
   --
-  | InlineJavascript
-  -- |
-  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
-  --
-  | TypeClassAccessorImport deriving (Show, Eq, Data, Typeable)
+  | InlineJavascript deriving (Show, Eq, Data, Typeable)
 
 -- |
 -- The kind of a name
@@ -88,6 +84,10 @@ data NameKind
   --
   = Value
   -- |
+  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
+  --
+  | TypeClassAccessorImport
+  -- |
   -- A foreign import
   --
   | Extern ForeignImportType
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index f9be3a1..481ccc2 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -54,6 +54,12 @@ reservedPsNames = [ "data"
                   ]
 
 -- |
+-- The characters allowed for use in operators
+--
+opChars :: [Char]
+opChars = ":!#$%&*+./<=>?@\\^|-~"
+
+-- |
 -- A list of reserved identifiers for types
 --
 reservedTypeNames :: [String]
@@ -82,13 +88,13 @@ identLetter = P.alphaNum <|> P.oneOf "_'"
 -- Valid first characters for an operator
 --
 opStart :: P.Parsec String u Char
-opStart = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
+opStart = P.oneOf opChars
 
 -- |
 -- Valid operators characters
 --
 opLetter :: P.Parsec String u Char
-opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
+opLetter = P.oneOf opChars
 
 -- |
 -- The PureScript language definition
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index eef5fd0..47b9e18 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -123,13 +123,13 @@ parseImportDeclaration = do
   where
   stdImport = do
     moduleName' <- moduleName
-    idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef
+    idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
     return $ ImportDeclaration moduleName' idents Nothing
   qualImport = do
     reserved "qualified"
     indented
     moduleName' <- moduleName
-    idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef
+    idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
     reserved "as"
     asQ <- moduleName
     return $ ImportDeclaration moduleName' idents (Just asQ)
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 5d9d151..014ba38 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Pretty.Common where
 
 import Control.Monad.State
 import Data.List (intercalate)
+import Language.PureScript.Parser.Common (reservedPsNames, opChars)
 
 -- |
 -- Wrap a string in parentheses
@@ -58,3 +59,11 @@ prettyPrintMany f xs = do
   ss <- mapM f xs
   indentString <- currentIndent
   return $ intercalate "\n" $ map (indentString ++) ss
+
+-- |
+-- Prints an object key, escaping reserved names.
+--
+prettyPrintObjectKey :: String -> String
+prettyPrintObjectKey s | s `elem` reservedPsNames = show s
+                       | head s `elem` opChars = show s
+                       | otherwise = s
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 65395f2..b044cf5 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -51,7 +51,7 @@ prettyPrintRow :: Type -> String
 prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
   where
   nameAndTypeToPs :: String -> Type -> String
-  nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
+  nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
   tailToPs :: Type -> String
   tailToPs REmpty = ""
   tailToPs other = " | " ++ prettyPrintType other
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 974bc71..ee0107d 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -215,12 +215,12 @@ matchConsBinder = mkPattern match'
 
 prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
 prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
-    [ return $ key ++ ": "
+    [ return $ prettyPrintObjectKey key ++ ": "
     , prettyPrintBinder' binder
     ]
 
 prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
 prettyPrintObjectProperty (key, value) = fmap concat $ sequence
-    [ return $ key ++ ": "
+    [ return $ prettyPrintObjectKey key ++ ": "
     , prettyPrintValue' value
     ]
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b627d0a..2f2e0c3 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -21,12 +21,10 @@ module Language.PureScript.Sugar.TypeClasses (
 import Language.PureScript.Declarations
 import Language.PureScript.Names
 import Language.PureScript.Types
-import Language.PureScript.CodeGen.JS.AST
 import Language.PureScript.Sugar.CaseDeclarations
 import Language.PureScript.Environment
 import Language.PureScript.Errors
 import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
-import Language.PureScript.CodeGen.Common (identToJs)
 
 import qualified Language.PureScript.Constants as C
 
@@ -143,9 +141,9 @@ typeClassDictionaryDeclaration name args implies members =
 
 typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
 typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
-  ExternDeclaration TypeClassAccessorImport ident
-    (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
-    (moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty)))
+  ValueDeclaration ident TypeClassAccessorImport [] Nothing $
+    TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
+    moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
 typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
   PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
 typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 04e4f1b..39213bf 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -348,7 +348,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
 	    -- Make sure the types unify with the types in the superclass implication
 	    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
 	    -- Finally, satisfy the subclass constraint
-	    , args' <- maybeToList $ mapM (applySubst subst . TypeVar) args
+	    , args' <- maybeToList $ mapM (flip lookup subst) args
 	    , suDict <- go True subclassName args' ]
 	
 	  -- Create dictionaries for subgoals which still need to be solved by calling go recursively
@@ -379,12 +379,6 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
 	    let grps = groupBy ((==) `on` fst) subst
 	    guard (all (pairwise (unifiesWith env) . map snd) grps)
 	    return $ map head grps
-	  -- Apply a substitution to a type
-	  applySubst :: [(String, Type)] -> Type -> Maybe Type
-	  applySubst subst = everywhereOnTypesM replace
-	    where
-	    replace (TypeVar v) = lookup v subst
-	    replace other = Just other
 	  -- Choose the simplest DictionaryValues from a list of candidates
 	  -- The reason for this function is as follows:
 	  -- When considering overlapping instances, we don't want to consider the same dictionary