@@ -25,14 +25,18 @@ import Language.PureScript.CodeGen.JS.AST
2525import Language.PureScript.Sugar.CaseDeclarations
2626import Language.PureScript.Environment
2727import Language.PureScript.Errors
28+import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
2829import Language.PureScript.CodeGen.Common (identToJs)
2930
3031import qualified Language.PureScript.Constants as C
3132
3233import Control.Applicative
34+import Control.Monad.Error
3335import Control.Monad.State
3436import Control.Arrow (first, second)
35−import Data.Maybe (catMaybes)
37+import Data.List ((\\))
38+import Data.Monoid ((<>))
39+import Data.Maybe (catMaybes, mapMaybe)
3640
3741import qualified Data.Map as M
3842
@@ -115,7 +119,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
115119 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
116120 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
117121desugarDecl mn (PositionedDeclaration pos d) = do
118− (dr, ds) <- desugarDecl mn d
122+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
119123 return (dr, map (PositionedDeclaration pos) ds)
120124desugarDecl _ other = return (Nothing, [other])
121125
@@ -154,41 +158,55 @@ unit :: Type
154158unit = TypeApp tyObject REmpty
155159
156160typeInstanceDictionaryDeclaration :: 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
158163 m <- get
159164
160165 -- Lookup the type arguments and member types for the type class
161166 (TypeClassDeclaration _ args implies tyDecls) <- lift $
162167 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
163168 M.lookup (qualify mn className) m
164− let instanceTys = map memberToNameAndType tyDecls
165−
166− -- Replace the type arguments with the appropriate types in the member types
167− let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
168− -- Create values for the type instance members
169− memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
170− -- Create the type of the dictionary
171− -- 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
173− -- 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.
175− let superclasses = ObjectLiteral
176− [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
177− | (index, (superclass, suTyArgs)) <- zip [0..] implies
178− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
179− , let fieldName = mkSuperclassDictionaryName superclass index
180− ]
181−
182− let memberNames' = (C.__superclasses, superclasses) : memberNames
183− dictTy = foldl TypeApp (TypeConstructor className) tys
184− 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'
186− return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
169+
170+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
171+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
172+ [] -> do
173+
174+ let instanceTys = map memberToNameAndType tyDecls
175+
176+ -- Replace the type arguments with the appropriate types in the member types
177+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
178+ -- Create values for the type instance members
179+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
180+ -- Create the type of the dictionary
181+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
182+ -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
183+ -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
184+ -- dependencies, we introduce an unnamed function parameter.
185+ let superclasses = ObjectLiteral
186+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
187+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
188+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
189+ , let fieldName = mkSuperclassDictionaryName superclass index
190+ ]
191+
192+ let memberNames' = (C.__superclasses, superclasses) : memberNames
193+ dictTy = foldl TypeApp (TypeConstructor className) tys
194+ constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
195+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
196+
197+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
198+
187199 where
188200
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
206+
189207 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
190208 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'
192210 let memberValue = typeInstanceDictionaryEntryValue d
193211 return (ident, memberValue)
194212 memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do