summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-08 21:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-08 21:08:00 (GMT)
commit6c8fdde0e684041ce538996341dda01030d10c32 (patch)
tree05d8f29c41aaabb5f87724392dc38f2ece11a063
parent84230ac341d5716f1e64bac53d8676e9a7a82e97 (diff)
version 0.4.170.4.17
-rw-r--r--docgen/Main.hs11
-rw-r--r--prelude/prelude.purs84
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs2
-rw-r--r--src/Language/PureScript/Constants.hs9
-rw-r--r--src/Language/PureScript/Declarations.hs13
-rw-r--r--src/Language/PureScript/Environment.hs2
-rw-r--r--src/Language/PureScript/Optimizer.hs1
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs2
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs14
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs18
-rw-r--r--src/Language/PureScript/Pretty/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs3
-rw-r--r--src/Language/PureScript/Sugar/Names.hs18
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs71
-rw-r--r--src/Language/PureScript/TypeChecker.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs129
-rw-r--r--src/Language/PureScript/Types.hs2
19 files changed, 298 insertions, 107 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index f34f748..9fea026 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -92,7 +92,7 @@ isExported (Just exps) decl = any (matches decl) exps
matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
- matches (P.TypeClassDeclaration ident _ _) (P.TypeClassRef ident') = ident == ident'
+ matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
matches (P.PositionedDeclaration _ d) r = d `matches` r
matches _ _ = False
@@ -124,8 +124,11 @@ renderDeclaration n _ (P.ExternDataDeclaration name kind) =
renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
let typeName = P.runProperName name ++ " " ++ unwords args
atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
-renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do
- atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
+ let impliesText = case implies of
+ [] -> ""
+ is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
+ atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"
mapM_ (renderDeclaration (n + 2) exps) ds
renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
let constraintsText = case constraints of
@@ -142,7 +145,7 @@ getName (P.ExternDeclaration _ ident _ _) = show ident
getName (P.DataDeclaration name _ _) = P.runProperName name
getName (P.ExternDataDeclaration name _) = P.runProperName name
getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
-getName (P.TypeClassDeclaration name _ _) = P.runProperName name
+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
getName (P.PositionedDeclaration _ d) = getName d
getName _ = error "Invalid argument to getName"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index b867a23..f964109 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -8,7 +8,7 @@ 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
@@ -59,10 +59,12 @@ module Prelude where
infixl 4 <*>
- class Applicative f where
- pure :: forall a. a -> f a
+ class (Functor f) <= Apply f where
(<*>) :: forall a b. f (a -> b) -> f a -> f b
+ class (Apply f) <= Applicative f where
+ pure :: forall a. a -> f a
+
liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a
@@ -74,10 +76,14 @@ module Prelude where
infixl 1 >>=
- class Monad m where
- return :: forall a. a -> m a
+ class (Apply m) <= Bind m where
(>>=) :: forall a b. m a -> (a -> m b) -> m b
+ class (Applicative m, Bind m) <= Monad m
+
+ return :: forall m a. (Monad m) => a -> m a
+ return = pure
+
liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
liftM1 f a = do
a' <- a
@@ -187,12 +193,19 @@ module Prelude where
data Ordering = LT | GT | EQ
+ instance eqOrdering :: Eq Ordering where
+ (==) LT LT = true
+ (==) GT GT = true
+ (==) EQ EQ = true
+ (==) _ _ = false
+ (/=) x y = not (x == y)
+
instance showOrdering :: Show Ordering where
show LT = "LT"
show GT = "GT"
show EQ = "EQ"
- class Ord a where
+ class (Eq a) <= Ord a where
compare :: a -> a -> Ordering
infixl 4 <
@@ -332,13 +345,25 @@ module Prelude where
(||) = boolOr
not = boolNot
+ infixr 5 <>
+
+ class Semigroup a where
+ (<>) :: a -> a -> a
+
+ foreign import concatString
+ "function concatString(s1) {\
+ \ return function(s2) {\
+ \ return s1 + s2;\
+ \ };\
+ \}" :: String -> String -> String
+
+ instance semigroupString :: Semigroup String where
+ (<>) = concatString
+
infixr 5 ++
- foreign import (++) "function $plus$plus(s1) {\
- \ return function(s2) {\
- \ return s1 + s2;\
- \ };\
- \}" :: String -> String -> String
+ (++) :: forall s. (Semigroup s) => s -> s -> s
+ (++) = (<>)
module Data.Eq where
@@ -355,19 +380,19 @@ module Control.Monad.Eff where
foreign import data Eff :: # ! -> * -> *
- foreign import retEff "function retEff(a) {\
- \ return function() {\
- \ return a;\
- \ };\
- \}" :: forall e a. a -> Eff e a
-
- foreign import bindEff "function bindEff(a) {\
- \ return function(f) {\
- \ return function() {\
- \ return f(a())();\
- \ };\
+ foreign import returnE "function returnE(a) {\
+ \ return function() {\
+ \ return a;\
\ };\
- \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+ \}" :: forall e a. a -> Eff e a
+
+ foreign import bindE "function bindE(a) {\
+ \ return function(f) {\
+ \ return function() {\
+ \ return f(a())();\
+ \ };\
+ \ };\
+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
type Pure a = forall e. Eff e a
@@ -378,13 +403,16 @@ module Control.Monad.Eff where
instance functorEff :: Functor (Eff e) where
(<$>) = liftA1
- instance applicativeEff :: Applicative (Eff e) where
- pure = return
+ instance applyEff :: Apply (Eff e) where
(<*>) = ap
- instance monadEff :: Monad (Eff e) where
- return = retEff
- (>>=) = bindEff
+ instance applicativeEff :: Applicative (Eff e) where
+ pure = returnE
+
+ instance bindEff :: Bind (Eff e) where
+ (>>=) = bindE
+
+ instance monadEff :: Monad (Eff e)
foreign import untilE "function untilE(f) {\
\ return function() {\
diff --git a/purescript.cabal b/purescript.cabal
index 3143723..7737be8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.16
+version: 0.4.17
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index f562c89..52d0f7d 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -77,10 +77,12 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
exportToPs (TypeClassRef className) =
case Qualified (Just moduleName) className `M.lookup` typeClasses env of
Nothing -> error $ show className ++ " has no type class definition in exportToPs"
- Just (args, members) -> do
- tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]
+ Just (args, members, implies) -> do
+ let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
+ tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]
forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
+
exportToPs (TypeInstanceRef ident) = do
let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9040722..694542b 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -144,7 +144,7 @@ valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntim
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 _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
-- |
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 45c0ede..beca0fe 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -146,6 +146,9 @@ pokeSTArray = "pokeSTArray"
monadEffDictionary :: String
monadEffDictionary = "monadEff"
+bindEffDictionary :: String
+bindEffDictionary = "bindEff"
+
numNumber :: String
numNumber = "numNumber"
@@ -167,6 +170,9 @@ bitsNumber = "bitsNumber"
boolLikeBoolean :: String
boolLikeBoolean = "boolLikeBoolean"
+semigroupString :: String
+semigroupString = "semigroupString"
+
-- Main module
main :: String
@@ -177,6 +183,9 @@ main = "main"
_ps :: String
_ps = "_ps"
+__superclasses :: String
+__superclasses = "__superclasses"
+
-- Modules
prim :: String
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index e07671e..c662007 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -158,9 +158,9 @@ data Declaration
--
| ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)
-- |
- -- A type class declaration (name, argument, member declarations)
+ -- A type class declaration (name, argument, implies, member declarations)
--
- | TypeClassDeclaration ProperName [String] [Declaration]
+ | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]
-- |
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
@@ -329,10 +329,15 @@ data Value
-- |
-- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-- placeholders will be replaced with actual expressions representing type classes dictionaries which
- -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
+ -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
+ -- at superclass implementations when searching for a dictionary, the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
+ | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
+ -- |
+ -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
+ --
+ | SuperClassDictionary (Qualified ProperName) [Type]
-- |
-- A value with source position information
--
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 599e48f..d25ae77 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -53,7 +53,7 @@ data Environment = Environment {
-- |
-- Type classes
--
- , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])
+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])
} deriving (Show)
-- |
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
index e5de099..16d60dc 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -66,7 +66,6 @@ optimize opts | optionsNoOptimizations opts = id
, inlineOperator (C.$) $ \f x -> JSApp f [x]
, inlineOperator (C.#) $ \x f -> JSApp f [x]
, inlineOperator (C.!!) $ flip JSIndexer
- , inlineOperator (C.++) $ JSBinary Add
, inlineCommonOperators ])
untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 1cc17b9..10dddfe 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -110,6 +110,8 @@ inlineCommonOperators = applyAll
, binary C.eqBoolean (C.==) EqualTo
, binary C.eqBoolean (C./=) NotEqualTo
+ , binary C.semigroupString (C.++) Add
+
, binaryFunction C.bitsNumber C.shl ShiftLeft
, binaryFunction C.bitsNumber C.shr ShiftRight
, binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 1e3d9ed..3cdc6b5 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -74,10 +74,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
convert other = other
-- Check if an expression represents a monomorphic call to >>= for the Eff monad
- isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
isBind _ = False
-- Check if an expression represents a monomorphic call to return for the Eff monad
- isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
isReturn _ = False
-- Check if an expression represents the polymorphic >>= function
isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
@@ -101,11 +101,11 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
name == name' = True
isEffFunc _ _ = False
-- Check if an expression represents the Monad Eff dictionary
- isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True
- isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
- _ps == C._ps &&
- prop == C.monadEffDictionary = True
- isEffDict _ = False
+ isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True
+ isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
+ _ps == C._ps &&
+ prop == name = True
+ isEffDict _ _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 3ff4fec..eef5fd0 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -144,12 +144,17 @@ parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
reserved "class"
+ implies <- P.option [] $ do
+ indented
+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
+ reservedOp "<="
+ return implies
className <- indented *> properName
idents <- P.many (indented *> identifier)
members <- P.option [] . P.try $ do
indented *> reserved "where"
- mark (P.many (same *> parseTypeDeclaration))
- return $ TypeClassDeclaration className idents members
+ mark (P.many (same *> positioned parseTypeDeclaration))
+ return $ TypeClassDeclaration className idents implies members
parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
parseTypeInstanceDeclaration = do
@@ -164,14 +169,17 @@ parseTypeInstanceDeclaration = do
ty <- P.many (indented *> parseTypeAtom)
members <- P.option [] . P.try $ do
indented *> reserved "where"
- mark (P.many (same *> parseValueDeclaration))
+ mark (P.many (same *> positioned parseValueDeclaration))
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
+positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration
+positioned d = PositionedDeclaration <$> sourcePos <*> d
+
-- |
-- Parse a single declaration
--
parseDeclaration :: P.Parsec String ParseState Declaration
-parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
+parseDeclaration = positioned (P.choice
[ parseDataDeclaration
, parseTypeDeclaration
, parseTypeSynonymDeclaration
@@ -181,7 +189,7 @@ parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
, parseImportDeclaration
, parseTypeClassDeclaration
, parseTypeInstanceDeclaration
- ] P.<?> "declaration"
+ ]) P.<?> "declaration"
parseLocalDeclaration :: P.Parsec String ParseState Declaration
parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index b55f44c..b63c78c 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -39,7 +39,7 @@ typeLiterals = mkPattern match
match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
- match (Skolem s _) = Just $ 's' : show s
+ match (Skolem name s _) = Just $ name ++ show s
match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
match REmpty = Just "()"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 8202007..974bc71 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -73,7 +73,8 @@ literals = mkPattern' match
, withIndent $ prettyPrintMany prettyPrintDoNotationElement els
, currentIndent
]
- match (TypeClassDictionary _ _) = return "<<dict>>"
+ match (TypeClassDictionary _ _ _) = return "<<dict>>"
+ match (SuperClassDictionary _ _) = return "<<superclass dict>>"
match (TypedValue _ val _) = prettyPrintValue' val
match (PositionedValue _ val) = prettyPrintValue' val
match _ = mzero
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 9276de5..eaef1f7 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -185,6 +185,8 @@ renameInModule imports exports (Module mn decls exps) =
go (TypeSynonymDeclaration name ps ty) =
rethrow (strMsg ("Error in type synonym " ++ show name) <>) $
TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
+ go (TypeClassDeclaration className args implies ds) =
+ TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds
go (TypeInstanceDeclaration name cs cn ts ds) =
TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds
go (ExternInstanceDeclaration name cs cn ts) =
@@ -209,7 +211,7 @@ renameInModule imports exports (Module mn decls exps) =
bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
(,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
bindFunctionArgs pb other = return (pb, other)
-
+
bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
@@ -245,7 +247,7 @@ renameInModule imports exports (Module mn decls exps) =
updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)
updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)
updateType pos t = return (pos, t)
-
+
updateType' :: Data d => d -> Either ErrorStack d
updateType' = everywhereWithContextM' Nothing (mkS updateType)
@@ -301,9 +303,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
-- Add a declaration from a module to the global export environment
addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
- addDecl mn env (TypeClassDeclaration tcn _ ds) = do
+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
env' <- addTypeClass env mn tcn
- foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
+ foldM go env' ds
+ where
+ go env'' (TypeDeclaration name _) = addValue env'' mn name
+ go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d
+ go _ _ = error "Invalid declaration in TypeClassDeclaration"
addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
@@ -389,14 +395,14 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron
resolveImports env (Module currentModule decls _) =
foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
where
-
+
-- A Map from module name to the source position for the import, the list of imports from that
-- module (where Nothing indicates everything is to be imported), and optionally a qualified name
-- for the module
scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
- resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
resolveImport' imp (mn, (pos, explImports, impQual)) = do
modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
positioned $ resolveImport currentModule mn modExports imp impQual explImports
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index f02a063..e19bba0 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -27,6 +27,8 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.CodeGen.Common (identToJs)
+import qualified Language.PureScript.Constants as C
+
import Control.Applicative
import Control.Monad.State
import Control.Arrow (first, second)
@@ -34,7 +36,7 @@ import Data.Maybe (catMaybes)
import qualified Data.Map as M
-type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])
+type MemberMap = M.Map (ModuleName, ProperName) Declaration
type Desugar = StateT MemberMap (Either ErrorStack)
@@ -70,6 +72,14 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- instance fooArray :: (Foo a) => Foo [a] where
-- foo = map foo
--
+-- {- Superclasses -}
+--
+-- class (Foo a) <= Sub a where
+-- sub :: a
+--
+-- instance subString :: Sub String where
+-- sub = ""
+--
-- becomes
--
-- type Foo a = { foo :: a -> a }
@@ -84,11 +94,22 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- fooArray :: forall a. (Foo a) => Foo [a]
-- fooArray = { foo: map foo }
--
+-- {- Superclasses -}
+--
+-- ...
+--
+-- subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }
+-- subString _ = {
+-- __superclasses: {
+-- "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>
+-- }
+-- sub: ""
+-- }
+--
desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
-desugarDecl mn d@(TypeClassDeclaration name args members) = do
- let tys = map memberToNameAndType members
- modify (M.insert (mn, name) (args, tys))
- return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
+desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
+ modify (M.insert (mn, name) d)
+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
desugared <- lift $ desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
@@ -107,9 +128,15 @@ 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 (first identToProperty . memberToNameAndType) members, REmpty))
+typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration name args implies members =
+ let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)
+ | (index, (superclass, tyArgs)) <- zip [0..] implies
+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
+ , let fieldName = mkSuperclassDictionaryName superclass index
+ ], REmpty))
+
+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
@@ -120,13 +147,21 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
+mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
+mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index
+
+unit :: Type
+unit = TypeApp tyObject REmpty
+
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
+ (TypeClassDeclaration _ args implies tyDecls) <- lift $
+ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
+ M.lookup (qualify mn className) m
+ let instanceTys = map memberToNameAndType tyDecls
-- Replace the type arguments with the appropriate types in the member types
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
@@ -137,20 +172,26 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
-- 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))
+ let superclasses = ObjectLiteral
+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
+ , let fieldName = mkSuperclassDictionaryName superclass index
+ ]
+
+ let memberNames' = (C.__superclasses, superclasses) : memberNames
+ dictTy = foldl TypeApp (TypeConstructor className) tys
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
+ 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 :: [(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
+ memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
(ident, val) <- memberToNameAndValue tys' d
return (ident, PositionedValue pos val)
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 9a34cae..6fadcfc 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -73,10 +73,14 @@ addValue moduleName name ty nameKind = do
env <- getEnv
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })
-addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()
-addTypeClass moduleName pn args ds =
- let members = map (\(TypeDeclaration ident ty) -> (ident, ty)) ds in
- modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }
+addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
+addTypeClass moduleName pn args implies ds =
+ let members = map toPair ds in
+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
+ where
+ toPair (TypeDeclaration ident ty) = (ident, ty)
+ toPair (PositionedDeclaration _ d) = toPair d
+ toPair _ = error "Invalid declaration in TypeClassDeclaration"
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries =
@@ -186,8 +190,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _)
]
ds <- typeCheckAll mainModuleName currentModule rest
return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do
- addTypeClass moduleName pn args tys
+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do
+ addTypeClass moduleName pn args implies tys
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 7ec773e..e80cfab 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -116,7 +116,7 @@ unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintT
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
- unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()
+ unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()
unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
@@ -155,7 +155,7 @@ unifyRows r1 r2 =
unifyRows' row r others u'
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
- unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
+ unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
-- |
@@ -261,9 +261,9 @@ overTypes f = everywhere (mkT f)
replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
replaceTypeClassDictionaries mn = everywhereM' (mkM go)
where
- go (TypeClassDictionary constraint dicts) = do
+ go (TypeClassDictionary trySuperclasses constraint dicts) = do
env <- getEnv
- entails env mn dicts constraint
+ entails env mn dicts constraint trySuperclasses
go other = return other
-- |
@@ -283,13 +283,17 @@ data DictionaryValue
-- A dictionary which depends on other dictionaries
--
| DependentDictionaryValue (Qualified Ident) [DictionaryValue]
+ -- |
+ -- A subclass dictionary
+ --
+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
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 :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value
entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
where
sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
@@ -301,13 +305,16 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
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)
+ solve context' (className, tys) trySuperclasses =
+ let
+ dicts = go trySuperclasses className tys
+ in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of
+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ [_] -> return $ dictionaryValueToValue $ head dicts
+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
where
- go (className', tys') =
+ go trySuperclasses' className' tys' =
+ -- Look for regular type instances
[ mkDictionary (canonicalizeDictionary tcd) args
| tcd <- context'
-- Make sure the type class name matches the one we are trying to satisfy
@@ -315,14 +322,29 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
-- 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) ]
+ , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
+
+ -- Look for implementations via superclasses
+ [ SubclassDictionaryValue suDict superclass index
+ | trySuperclasses'
+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
+ -- Try each superclass
+ , (index, (superclass, suTyArgs)) <- zip [0..] implies
+ -- Make sure the type class name matches the superclass name
+ , className' == superclass
+ -- 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
+ , suDict <- go True subclassName args' ]
+
-- 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
+ dict <- mapM (uncurry (go True) . 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
@@ -334,12 +356,45 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
+ App (Accessor (show superclassName ++ "_" ++ show index)
+ (Accessor C.__superclasses (dictionaryValueToValue dict)))
+ (ObjectLiteral [])
-- 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
+ -- Apply a substitution to a type
+ applySubst :: [(String, Type)] -> Type -> Maybe Type
+ applySubst subst = everywhereM (mkM 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
+ -- to be an overlap of itself when obtained as a superclass of another class.
+ -- Observing that we probably don't want to select a superclass instance when an instance
+ -- is available directly, and that there is no way for a superclass instance to actually
+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
+ -- obtained as superclass instances if there are simpler instances available.
+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
+ [] -> ds
+ simple -> simple
+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
+ isSimpleDictionaryValue _ = True
+ -- |
+ -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
+ -- data constructors
+ --
+ dictTrace :: DictionaryValue -> DictionaryValue
+ dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
+ dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
+ dictTrace other = other
-- |
-- Check all values in a list pairwise match a predicate
@@ -355,7 +410,7 @@ pairwise p (x : xs) = all (p x) xs && pairwise p xs
unifiesWith :: Environment -> Type -> Type -> Bool
unifiesWith _ (TUnknown _) _ = True
unifiesWith _ _ (TUnknown _) = True
-unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True
+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
@@ -371,7 +426,7 @@ unifiesWith _ _ _ = False
-- and return a substitution from type variables to types which makes the type heads unify.
--
typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
-typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
@@ -405,7 +460,7 @@ skolemEscapeCheck root@TypedValue{} =
collectSkolems :: Type -> [SkolemScope]
collectSkolems = nub . everything (++) (mkQ [] collect)
where
- collect (Skolem _ scope) = [scope]
+ collect (Skolem _ _ scope) = [scope]
collect _ = []
go _ scos = ([], scos)
findBindingScope :: SkolemScope -> Maybe Value
@@ -454,7 +509,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
dicts <- getTypeClassDictionaries
(_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
- return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
+ return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- |
@@ -578,7 +633,7 @@ infer' (Var var) = do
case ty of
ConstrainedType constraints ty' -> do
dicts <- getTypeClassDictionaries
- return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
+ return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'
_ -> return $ TypedValue True (Var var) ty
infer' v@(Constructor c) = do
env <- getEnv
@@ -600,6 +655,9 @@ infer' (IfThenElse cond th el) = do
infer' (Let ds val) = do
(ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
return $ TypedValue True (Let ds' val') valTy
+infer' (SuperClassDictionary className tys) = do
+ dicts <- getTypeClassDictionaries
+ return $ TypeClassDictionary False (className, tys) dicts
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty
@@ -735,7 +793,18 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'
-- Skolemize a type variable by replacing its instances with fresh skolem constants
--
skolemize :: String -> Int -> SkolemScope -> Type -> Type
-skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)
+skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
+
+-- |
+-- This function has one purpose - to skolemize type variables appearing in a
+-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
+-- only example of scoped type variables.
+--
+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value
+skolemizeTypesInValue ident sko scope = everywhere (mkT go)
+ where
+ go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
+ go other = other
-- |
-- Introduce skolem scope at every occurence of a ForAll
@@ -766,7 +835,8 @@ check' val (ForAll ident ty _) = do
scope <- newSkolemScope
sko <- newSkolemConstant
let sk = skolemize ident sko scope ty
- val' <- check val sk
+ let skVal = skolemizeTypesInValue ident sko scope val
+ val' <- check skVal sk
return $ TypedValue True val' (ForAll ident ty (Just scope))
check' val t@(ConstrainedType constraints ty) = do
dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
@@ -812,6 +882,19 @@ check' v@(Var var) ty = do
case v' of
Nothing -> throwError . strMsg $ "Unable to check type subsumption"
Just v'' -> return $ TypedValue True v'' ty'
+check' (SuperClassDictionary className tys) _ = do
+ -- |
+ -- Here, we replace a placeholder for a superclass dictionary with a regular
+ -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
+ -- correct super instance dictionaries in scope, and these are not available when the type class
+ -- declaration gets desugared.
+ --
+ -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want
+ -- to consider superclass instances when searching for this dictionary - doing so might lead
+ -- to traversing a cycle in the instance graph.
+ --
+ dicts <- getTypeClassDictionaries
+ return $ TypeClassDictionary False (className, tys) dicts
check' (TypedValue checkType val ty1) ty2 = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty1
@@ -883,7 +966,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return []
go [] [] u@(TUnknown _) = do u =?= REmpty
return []
- go [] [] (Skolem _ _) | lax = return []
+ go [] [] (Skolem _ _ _) | lax = return []
go [] ((p, _): _) _ | lax = return []
| otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
@@ -944,7 +1027,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
- checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
+ checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
++ prettyPrintType fnTy
++ " to argument " ++ prettyPrintValue arg
@@ -987,7 +1070,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
_ <- subsumes' Nothing ty1 ty2
- return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)
+ return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)
subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
let
(ts1, r1') = rowToList r1
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index c314f36..0244c1f 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -66,7 +66,7 @@ data Type
-- |
-- A skolem constant
--
- | Skolem Int SkolemScope
+ | Skolem String Int SkolemScope
-- |
-- An empty row
--