summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-05-09 05:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-05-09 05:21:00 (GMT)
commit5241fc61c21072ba87d7ec68ab0e8116d444269b (patch)
treedc9f353fa8c858d7efb04b41cd40739884de832d
parent73e8826ca8c27be924b76331963fee3ab3d1464a (diff)
version 0.5.10.5.1
-rw-r--r--prelude/prelude.purs71
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/Environment.hs10
-rw-r--r--src/Language/PureScript/Parser/Common.hs10
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs4
-rw-r--r--src/Language/PureScript/Pretty/Common.hs9
-rw-r--r--src/Language/PureScript/Pretty/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs8
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