summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-05 23:27:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-05 23:27:00 (GMT)
commit84230ac341d5716f1e64bac53d8676e9a7a82e97 (patch)
tree132009276d72ba7fcda1bc47fd3ccef547b2124b
parent3b37a19639785ed27756b1c4c7e750aff97da963 (diff)
version 0.4.160.4.16
-rw-r--r--prelude/prelude.purs3
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs19
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs2
-rw-r--r--src/Language/PureScript/Environment.hs6
-rw-r--r--src/Language/PureScript/Names.hs19
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs8
-rw-r--r--src/Language/PureScript/Parser/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs7
-rw-r--r--src/Language/PureScript/Pretty/Values.hs1
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs102
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs98
13 files changed, 130 insertions, 147 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 1669adf..b867a23 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -8,6 +8,9 @@ module Prelude where
on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = g x `f` g y
+
+ asTypeOf :: forall a. a -> a -> a
+ asTypeOf x _ = x
infixr 9 >>>
infixr 9 <<<
diff --git a/purescript.cabal b/purescript.cabal
index 6ad4336..3143723 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.15.1
+version: 0.4.16
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
index 288ba23..661ce59 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -32,7 +32,6 @@ identToJs :: Ident -> String
identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
identToJs (Ident name) = concatMap identCharToString name
identToJs (Op op) = concatMap identCharToString op
-identToJs (Escaped name) = name
-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
@@ -130,5 +129,12 @@ nameIsJsReserved name =
, "with"
, "yield" ]
+-- |
+-- Test if a string is a valid JS identifier (may return false negatives)
+--
+isIdent :: String -> Bool
+isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True
+isIdent _ = False
+
moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 6ccaabb..9040722 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -19,7 +19,8 @@ module Language.PureScript.CodeGen.JS (
module AST,
declToJs,
moduleToJs,
- wrapExportsContainer
+ wrapExportsContainer,
+ isIdent
) where
import Data.Maybe (fromMaybe, mapMaybe)
@@ -90,7 +91,7 @@ declToJs _ _ _ _ = Nothing
-- module.
--
exportToJs :: DeclarationRef -> [JS]
-exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)
+exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)
exportToJs (ValueRef name) = [export name]
exportToJs (TypeInstanceRef name) = [export name]
exportToJs _ = []
@@ -115,9 +116,12 @@ var = JSVar . identToJs
-- indexer is returned.
--
accessor :: Ident -> JS -> JS
-accessor (Ident name) | nameIsJsReserved name = JSIndexer (JSStringLiteral name)
+accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)
-accessor ident = JSAccessor (identToJs ident)
+
+accessorString :: String -> JS -> JS
+accessorString prop | isIdent prop = JSAccessor prop
+ | otherwise = JSIndexer (JSStringLiteral prop)
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
@@ -132,13 +136,14 @@ valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (
valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
-valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
+valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)
valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []
valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
valueToJs _ m _ (Var ident) = varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
+valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
@@ -198,7 +203,7 @@ runtimeTypeChecks arg ty =
let
(pairs, _) = rowToList row
in
- typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs
argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
argumentCheck _ _ = []
@@ -283,7 +288,7 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs
propVar <- fresh
done'' <- go done' bs'
js <- binderToJs m e propVar done'' binder
- return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)
+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
binderToJs m e varName done (ArrayBinder bs) = do
js <- go done 0 bs
return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index fd7034c..2111774 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -19,8 +19,6 @@ module Language.PureScript.CodeGen.JS.AST where
import Data.Data
-
-
-- |
-- Built-in unary operators
--
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 673a08d..599e48f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -102,11 +102,7 @@ data NameKind
-- |
-- A type class dictionary, generated during desugaring of type class declarations
--
- | TypeInstanceDictionaryValue
- -- |
- -- A type instance member, generated during desugaring of type class declarations
- --
- | TypeInstanceMember deriving (Show, Eq, Data, Typeable)
+ | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
-- |
-- The kinds of a type
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 3f87e12..a384266 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -19,7 +19,6 @@ module Language.PureScript.Names where
import Data.List
import Data.Data
-import Data.Function (on)
-- |
-- Names for value identifiers
@@ -32,27 +31,11 @@ data Ident
-- |
-- A symbolic name for an infix operator
--
- | Op String
- -- |
- -- An escaped name
- --
- | Escaped String deriving (Data, Typeable)
+ | Op String deriving (Eq, Ord, Data, Typeable)
instance Show Ident where
show (Ident s) = s
show (Op op) = '(':op ++ ")"
- show (Escaped s) = s
-
-instance Eq Ident where
- Ident s1 == Ident s2 = s1 == s2
- Op s1 == Op s2 = s1 == s2
- Escaped s1 == Escaped s2 = s1 == s2
- Ident s1 == Escaped s2 = s1 == s2
- Escaped s1 == Ident s2 = s1 == s2
- _ == _ = False
-
-instance Ord Ident where
- compare = compare `on` show
-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index af01730..3ff4fec 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -227,7 +227,7 @@ parseObjectLiteral :: P.Parsec String ParseState Value
parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
-parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
+parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)
<*> (C.indented *> parseValue)
parseAbs :: P.Parsec String ParseState Value
@@ -290,14 +290,14 @@ parseValueAtom = P.choice
parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
parsePropertyUpdate = do
- name <- C.lexeme C.identifier
+ name <- C.lexeme (C.identifier <|> C.stringLiteral)
_ <- C.lexeme $ C.indented *> P.char '='
value <- C.indented *> parseValue
return (name, value)
parseAccessor :: Value -> P.Parsec String ParseState Value
parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj
parseDo :: P.Parsec String ParseState Value
parseDo = do
@@ -372,7 +372,7 @@ parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> retu
parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
parseIdentifierAndBinder = do
- name <- C.lexeme C.identifier
+ name <- C.lexeme (C.identifier <|> C.stringLiteral)
_ <- C.lexeme $ C.indented *> P.char '='
binder <- C.indented *> parseBinder
return (name, binder)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index a3d2c70..76fab97 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -118,7 +118,7 @@ parsePolyType :: P.Parsec String ParseState Type
parsePolyType = parseAnyType
parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
-parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p
+parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p
parseRowEnding :: P.Parsec String ParseState Type
parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 47b353c..3ab0153 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Pretty.JS (
) where
import Language.PureScript.Pretty.Common
+import Language.PureScript.CodeGen.JS (isIdent)
import Language.PureScript.CodeGen.JS.AST
import Data.List
@@ -46,13 +47,17 @@ literals = mkPattern' match
match (JSObjectLiteral ps) = fmap concat $ sequence
[ return "{\n"
, withIndent $ do
- jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
indentString <- currentIndent
return $ intercalate ", \n" $ map (indentString ++) jss
, return "\n"
, currentIndent
, return "}"
]
+ where
+ objectPropertyToString :: String -> String
+ objectPropertyToString s | isIdent s = s
+ | otherwise = show s
match (JSBlock sts) = fmap concat $ sequence
[ return "{\n"
, withIndent $ prettyStatements sts
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index e7ea5c5..8202007 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -47,6 +47,7 @@ literals = mkPattern' match
match (ObjectLiteral ps) = fmap concat $ sequence
[ return "{\n"
, withIndent $ prettyPrintMany prettyPrintObjectProperty ps
+ , return "\n"
, currentIndent
, return "}"
]
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b836e5b..f02a063 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -15,8 +15,7 @@
-----------------------------------------------------------------------------
module Language.PureScript.Sugar.TypeClasses (
- desugarTypeClasses,
- mkDictionaryEntryName
+ desugarTypeClasses
) where
import Language.PureScript.Declarations
@@ -30,12 +29,12 @@ import Language.PureScript.CodeGen.Common (identToJs)
import Control.Applicative
import Control.Monad.State
-import Control.Arrow (second)
+import Control.Arrow (first, second)
import Data.Maybe (catMaybes)
import qualified Data.Map as M
-type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
+type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])
type Desugar = StateT MemberMap (Either ErrorStack)
@@ -65,10 +64,10 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- class Foo a where
-- foo :: a -> a
--
--- instance Foo String where
+-- instance fooString :: Foo String where
-- foo s = s ++ s
--
--- instance (Foo a) => Foo [a] where
+-- instance fooArray :: (Foo a) => Foo [a] where
-- foo = map foo
--
-- becomes
@@ -79,16 +78,11 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- \ return dict.foo;\
-- \}" :: forall a. (Foo a) => a -> a
--
--- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
+-- fooString :: {} -> Foo String
+-- fooString _ = { foo: \s -> s ++ s }
--
--- __Test_Foo_string :: {} -> Foo String
--- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
---
--- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a]
--- __Test_Foo_array_foo _1 = map (foo _1)
---
--- __Test_Foo_array :: forall a. Foo a -> Foo [a]
--- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
+-- fooArray :: forall a. (Foo a) => Foo [a]
+-- fooArray = { foo: map foo }
--
desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
desugarDecl mn d@(TypeClassDeclaration name args members) = do
@@ -97,27 +91,30 @@ desugarDecl mn d@(TypeClassDeclaration name args members) = do
return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
desugared <- lift $ desugarCases members
- entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
- return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])
+ return $ (Just $ TypeInstanceRef name, [d, dictDecl])
desugarDecl mn (PositionedDeclaration pos d) = do
(dr, ds) <- desugarDecl mn d
return (dr, map (PositionedDeclaration pos) ds)
desugarDecl _ other = return (Nothing, [other])
-memberToNameAndType :: Declaration -> (String, Type)
-memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
+memberToNameAndType :: Declaration -> (Ident, Type)
+memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
+identToProperty :: Ident -> String
+identToProperty (Ident name) = name
+identToProperty (Op op) = op
+
typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args members =
- TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty))
+ TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
- (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
+ (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
(quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
@@ -126,54 +123,39 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls = do
m <- get
+
+ -- Lookup the type arguments and member types for the type class
(args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right
$ M.lookup (qualify mn className) m
+
+ -- Replace the type arguments with the appropriate types in the member types
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
- let entryName = Escaped (show name)
- memberNames <- mapM (memberToNameAndValue memberTypes) decls
- return $ ValueDeclaration entryName TypeInstanceDictionaryValue [] Nothing
- (TypedValue True
- (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
- (quantify (if null deps then
- function unit (foldl TypeApp (TypeConstructor className) tys)
- else
- foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))
- )
+ -- Create values for the type instance members
+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
+ -- Create the type of the dictionary
+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
+ -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
+ -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
+ -- dependencies, we introduce an unnamed function parameter.
+ let dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty))
+ constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames) else ObjectLiteral memberNames
+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
where
unit :: Type
unit = TypeApp tyObject REmpty
- memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
- memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do
- memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'
- memberName <- mkDictionaryEntryName name ident
- return (identToJs ident, TypedValue False
- (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
- (quantify memberType))
+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
+ memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
+ _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'
+ let memberValue = typeInstanceDictionaryEntryValue d
+ return (ident, memberValue)
memberToNameAndValue tys' (PositionedDeclaration pos d) = do
(ident, val) <- memberToNameAndValue tys' d
return (ident, PositionedValue pos val)
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
-typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
-typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident _ [] _ val) = do
- m <- get
- valTy <- lift $ do (args, members) <- lookupTypeClass m
- ty' <- lookupIdent members
- return $ replaceAllTypeVars (zip args tys) ty'
- entryName <- mkDictionaryEntryName name ident
- return $ ValueDeclaration entryName TypeInstanceMember [] Nothing
- (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
- where
- lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m
- lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) Right $ lookup (identToJs ident) members
-typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =
- PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d
-typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
-
--- |
--- Generate a name for a type class dictionary member, based on the module name, class name, type name and
--- member name
---
-mkDictionaryEntryName :: Ident -> Ident -> Desugar Ident
-mkDictionaryEntryName dictName ident = return $ Escaped $ show dictName ++ "_" ++ identToJs ident
+ typeInstanceDictionaryEntryValue :: Declaration -> Value
+ typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
+ typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
+ typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index b0dd3b9..7ec773e 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -270,7 +270,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
-- A simplified representation of expressions which are used to represent type
-- class dictionaries at runtime, which can be compared for equality
--
-data DictionaryValue
+data DictionaryValue
-- |
-- A dictionary which is brought into scope by a local constraint
--
@@ -283,59 +283,63 @@ data DictionaryValue
-- A dictionary which depends on other dictionaries
--
| DependentDictionaryValue (Qualified Ident) [DictionaryValue]
- deriving (Show, Eq)
+ deriving (Show, Ord, Eq)
-- |
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
-entails env moduleName context goal@(className, tys) = do
- case go goal of
- [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
- [dict] -> return (dictionaryValueToValue dict)
- _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
where
- go (className', tys') =
- [ mkDictionary (canonicalizeDictionary tcd) args
- | tcd <- nubBy ((==) `on` canonicalizeDictionary) context
- -- Choose type class dictionaries in scope in the current module
- , filterModule tcd
- -- Make sure the type class name matches the one we are trying to satisfy
- , className' == tcdClassName tcd
- -- Make sure the type unifies with the type in the type instance definition
- , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
- -- Solve any necessary subgoals
- , args <- solveSubgoals subst (tcdDependencies tcd) ]
- -- Create dictionaries for subgoals which still need to be solved by calling go recursively
- -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
- -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
- solveSubgoals _ Nothing = return Nothing
- solveSubgoals subst (Just subgoals) = do
- dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals
- return $ Just dict
- -- Make a dictionary from subgoal dictionaries by applying the correct function
- mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
- mkDictionary fnName Nothing = LocalDictionaryValue fnName
- mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
- mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
- -- Turn a DictionaryValue into a Value
- dictionaryValueToValue :: DictionaryValue -> Value
- dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
- dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
- dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
- -- Filter out type dictionaries which are in scope in the current module
- filterModule :: TypeClassDictionaryInScope -> Bool
- filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
- filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
- filterModule _ = False
- -- Ensure that a substitution is valid
- verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
- verifySubstitution subst = do
- let grps = groupBy ((==) `on` fst) subst
- guard (all (pairwise (unifiesWith env) . map snd) grps)
- return $ map head grps
+ sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
+ sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
+
+ -- Filter out type dictionaries which are in scope in the current module
+ filterModule :: TypeClassDictionaryInScope -> Bool
+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
+ filterModule _ = False
+
+ solve context' goal@(className, tys) =
+ case go goal of
+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ [dict] -> return (dictionaryValueToValue dict)
+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ where
+ go (className', tys') =
+ [ mkDictionary (canonicalizeDictionary tcd) args
+ | tcd <- context'
+ -- Make sure the type class name matches the one we are trying to satisfy
+ , className' == tcdClassName tcd
+ -- Make sure the type unifies with the type in the type instance definition
+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
+ -- Solve any necessary subgoals
+ , args <- solveSubgoals subst (tcdDependencies tcd) ]
+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
+ solveSubgoals _ Nothing = return Nothing
+ solveSubgoals subst (Just subgoals) = do
+ dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals
+ return $ Just dict
+ -- Make a dictionary from subgoal dictionaries by applying the correct function
+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
+ -- Turn a DictionaryValue into a Value
+ dictionaryValueToValue :: DictionaryValue -> Value
+ dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
+ dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
+ dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
+ -- Ensure that a substitution is valid
+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
+ verifySubstitution subst = do
+ let grps = groupBy ((==) `on` fst) subst
+ guard (all (pairwise (unifiesWith env) . map snd) grps)
+ return $ map head grps
-- |
-- Check all values in a list pairwise match a predicate