summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-09 03:37:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-09 03:37:00 (GMT)
commit85982d2ed8507b6dca3739512ce18853dcb8f707 (patch)
treeb14b94f1b664382f3cb92db8bc43949b24409dfa
parent6c8fdde0e684041ce538996341dda01030d10c32 (diff)
version 0.4.17.10.4.17.1
-rw-r--r--prelude/prelude.purs14
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs6
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs77
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs15
6 files changed, 72 insertions, 44 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index f964109..7426306 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -15,16 +15,20 @@ module Prelude where
infixr 9 >>>
infixr 9 <<<
- class Category a where
- id :: forall t. a t t
+ class Semigroupoid a where
(<<<) :: forall b c d. a c d -> a b c -> a b d
- (>>>) :: forall a b c d. (Category a) => a b c -> a c d -> a b d
+ instance semigroupoidArr :: Semigroupoid (->) where
+ (<<<) f g x = f (g x)
+
+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
(>>>) f g = g <<< f
+ class (Semigroupoid a) <= Category a where
+ id :: forall t. a t t
+
instance categoryArr :: Category (->) where
id x = x
- (<<<) f g x = f (g x)
infixr 0 $
infixl 0 #
@@ -80,7 +84,7 @@ module Prelude 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
diff --git a/purescript.cabal b/purescript.cabal
index 7737be8..68ba2d3 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.17
+version: 0.4.17.1
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index eaef1f7..120f43e 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -41,10 +41,11 @@ type ExportEnvironment = M.Map ModuleName Exports
-- The exported declarations from a module.
--
data Exports = Exports
+ {
-- |
-- The types exported from each module
--
- { exportedTypes :: [(ProperName, [ProperName])]
+ exportedTypes :: [(ProperName, [ProperName])]
-- |
-- The classes exported from each module
--
@@ -59,10 +60,11 @@ data Exports = Exports
-- An imported environment for a particular module. This also contains the module's own members.
--
data ImportEnvironment = ImportEnvironment
+ {
-- |
-- Local names for types within a module mapped to to their qualified names
--
- { importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
+ importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
-- |
-- Local names for data constructors within a module mapped to to their qualified names
--
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index e19bba0..4390621 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -25,14 +25,18 @@ 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
import Control.Applicative
+import Control.Monad.Error
import Control.Monad.State
import Control.Arrow (first, second)
-import Data.Maybe (catMaybes)
+import Data.List ((\\))
+import Data.Monoid ((<>))
+import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Map as M
@@ -53,8 +57,7 @@ desugarModule (Module name decls (Just exps)) = do
return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = error "Exports should have been elaborated in name desugaring"
--- |
--- Desugar type class and type class instance declarations
+{- Desugar type class and type class instance declarations
--
-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
@@ -105,7 +108,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- }
-- sub: ""
-- }
---
+-}
desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
modify (M.insert (mn, name) d)
@@ -115,7 +118,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
return $ (Just $ TypeInstanceRef name, [d, dictDecl])
desugarDecl mn (PositionedDeclaration pos d) = do
- (dr, ds) <- desugarDecl mn d
+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
return (dr, map (PositionedDeclaration pos) ds)
desugarDecl _ other = return (Nothing, [other])
@@ -154,41 +157,55 @@ 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
+typeInstanceDictionaryDeclaration name mn deps className tys decls =
+ rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
m <- get
-- Lookup the type arguments and member types for the type class
(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
- -- 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 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'
- return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
+
+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
+ [] -> do
+
+ 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
+ -- 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 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'
+
+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
+
where
+ declName :: Declaration -> Maybe Ident
+ declName (PositionedDeclaration _ d) = declName d
+ declName (ValueDeclaration ident _ _ _ _) = Just ident
+ declName (TypeDeclaration ident _) = Just ident
+ declName _ = Nothing
+
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'
+ _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
let memberValue = typeInstanceDictionaryEntryValue d
return (ident, memberValue)
memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index f702557..86bc9a7 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -143,7 +143,7 @@ getEnv :: (Functor m, MonadState CheckState m) => m Environment
getEnv = checkEnv <$> get
-- |
--- Update the @Environment#
+-- Update the @Environment@
--
putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv env = modify (\s -> s { checkEnv = env })
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index e80cfab..adcafc1 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -45,8 +45,8 @@ import Data.List
import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
import qualified Data.Data as D
import Data.Generics
- (everythingWithContext, mkM, everywhereM, everything, mkT,
- something, everywhere, mkQ)
+ (everythingWithContext, mkM, everywhereM,
+ everything, mkT, something, everywhere, mkQ)
import Data.Generics.Extras
import Language.PureScript.Declarations
@@ -253,7 +253,12 @@ isTyped (name, value) = (name, (value, Nothing))
-- Map a function over type annotations appearing inside a value
--
overTypes :: (Type -> Type) -> Value -> Value
-overTypes f = everywhere (mkT f)
+overTypes f = everywhere (mkT g)
+ where
+ g :: Value -> Value
+ g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
+ g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
+ g other = other
-- |
-- Replace type class dictionary placeholders with inferred type class dictionaries
@@ -883,7 +888,7 @@ check' v@(Var var) ty = do
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
@@ -892,7 +897,7 @@ check' (SuperClassDictionary className tys) _ = do
-- 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