@@ -33,8 +33,9 @@ import Control.Applicative
3333import Control.Monad.Error
3434import Control.Monad.State
3535import Control.Arrow (first, second)
36+import Data.List ((\\))
3637import Data.Monoid ((<>))
37−import Data.Maybe (catMaybes)
38+import Data.Maybe (catMaybes, mapMaybe)
3839
3940import qualified Data.Map as M
4041
@@ -117,7 +118,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
117118 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
118119 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
119120desugarDecl mn (PositionedDeclaration pos d) = do
120− (dr, ds) <- desugarDecl mn d
121+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
121122 return (dr, map (PositionedDeclaration pos) ds)
122123desugarDecl _ other = return (Nothing, [other])
123124
@@ -156,39 +157,52 @@ unit :: Type
156157unit = TypeApp tyObject REmpty
157158
158159typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
159−typeInstanceDictionaryDeclaration name mn deps className tys decls = do
160+typeInstanceDictionaryDeclaration name mn deps className tys decls =
161+ rethrow (strMsg ("Error in type class " ++ show className ++ ":") <>) $ do
160162 m <- get
161163
162164 -- Lookup the type arguments and member types for the type class
163165 (TypeClassDeclaration _ args implies tyDecls) <- lift $
164166 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
165167 M.lookup (qualify mn className) m
166− let instanceTys = map memberToNameAndType tyDecls
167−
168− -- Replace the type arguments with the appropriate types in the member types
169− let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
170− -- Create values for the type instance members
171− memberNames <- rethrow (strMsg ("Error in type class " ++ show className ++ ":") <>) $
172− map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
173− -- Create the type of the dictionary
174− -- The type is an object type, but depending on type instance dependencies, may be constrained.
175− -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
176− -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
177− -- dependencies, we introduce an unnamed function parameter.
178− let superclasses = ObjectLiteral
179− [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
180− | (index, (superclass, suTyArgs)) <- zip [0..] implies
181− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
182− , let fieldName = mkSuperclassDictionaryName superclass index
183− ]
184−
185− let memberNames' = (C.__superclasses, superclasses) : memberNames
186− dictTy = foldl TypeApp (TypeConstructor className) tys
187− constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
188− dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
189− return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
168+
169+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
170+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
171+ [] -> do
172+
173+ let instanceTys = map memberToNameAndType tyDecls
174+
175+ -- Replace the type arguments with the appropriate types in the member types
176+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
177+ -- Create values for the type instance members
178+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
179+ -- Create the type of the dictionary
180+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
181+ -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
182+ -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
183+ -- dependencies, we introduce an unnamed function parameter.
184+ let superclasses = ObjectLiteral
185+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
186+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
187+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
188+ , let fieldName = mkSuperclassDictionaryName superclass index
189+ ]
190+
191+ let memberNames' = (C.__superclasses, superclasses) : memberNames
192+ dictTy = foldl TypeApp (TypeConstructor className) tys
193+ constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
194+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
195+
196+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
197+
190198 where
191199
200+ declName :: Declaration -> Maybe Ident
201+ declName (PositionedDeclaration _ d) = declName d
202+ declName (ValueDeclaration ident _ _ _ _) = Just ident
203+ declName (TypeDeclaration ident _) = Just ident
204+ declName _ = Nothing
205+
192206 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
193207 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
194208 _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'