From 7f449d0b3181635731b26a206c830a98649f3b51 Mon Sep 17 00:00:00 2001 From: justinwoo Date: Fri, 9 Jun 2017 15:51:44 +0200 Subject: [PATCH] add warning for type constructor aliases w/ suggestions --- examples/warning/TypeConstructorAlias.purs | 4 ++++ purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 4 ++++ src/Language/PureScript/Pretty/Types.hs | 12 ++++++++++++ src/Language/PureScript/TypeChecker.hs | 11 +++++++++++ 6 files changed, 33 insertions(+) create mode 100644 examples/warning/TypeConstructorAlias.purs diff --git a/examples/warning/TypeConstructorAlias.purs b/examples/warning/TypeConstructorAlias.purs new file mode 100644 index 0000000000..ce6e7c8d43 --- /dev/null +++ b/examples/warning/TypeConstructorAlias.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith TypeConstructorAlias +module Main where + +type TypeConstructorAlias = String diff --git a/purescript.cabal b/purescript.cabal index 159e03cf19..2e6777d345 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -616,6 +616,7 @@ extra-source-files: examples/warning/ShadowedBinderPatternGuard.purs examples/warning/ShadowedNameParens.purs examples/warning/ShadowedTypeVar.purs + examples/warning/TypeConstructorAlias.purs examples/warning/UnnecessaryFFIModule.js examples/warning/UnnecessaryFFIModule.purs examples/warning/UnusedDctorExplicitImport.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index c067e5afc9..07e2a3577c 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -70,6 +70,7 @@ data SimpleErrorMessage | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath + | TypeConstructorAlias (ProperName 'TypeName) [(Text, Maybe Kind)] Type | InfiniteType Type | InfiniteKind Kind | MultipleValueOpFixities (OpName 'ValueOpName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 742640a0c3..180603ab11 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -84,6 +84,7 @@ errorCode em = case unwrapErrorMessage em of CannotGetFileInfo{} -> "CannotGetFileInfo" CannotReadFile{} -> "CannotReadFile" CannotWriteFile{} -> "CannotWriteFile" + TypeConstructorAlias{} -> "TypeConstructorAlias" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" MultipleValueOpFixities{} -> "MultipleValueOpFixities" @@ -304,6 +305,7 @@ errorSuggestion err = HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty) WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty) + TypeConstructorAlias name args ty -> suggest $ T.pack (prettyPrintNewtypeForType name args ty) _ -> Nothing where emptySuggestion = Just $ ErrorSuggestion "" @@ -481,6 +483,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." renderSimpleErrorMessage OverlappingNamesInLet = line "The same name was used more than once in a let binding." + renderSimpleErrorMessage (TypeConstructorAlias _ _ _) = + line "This type synonym aliases a type constructor. Consider using a newtype or using the original type instead." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , markCodeBox $ indent $ typeAsBox ty diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index bee62db14c..e3b97d8b04 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -7,6 +7,7 @@ module Language.PureScript.Pretty.Types , prettyPrintType , prettyPrintTypeWithUnicode , prettyPrintSuggestedType + , prettyPrintNewtypeForType , typeAtomAsBox , prettyPrintTypeAtom , prettyPrintRow @@ -218,6 +219,17 @@ prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions prettyPrintSuggestedType :: Type -> String prettyPrintSuggestedType = prettyPrintType' suggestingOptions +-- | Generate a pretty-printed string newtype +prettyPrintNewtypeForType :: ProperName 'TypeName -> [(Text, Maybe Kind)] -> Type -> String +prettyPrintNewtypeForType (ProperName name) args ty = + "newtype " ++ name' ++ args' ++ " = " ++ name' ++ " " ++ ctr + where + name' = T.unpack name + args' = (" " ++) . T.unpack . fst =<< args + ctr = case ty of + TypeConstructor (Qualified _ (ProperName tn)) -> T.unpack tn + _ -> error "Type constructor was expected here." + prettyPrintType' :: TypeRenderOptions -> Type -> String prettyPrintType' tro = render . typeAsBoxImpl tro diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 1323b575ed..63b4f053de 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -163,6 +163,16 @@ addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) +checkTypeConstructorAlias + :: (MonadState CheckState m, MonadWriter MultipleErrors m) + => ProperName 'TypeName + -> [(Text, Maybe Kind)] + -> Type + -> m () +checkTypeConstructorAlias name args ty@(TypeConstructor _) = do + tell . errorMessage $ TypeConstructorAlias name args ty +checkTypeConstructorAlias _ _ _ = return () + checkDuplicateTypeArguments :: (MonadState CheckState m, MonadError MultipleErrors m) => [Text] @@ -262,6 +272,7 @@ typeCheckAll moduleName _ = traverse go toDataDecl _ = Nothing go (TypeSynonymDeclaration name args ty) = do warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do + checkTypeConstructorAlias name args ty checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind