@@ -191,23 +191,19 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
191 go :: Declaration -> m Declaration
191 go :: Declaration -> m Declaration
192 go (DataDeclaration dtype name args dctors) = do
192 go (DataDeclaration dtype name args dctors) = do
193 warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
193 warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
194− when (dtype == Newtype) $ checkNewtype dctors
194+ when (dtype == Newtype) $ checkNewtype name dctors
195 checkDuplicateTypeArguments $ map fst args
195 checkDuplicateTypeArguments $ map fst args
196 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
196 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
197 let args' = args `withKinds` ctorKind
197 let args' = args `withKinds` ctorKind
198 addDataType moduleName dtype name args' dctors ctorKind
198 addDataType moduleName dtype name args' dctors ctorKind
199 return $ DataDeclaration dtype name args dctors
199 return $ DataDeclaration dtype name args dctors
201− checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()
202− checkNewtype [(_, [_])] = return ()
203− checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
204− checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
205 go (d@(DataBindingGroupDeclaration tys)) = do
200 go (d@(DataBindingGroupDeclaration tys)) = do
206 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
201 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
207 let syns = mapMaybe toTypeSynonym tys
202 let syns = mapMaybe toTypeSynonym tys
208 let dataDecls = mapMaybe toDataDecl tys
203 let dataDecls = mapMaybe toDataDecl tys
209 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
204 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
210 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
205 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
206+ when (dtype == Newtype) $ checkNewtype name dctors
211 checkDuplicateTypeArguments $ map fst args
207 checkDuplicateTypeArguments $ map fst args
212 let args' = args `withKinds` ctorKind
208 let args' = args `withKinds` ctorKind
213 addDataType moduleName dtype name args' dctors ctorKind
209 addDataType moduleName dtype name args' dctors ctorKind
@@ -327,6 +323,10 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
327 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
323 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
328 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
324 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
326+ checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
327+ checkNewtype _ [(_, [_])] = return ()
328+ checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
331 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
331 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
332 -- extracted from the kind of the type constructor itself.
332 -- extracted from the kind of the type constructor itself.