summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-04 00:09:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-04 00:09:00 (GMT)
commit079627cc268d7b88a75f4a4c71575c1d223f8a2d (patch)
tree014626765801bf2fbcfc0eb8a5d949a898d86b2d
parent8add88b45a08ae3543798f11efa8d8d94e50447a (diff)
version 0.4.150.4.15
-rw-r--r--prelude/prelude.purs27
-rw-r--r--psci/Main.hs7
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs42
4 files changed, 58 insertions, 20 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 23923a4..1669adf 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -60,8 +60,8 @@ module Prelude where
pure :: forall a. a -> f a
(<*>) :: forall a b. f (a -> b) -> f a -> f b
- instance functorFromApplicative :: (Applicative f) => Functor f where
- (<$>) f a = pure f <*> a
+ liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
+ liftA1 f a = pure f <*> a
infixl 3 <|>
@@ -75,12 +75,16 @@ module Prelude where
return :: forall a. a -> m a
(>>=) :: forall a b. m a -> (a -> m b) -> m b
- instance applicativeFromMonad :: (Monad m) => Applicative m where
- pure = return
- (<*>) f a = do
- f' <- f
- a' <- a
- return (f' a')
+ liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
+ liftM1 f a = do
+ a' <- a
+ return (f a')
+
+ ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
+ ap f a = do
+ f' <- f
+ a' <- a
+ return (f' a')
infixl 7 *
infixl 7 /
@@ -368,6 +372,13 @@ module Control.Monad.Eff where
\ return f();\
\}" :: forall a. Pure a -> a
+ instance functorEff :: Functor (Eff e) where
+ (<$>) = liftA1
+
+ instance applicativeEff :: Applicative (Eff e) where
+ pure = return
+ (<*>) = ap
+
instance monadEff :: Monad (Eff e) where
return = retEff
(>>=) = bindEff
diff --git a/psci/Main.hs b/psci/Main.hs
index 0480b05..4fd50e2 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -176,9 +176,10 @@ completion = completeWord Nothing " \t\n\r" findCompletions
getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident
getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident
where
- isExported = flip any exts $ \e -> case e of
- P.ValueRef ident' -> ident == ident'
- _ -> False
+ isExported = any exports exts
+ exports (P.ValueRef ident') = ident == ident'
+ exports (P.PositionedDeclarationRef _ r) = exports r
+ exports _ = False
getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
getDeclName _ _ = Nothing
names :: [P.Module] -> [String]
diff --git a/purescript.cabal b/purescript.cabal
index 4d022f7..a995ee2 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.14
+version: 0.4.15
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2e20855..a2cbf6a 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -267,14 +267,34 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
go other = return other
-- |
+-- A simplified representation of expressions which are used to represent type
+-- class dictionaries at runtime, which can be compared for equality
+--
+data DictionaryValue
+ -- |
+ -- A dictionary which is brought into scope by a local constraint
+ --
+ = LocalDictionaryValue (Qualified Ident)
+ -- |
+ -- A dictionary which is brought into scope by an instance declaration
+ --
+ | GlobalDictionaryValue (Qualified Ident)
+ -- |
+ -- A dictionary which depends on other dictionaries
+ --
+ | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
+ deriving (Show, 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 " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
- (dict : _) -> return dict
+ case nub (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
@@ -290,16 +310,21 @@ entails env moduleName context goal@(className, tys) = do
-- 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 [Value]]
+ 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 [Value] -> Value
- mkDictionary fnName Nothing = Var fnName
- mkDictionary fnName (Just []) = App (Var fnName) (ObjectLiteral [])
- mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
+ 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
@@ -985,3 +1010,4 @@ subsumes' val ty1 ty2 = do
return val
+