source-constraints (empty) → 0.0.1

raw patch · 12 files changed

+602/−0 lines, 12 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, filepath, ghc, ghc-paths, heredoc, hspec, source-constraints, syb, text

Files

• LICENSE +11/−0
• README.md +22/−0
• source-constraints.cabal +89/−0
• src/SourceConstraints.hs +247/−0
• src/SourceConstraints/LocalModule.hs +39/−0
• test/LocalModuleExplicitImport.hs +3/−0
• test/MissingDerivingStrategy.hs +9/−0
• test/Spec.hs +160/−0
• test/UnsortedIE.hs +4/−0
• test/UnsortedIEThingWith.hs +3/−0
• test/UnsortedImportStatement.hs +4/−0
• test/UnsortedMultipleDeriving.hs +11/−0

@@ -0,0 +1,11 @@+Copyright 2019-2020 Markus Schirp++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,22 @@+![CI](https://github.com/mbj/source-constraints/workflows/CI/badge.svg)++# source-constraints++An in progress GHC plugin to add constraints on the GHC AST.++## Installation++Add the following extra-dep to your `stack.yml`:++```yaml+extra-deps:+- git: ssh://git@github.com/mbj/source-constraints+  commit: $use_current_commit_hash+```++Add the plugin to your `packages.yml`++```yaml+ghc-options:+- -fplugin=SourceConstraints+```

@@ -0,0 +1,89 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 91a3bc64301e8157e58aa102b9090a7175351884011c0df8480f6971486b3ba3++name:           source-constraints+version:        0.0.1+synopsis:       Source constraints GHC plugin+description:    Please visit the README at <https://github.com/mbj/source-constraints#readme>+                for usage information.+category:       CodeQuality+homepage:       https://github.com/mbj/source-constraints#readme+bug-reports:    https://github.com/mbj/source-constraints/issues+author:         Markus Schirp+maintainer:     mbj@schirp-dso.com+copyright:      2018 Markus Schirp+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    test/LocalModuleExplicitImport.hs+    test/MissingDerivingStrategy.hs+    test/UnsortedIE.hs+    test/UnsortedIEThingWith.hs+    test/UnsortedImportStatement.hs+    test/UnsortedMultipleDeriving.hs+extra-doc-files:+    README.md++source-repository head+  type: git+  location: https://github.com/mbj/source-constraints++flag development+  description: Run GHC with development flags+  manual: True+  default: False++library+  exposed-modules:+      SourceConstraints+      SourceConstraints.LocalModule+  other-modules:+      Paths_source_constraints+  hs-source-dirs:+      src+  default-extensions: DerivingStrategies GeneralizedNewtypeDeriving LambdaCase NoImplicitPrelude OverloadedStrings RecordWildCards ScopedTypeVariables Strict+  ghc-options: -Wall -Wcompat -Widentities -Wimplicit-prelude -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-exported-signatures -Wmissing-local-signatures -Wmonomorphism-restriction+  build-depends:+      attoparsec >=0.13 && <0.14+    , base >=4.13 && <4.14+    , bytestring >=0.10 && <0.11+    , filepath >=1.4 && <1.5+    , ghc >=8.8 && <8.9+    , syb >=0.7 && <0.8+    , text >=1.2 && <1.3+  if flag(development)+    ghc-options: -Werror+  else+    ghc-options: -Wwarn+  default-language: Haskell2010++test-suite hspec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  default-extensions: DerivingStrategies GeneralizedNewtypeDeriving LambdaCase NoImplicitPrelude OverloadedStrings RecordWildCards ScopedTypeVariables Strict+  ghc-options: -Wall -Wcompat -Widentities -Wimplicit-prelude -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-exported-signatures -Wmissing-local-signatures -Wmonomorphism-restriction -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      attoparsec >=0.13 && <0.14+    , base >=4.13 && <4.14+    , bytestring >=0.10 && <0.11+    , filepath >=1.4 && <1.5+    , ghc >=8.8 && <8.9+    , ghc-paths >=0.1 && <0.2+    , heredoc >=0.2 && <0.3+    , hspec >=2.7 && <2.8+    , source-constraints+    , syb >=0.7 && <0.8+    , text >=1.2 && <1.3+  if flag(development)+    ghc-options: -Werror+  else+    ghc-options: -Wwarn+  default-language: Haskell2010

@@ -0,0 +1,247 @@+{-# LANGUAGE RankNTypes #-}++module SourceConstraints (Context(..), plugin, warnings) where++import Bag+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.Attoparsec.Text+import Data.Bool+import Data.Char+import Data.Data+import Data.Either+import Data.Eq+import Data.Foldable+import Data.Function+import Data.Generics.Aliases+import Data.Generics.Text+import Data.List+import Data.Maybe+import Data.Ord+import Data.Semigroup+import Data.String (String)+import Data.Text (Text, pack)+import Data.Tuple+import DynFlags+import ErrUtils+import HsDecls+import HsExtension+import HsSyn+import HscTypes+import Module hiding (Module)+import Outputable hiding ((<>), empty)+import Plugins+import Prelude(error)+import SrcLoc+import System.FilePath.Posix+import SourceConstraints.LocalModule++data Context = Context+  { dynFlags     :: DynFlags+  , localModules :: [LocalModule]+  }++plugin :: Plugin+plugin =+  defaultPlugin+  { parsedResultAction = run+  , pluginRecompile    = purePlugin+  }++run+  :: [CommandLineOption]+  -> ModSummary+  -> HsParsedModule+  -> Hsc HsParsedModule+run options summary parsedModule = do+  dynFlags <- getDynFlags+  runSourceConstraints dynFlags options summary parsedModule++runSourceConstraints+  :: DynFlags+  -> [CommandLineOption]+  -> ModSummary+  -> HsParsedModule+  -> Hsc HsParsedModule+runSourceConstraints dynFlags options ModSummary{ms_location = ModLocation{..}} parsedModule = do+  localModules <- mapM parseLocalModule (pack <$> options)+  when (allowLocation ml_hs_file) . emitWarnings $ warnings Context{..} (hpm_module parsedModule)+  pure parsedModule+  where+    allowLocation = maybe False (notElem "autogen/" . splitPath)++    emitWarnings :: Bag WarnMsg -> Hsc ()+    emitWarnings  = liftIO . printOrThrowWarnings dynFlags++    parseLocalModule :: Text -> Hsc LocalModule+    parseLocalModule+      = either localParseFailure pure . parseOnly localModuleParser++    localParseFailure :: String -> Hsc a+    localParseFailure =+      throwOneError . mkPlainErrMsg dynFlags noSrcSpan . text++-- | Find warnings for node+warnings+  :: (Data a, Data b, Typeable a)+  => Context+  -> GenLocated a b+  -> WarningMessages+warnings context@Context{..} (L sourceSpan node) =+  unionManyBags+    [ maybe emptyBag mkWarning $ unlocatedWarning context node+    , locatedWarnings context node+    , descend node+    ]+  where+    mkWarning =+      unitBag . mkWarnMsg+        dynFlags+        (fromJust $ cast sourceSpan)+        neverQualify++    descend :: Data a => a -> WarningMessages+    descend =+      unionManyBags . gmapQ+        (descend `ext2Q` warnings context)++data IEClass = Module String | Type String | Operator String | Function String+  deriving stock (Eq, Ord)++locatedWarnings :: Data a => Context -> a -> WarningMessages+locatedWarnings context@Context{..} node =+  singleWarnings `unionBags` mkQ emptyBag absentImportDeclList node+  where+    singleWarnings = listToBag $ catMaybes+      [ mkQ empty sortedImportStatement  node+      , mkQ empty sortedIEThingWith      node+      , mkQ empty sortedIEs              node+      , mkQ empty sortedMultipleDeriving node+      ]++    absentImportDeclList :: HsModule GhcPs -> WarningMessages+    absentImportDeclList HsModule{..} =+      listToBag $ catMaybes (absentList <$> candidates)+      where+        absentList :: LImportDecl GhcPs -> Maybe ErrMsg+        absentList = \case+          (L _loc ImportDecl { ideclHiding = Just (False, L loc list) }) ->+            testList loc list+          _  -> empty++        testList :: SrcSpan -> [LIE GhcPs] -> Maybe ErrMsg+        testList srcSpan = \case+          [] -> empty+          _  -> pure $ notEmpty srcSpan++        notEmpty :: SrcSpan -> ErrMsg+        notEmpty src =+          mkWarnMsg+            dynFlags+            src+            neverQualify+            (text "Present import list for local module")++        candidates :: [LImportDecl GhcPs]+        candidates = filter isCandidate hsmodImports++        isCandidate :: LImportDecl GhcPs -> Bool+        isCandidate = \case+          (L _ ImportDecl{ideclName = L _ moduleName}) ->+            any (`isLocalModule` moduleName) localModules+          _ -> False++    sortedImportStatement :: HsModule GhcPs -> Maybe ErrMsg+    sortedImportStatement HsModule{..} =+      sortedLocated+        "import statement"+        context+        (render context)+        hsmodImports++    sortedMultipleDeriving :: [LHsDerivingClause GhcPs] -> Maybe ErrMsg+    sortedMultipleDeriving =+      sortedLocated+        "deriving clauses"+        context+        (render context)++    sortedIEs :: [LIE GhcPs] -> Maybe ErrMsg+    sortedIEs =+      sortedLocated+        "import/export declaration"+        context+        ieClass++    sortedIEThingWith :: IE GhcPs -> Maybe ErrMsg+    sortedIEThingWith = \case+      (IEThingWith _xIE _name _ieWildcard ieWith _ieFieldLabels) ->+        sortedLocated+          "import/export item with list"+          context+          (render context)+          ieWith+      _ -> empty++    classify str@('(':_) = Function str+    classify str@(x:_)   = if isUpper x then Type str else Function str+    classify []          = error "Parser error"++    ieClass :: IE GhcPs -> IEClass+    ieClass = \case+      (IEVar _xIE name)            -> mkClass classify name+      (IEThingAbs _xIE name)       -> mkClass Type name+      (IEThingAll _xIE name)       -> mkClass Type name+      (IEModuleContents _xIE name) -> mkClass Module name+      (IEThingWith _xIE name _ieWildcard _ieWith _ieFieldLabels) ->+        mkClass Type name+      ie -> error $ "Unsupported: " <> gshow ie++    mkClass :: (Outputable a, Outputable b) => (String -> IEClass) -> GenLocated a b -> IEClass+    mkClass constructor name = constructor $ render context name++unlocatedWarning :: Data a => Context -> a -> Maybe SDoc+unlocatedWarning _context = mkQ empty requireDerivingStrategy++requireDerivingStrategy :: HsDerivingClause GhcPs -> Maybe SDoc+requireDerivingStrategy = \case+  HsDerivingClause{deriv_clause_strategy = Nothing} ->+    pure $ text "Missing deriving strategy"+  _ -> empty++render :: Outputable a => Context -> a -> String+render Context{..} outputable =+  renderWithStyle+    dynFlags+    (ppr outputable)+    (defaultUserStyle dynFlags)++sortedLocated+  :: forall a b . (Eq b, Ord b, Outputable a)+  => String+  -> Context+  -> (a -> b)+  -> [Located a]+  -> Maybe ErrMsg+sortedLocated name context@Context{..} ordering nodes =+  mkWarning <$> find isViolation candidates+  where+    mkWarning :: ((Located a, b), (Located a, b)) -> ErrMsg+    mkWarning ((actualNode, _item), (expectedNode, _expected)) =+      mkWarnMsg+        dynFlags+        (getLoc actualNode)+        neverQualify+        (text $ "Unsorted " <> name <> ", expected: " <> render context expectedNode)++    isViolation :: ((Located a, b), (Located a, b)) -> Bool+    isViolation ((_actualNode, item), (_expectedNode, expected)) =+      item /= expected++    candidates :: [((Located a, b), (Located a, b))]+    candidates =+      let items    = (\node -> (node, ordering $ unLoc node)) <$> nodes+          expected = sortBy (compare `on` snd) items+      in+        zip items expected

@@ -0,0 +1,39 @@+module SourceConstraints.LocalModule+  ( LocalModule(..)+  , isLocalModule+  , localModuleParser+  )+where++import Control.Applicative+import Data.Attoparsec.Text+import Data.Bool+import Data.Char+import Data.Eq+import Data.Function+import Data.Semigroup+import Data.List+import Module++newtype LocalModule = LocalModule ModuleName++localModuleParser :: Parser LocalModule+localModuleParser = LocalModule <$> (string "local:" *> moduleNameParser)++moduleNameParser :: Parser ModuleName+moduleNameParser = do+  first  <- section+  others <- many (char '.' *> section)++  pure . mkModuleName $ first <> intercalate "." others+  where+    section = (:) <$> satisfy isUpper <*> many (satisfy isLower)++isLocalModule :: LocalModule -> ModuleName -> Bool+isLocalModule (LocalModule localModuleName) moduleName =+  localModuleName == moduleName || prefixMatch+    where+      prefixMatch =+        (moduleNameString localModuleName <> ".")+        `isPrefixOf`+        moduleNameString moduleName

@@ -0,0 +1,3 @@+module LocalModuleExplicitImport where++import Data.Word (Word32)

@@ -0,0 +1,9 @@+{-# LANGUAGE DerivingStrategies #-}++module MissingDerivingStrategy where++import Data.Eq (Eq)++data Foo = Foo deriving Eq++data Bar = Bar deriving stock Eq

@@ -0,0 +1,160 @@+{-# LANGUAGE QuasiQuotes #-}++module Main (main) where++import Bag+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.Bool+import Data.Eq+import Data.Foldable+import Data.Function+import Data.Maybe+import Data.Semigroup+import Data.String+import GHC.Paths+import HscMain+import HscTypes+import Module+import Outputable hiding ((<>), empty)+import SourceConstraints+import SourceConstraints.LocalModule+import System.IO+import Test.Hspec+import Text.Heredoc++import DynFlags+  ( DynFlags(packageFlags)+  , ModRenaming(ModRenaming)+  , PackageArg(PackageArg)+  , PackageFlag(ExposePackage)+  , getDynFlags+  )++import ErrUtils+  ( WarnMsg+  , errMsgDoc+  , errMsgSeverity+  , errMsgSpan+  , formatErrDoc+  , getCaretDiagnostic+  )++import GHC+  ( GhcMonad+  , LoadHowMuch(LoadAllTargets)+  , depanal+  , getSession+  , getSessionDynFlags+  , guessTarget+  , load+  , runGhc+  , setSessionDynFlags+  , setTargets+  , succeeded+  )++main :: IO ()+main = hspec $ do+  expectWarnings+    "test/MissingDerivingStrategy.hs"+    [[str|Missing deriving strategy+         |  |+         |7 | data Foo = Foo deriving Eq+         |  |                ^^^^^^^^^^^|]]++  expectWarnings+    "test/UnsortedIE.hs"+    [[str|Unsorted import/export declaration, expected: Integer+         |  |+         |4 | import Prelude (tail, head, Integer, (+))+         |  |                 ^^^^|]]+  expectWarnings+    "test/UnsortedIEThingWith.hs"+    [[str|Unsorted import/export item with list, expected: (+)+         |  |+         |3 | import GHC.Num (Num((-), (+)))+         |  |                     ^^^|]]++  expectWarnings+    "test/UnsortedMultipleDeriving.hs"+    [[str|Unsorted deriving clauses, expected: deriving newtype Eq+         |   |+         |10 |   deriving stock Show+         |   |   ^^^^^^^^^^^^^^^^^^^|]]++  expectWarnings+    "test/UnsortedImportStatement.hs"+    [[str|Unsorted import statement, expected: import Data.Bool+         |  |+         |3 | import Data.Char+         |  | ^^^^^^^^^^^^^^^^|]]++  expectWarnings+    "test/LocalModuleExplicitImport.hs"+    [[str|Present import list for local module+         |  |+         |3 | import Data.Word (Word32)+         |  |                  ^^^^^^^^|]]+  where+    expectWarnings file messages =+      it ("returns expected warnings from: " <> file) $ do+        actual <- getWarnings file+        actual `shouldBe` messages++getWarnings :: String -> IO [String]+getWarnings file = runGhc (pure libdir) $ do+  setupDynFlags+  setupTargets++  parseWarnings++  where+    parseWarnings :: GhcMonad m => m [String]+    parseWarnings = do+      moduleGraph <- depanal empty True++      let moduleSummary =+            fromMaybe+              (panic $ "Cannot find module summary for " <> file <> " in dependency graph")+              (find ((== file) . msHsFilePath) $ mgModSummaries moduleGraph)++      env          <- getSession+      dynFlags     <- getDynFlags+      parsedModule <- liftIO $ hscParse env moduleSummary++      let localModules = [LocalModule $ mkModuleName "Data.Word"]++      mapM (render dynFlags) . bagToList . warnings Context{..} $ hpm_module parsedModule++    setupDynFlags :: GhcMonad m => m ()+    setupDynFlags = do+      dynFlags <- getSessionDynFlags+      void . setSessionDynFlags $ dynFlags { packageFlags = [packageFlag] }+      where+        packageFlag =+          ExposePackage+            "-package base"+            (PackageArg "base")+            (ModRenaming True empty)++    setupTargets :: GhcMonad m => m ()+    setupTargets = do+      target <- guessTarget file empty+      setTargets [target]+      result <- load LoadAllTargets++      unless (succeeded result) $ panic "Loading of targets failed"++    render :: GhcMonad m => DynFlags -> WarnMsg -> m String+    render dynFlags warning = do+      caretDiagnostic <- liftIO $+        getCaretDiagnostic+          (errMsgSeverity warning)+          (errMsgSpan warning)++      pure $ renderWithStyle+        dynFlags+        (formatErrDoc dynFlags (errMsgDoc warning) $+$ caretDiagnostic)+        (defaultUserStyle dynFlags)

@@ -0,0 +1,4 @@+module UnoderedIE where++import Control.Monad (Monad, (=<<), unless)+import Prelude (tail, head, Integer, (+))

@@ -0,0 +1,3 @@+module UnoderedIEThingWith where++import GHC.Num (Num((-), (+)))

@@ -0,0 +1,4 @@+module UnsortedImportStatement where++import Data.Char+import Data.Bool

@@ -0,0 +1,11 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module UnorderedMultipleDeriving where++import Data.Eq (Eq)+import Text.Show (Show)++newtype SomeType = SomeType ()+  deriving stock Show+  deriving newtype Eq