@@ -25,14 +25,18 @@ import Language.PureScript.CodeGen.JS.AST
25import Language.PureScript.Sugar.CaseDeclarations
25import Language.PureScript.Sugar.CaseDeclarations
26import Language.PureScript.Environment
26import Language.PureScript.Environment
27import Language.PureScript.Errors
27import Language.PureScript.Errors
28+import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
28import Language.PureScript.CodeGen.Common (identToJs)
29import Language.PureScript.CodeGen.Common (identToJs)
30import qualified Language.PureScript.Constants as C
31import qualified Language.PureScript.Constants as C
32import Control.Applicative
33import Control.Applicative
34+import Control.Monad.Error
33import Control.Monad.State
35import Control.Monad.State
34import Control.Arrow (first, second)
36import Control.Arrow (first, second)
35−import Data.Maybe (catMaybes)
37+import Data.List ((\\))
38+import Data.Monoid ((<>))
39+import Data.Maybe (catMaybes, mapMaybe)
37import qualified Data.Map as M
41import qualified Data.Map as M
@@ -115,7 +119,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
115 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
119 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
116 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
120 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
117desugarDecl mn (PositionedDeclaration pos d) = do
121desugarDecl mn (PositionedDeclaration pos d) = do
118− (dr, ds) <- desugarDecl mn d
122+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
119 return (dr, map (PositionedDeclaration pos) ds)
123 return (dr, map (PositionedDeclaration pos) ds)
120desugarDecl _ other = return (Nothing, [other])
124desugarDecl _ other = return (Nothing, [other])
@@ -154,41 +158,55 @@ unit :: Type
154unit = TypeApp tyObject REmpty
158unit = TypeApp tyObject REmpty
156typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
160typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
157−typeInstanceDictionaryDeclaration name mn deps className tys decls = do
161+typeInstanceDictionaryDeclaration name mn deps className tys decls =
162+ rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
160 -- Lookup the type arguments and member types for the type class
165 -- Lookup the type arguments and member types for the type class
161 (TypeClassDeclaration _ args implies tyDecls) <- lift $
166 (TypeClassDeclaration _ args implies tyDecls) <- lift $
162 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
167 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
163 M.lookup (qualify mn className) m
168 M.lookup (qualify mn className) m
170+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
171+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
164− let instanceTys = map memberToNameAndType tyDecls
174+ let instanceTys = map memberToNameAndType tyDecls
166− -- Replace the type arguments with the appropriate types in the member types
176+ -- Replace the type arguments with the appropriate types in the member types
167− let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
177+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
168− -- Create values for the type instance members
178+ -- Create values for the type instance members
169− memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
179+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
170− -- Create the type of the dictionary
180+ -- Create the type of the dictionary
171− -- The type is an object type, but depending on type instance dependencies, may be constrained.
181+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
172− -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
182+ -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
173− -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
183+ -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
174− -- dependencies, we introduce an unnamed function parameter.
184+ -- dependencies, we introduce an unnamed function parameter.
175− let superclasses = ObjectLiteral
185+ let superclasses = ObjectLiteral
176− [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
186+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
177− | (index, (superclass, suTyArgs)) <- zip [0..] implies
187+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
178− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
188+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
179− , let fieldName = mkSuperclassDictionaryName superclass index
189+ , let fieldName = mkSuperclassDictionaryName superclass index
182− let memberNames' = (C.__superclasses, superclasses) : memberNames
192+ let memberNames' = (C.__superclasses, superclasses) : memberNames
183− dictTy = foldl TypeApp (TypeConstructor className) tys
193+ dictTy = foldl TypeApp (TypeConstructor className) tys
184− constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
194+ constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
185− dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
195+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
186− return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
197+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
201+ declName :: Declaration -> Maybe Ident
202+ declName (PositionedDeclaration _ d) = declName d
203+ declName (ValueDeclaration ident _ _ _ _) = Just ident
204+ declName (TypeDeclaration ident _) = Just ident
205+ declName _ = Nothing
189 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
207 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
190 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
208 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
191− _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'
209+ _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
192 let memberValue = typeInstanceDictionaryEntryValue d
210 let memberValue = typeInstanceDictionaryEntryValue d
193 return (ident, memberValue)
211 return (ident, memberValue)
194 memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
212 memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do