@@ -33,8 +33,9 @@ import Control.Applicative
33import Control.Monad.Error
33import Control.Monad.Error
34import Control.Monad.State
34import Control.Monad.State
35import Control.Arrow (first, second)
35import Control.Arrow (first, second)
36+import Data.List ((\\))
36import Data.Monoid ((<>))
37import Data.Monoid ((<>))
37−import Data.Maybe (catMaybes)
38+import Data.Maybe (catMaybes, mapMaybe)
39import qualified Data.Map as M
40import qualified Data.Map as M
@@ -117,7 +118,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
117 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
118 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
118 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
119 return $ (Just $ TypeInstanceRef name, [d, dictDecl])
119desugarDecl mn (PositionedDeclaration pos d) = do
120desugarDecl mn (PositionedDeclaration pos d) = do
120− (dr, ds) <- desugarDecl mn d
121+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
121 return (dr, map (PositionedDeclaration pos) ds)
122 return (dr, map (PositionedDeclaration pos) ds)
122desugarDecl _ other = return (Nothing, [other])
123desugarDecl _ other = return (Nothing, [other])
@@ -156,39 +157,52 @@ unit :: Type
156unit = TypeApp tyObject REmpty
157unit = TypeApp tyObject REmpty
158typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
159typeInstanceDictionaryDeclaration :: 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
162 -- Lookup the type arguments and member types for the type class
164 -- Lookup the type arguments and member types for the type class
163 (TypeClassDeclaration _ args implies tyDecls) <- lift $
165 (TypeClassDeclaration _ args implies tyDecls) <- lift $
164 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
166 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
165 M.lookup (qualify mn className) m
167 M.lookup (qualify mn className) m
169+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
170+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
166− let instanceTys = map memberToNameAndType tyDecls
173+ let instanceTys = map memberToNameAndType tyDecls
168− -- Replace the type arguments with the appropriate types in the member types
175+ -- Replace the type arguments with the appropriate types in the member types
169− let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
176+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
170− -- Create values for the type instance members
177+ -- 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
178+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
173− -- Create the type of the dictionary
179+ -- Create the type of the dictionary
174− -- The type is an object type, but depending on type instance dependencies, may be constrained.
180+ -- 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
181+ -- 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
182+ -- 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.
183+ -- dependencies, we introduce an unnamed function parameter.
178− let superclasses = ObjectLiteral
184+ let superclasses = ObjectLiteral
179− [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
185+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
180− | (index, (superclass, suTyArgs)) <- zip [0..] implies
186+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
181− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
187+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
182− , let fieldName = mkSuperclassDictionaryName superclass index
188+ , let fieldName = mkSuperclassDictionaryName superclass index
185− let memberNames' = (C.__superclasses, superclasses) : memberNames
191+ let memberNames' = (C.__superclasses, superclasses) : memberNames
186− dictTy = foldl TypeApp (TypeConstructor className) tys
192+ dictTy = foldl TypeApp (TypeConstructor className) tys
187− constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
193+ 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'
194+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
189− return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
196+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
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
192 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
206 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
193 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
207 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
194 _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
208 _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'