diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`extensions` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.0.0.0 — May the 4th, 2020 💪 + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/extensions/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,120 @@ +# extensions + +![Logo](https://user-images.githubusercontent.com/8126674/80925339-f09a4e80-8d86-11ea-81f4-fd1a6f50cd6b.png) + +[![GitHub CI](https://github.com/kowainik/extensions/workflows/CI/badge.svg)](https://github.com/kowainik/extensions/actions) +[![Hackage](https://img.shields.io/hackage/v/extensions.svg?logo=haskell)](https://hackage.haskell.org/package/extensions) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](LICENSE) + +Library and CLI tool to parse Haskell `{-# LANGUAGE #-}` extensions in +source files, extract `default-extensions` from `.cabal` files and +combine together `default-extensions` and per-module extensions. + +## Goals + +The `extensions` library provides a lighweight way to get Haskell +LANGUAGE pragmas for Haskell modules. It has the following goals: + +1. Be **lightweight**. Dependency footprint is extremely small, + and using `extensions` either as a library or as a tool is + straightforward. +2. Support both `default-extensions` in **Cabal** and `{-# LANGUAGE #-}` + pragmas in **Haskell** modules. +3. Should work on common and real cases. `extensions` strives to + support as many valid syntactic constructions as possible, but it + may not work on every possible combination of CPP, comments and + pragmas, where GHC would work. We encouragle you to + [open issue](https://github.com/kowainik/extensions/issues/new) if + you encounter any failures when using `extensions`. + +## How to use + +You can use `extensions` either as a library or as a CLI tool. + +### Library + +#### Usage with Cabal + +`extensions` is compatible with the latest GHC compiler +versions starting from `8.8.3`. + +In order to start using `extensions` in your project, you +will need to set it up with the three easy steps: + +1. Add the dependency on `extensions` in your project's + `.cabal` file. For this, you should modify the `build-depends` + section by adding the name of this library. After the adjustment, + this section could look like this: + + ```haskell + build-depends: base ^>= 4.14 + , extensions ^>= 0.0 + ``` +2. In the module where you wish to extract extensions, you + should add the import: + + ```haskell + import Extensions (getPackageExtensions) + ``` +3. Now you can use the types and functions from the library: + + ```haskell + main :: IO () + main = getPackageExtensions "extensions.cabal" >>= print + ``` + +#### Usage with Stack + +If `extensions` is not available on your current Stackage +resolver yet, fear not! You can still use it from Hackage by adding +the following to the `extra-deps` section of your `stack.yaml` file: + +```yaml +extra-deps: + - extensions-0.0.0.0 +``` + +### CLI tool + +To use `extensions` as a CLI tool, you need to install it either with Cabal + +``` +cabal install extensions +``` + +or Stack + +``` +stack install extensions +``` + +The tool can be used to inspect language extensions in your Haskell +project. Some common usages of the tool: + +1. Get all extensions in all modules, combined with + `default-extensions` from the `.cabal` file. + ![All extensions](https://user-images.githubusercontent.com/4276606/80870176-b0f73800-8c9c-11ea-8ffc-dda2d4940d1e.png) +2. Get all extensions for a specific module, combined with Cabal + extensions. + ![Module extensions](https://user-images.githubusercontent.com/4276606/80870175-b05ea180-8c9c-11ea-9f48-cac7ff854b9c.png) +3. Get extensions defined only in a module. + ![Only module](https://user-images.githubusercontent.com/4276606/80870173-afc60b00-8c9c-11ea-9d74-cf92ed0c3940.png) + +## Alternatives + +Alternatively, you can extract Haskell Language extensions using the +following ways: + +1. Using `ghc` as a library. This approach ties you to a specific GHC + version and requires more effort to support multiple GHCs. Also, + GHC API is more complicated than `extensions` API (especially if + you want to handle `CPP`). And even with `CPP` handling from `ghc` + you won't be able to get all extensions defined in a + module. However, this approach allows you to fully reproduce GHC + behaviour. +2. Using `ghc-lib-parser`. Same as the previous approach, but does not + tie you to a specific GHC version. However, `ghc-lib-parser` is + rather big dependency. +3. Using the `haskell-src-exts` library. This library parses Haskell + source files, but it's not actively maintained anymore and doesn't + support `CPP`. diff --git a/app/Cli.hs b/app/Cli.hs new file mode 100644 --- /dev/null +++ b/app/Cli.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +CLI options for the @extensions@ exectuable. +-} + +module Cli + ( ExtensionsArgs (..) + , Toggle (..) + , runExtensionsCli + ) where + +import Options.Applicative (Parser, ParserInfo, execParser, flag, fullDesc, help, helper, info, + long, metavar, optional, progDesc, strOption) + + +-- | Options used for the main @extensions@ executable. +data ExtensionsArgs = ExtensionsArgs + { -- | Path to cabal file + extensionsArgsCabalFilePath :: !(Maybe FilePath) + -- | Path to module + , extensionsArgsModuleFilePath :: !(Maybe FilePath) + -- | When 'Disabled', do not check extensions in @.cabal@ file + , extensionsArgsCabalToggle :: !Toggle + -- | When 'Disabled', print only @.cabal@ file's @default-extensions@ + , extensionsArgsModulesToggle :: !Toggle + } + +data Toggle + = Disabled + | Enabled + +-- | Run main parser of the @extensions@ command line tool. +runExtensionsCli :: IO ExtensionsArgs +runExtensionsCli = execParser extensionsCliParser + +extensionsCliParser :: ParserInfo ExtensionsArgs +extensionsCliParser = info (helper <*> extensionsP) $ + fullDesc <> progDesc "Display Haskell Language Extensions" + +-- | @extensions@ command parser. +extensionsP :: Parser ExtensionsArgs +extensionsP = do + extensionsArgsCabalFilePath <- filePathP "cabal" ".cabal file" + extensionsArgsModuleFilePath <- filePathP "module" "Haskell module" + extensionsArgsCabalToggle <- noCabalP + extensionsArgsModulesToggle <- noModulesP + pure ExtensionsArgs{..} + +filePathP :: String -> String -> Parser (Maybe FilePath) +filePathP opt desc = optional $ strOption $ mconcat + [ long $ opt <> "-file-path" + , metavar "FILE_PATH" + , help $ "Relative path to the " <> desc + ] + +noCabalP :: Parser Toggle +noCabalP = flag Enabled Disabled $ mconcat + [ long "no-cabal" + , help "Do not check extensions in the .cabal file" + ] + +noModulesP :: Parser Toggle +noModulesP = flag Enabled Disabled $ mconcat + [ long "no-modules" + , help "Print only .cabal file's 'default-extensions'" + ] diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,168 @@ +module Main (main) where + +import Colourista (errorMessage, infoMessage) +import Control.Exception (catch) +import Data.Foldable (forM_, for_) +import Data.List (nub) +import Data.Text (Text) +import GHC.Exts (sortWith) +import System.Directory (doesFileExist, getCurrentDirectory, listDirectory) +import System.Exit (exitFailure) +import System.FilePath (takeExtension, ()) + +import Cli (ExtensionsArgs (..), Toggle (..), runExtensionsCli) +import Extensions (ExtensionsResult, getModuleExtentions, getPackageExtentions) +import Extensions.Cabal (parseCabalFileExtensions) +import Extensions.Module (parseFile) +import Extensions.Types (CabalException, Extensions (..), OnOffExtension (..), + ParsedExtensions (..), SafeHaskellExtension, showOnOffExtension) + +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO + + +main :: IO () +main = do + ExtensionsArgs{..} <- runExtensionsCli + run extensionsArgsCabalFilePath + extensionsArgsModuleFilePath + extensionsArgsCabalToggle + extensionsArgsModulesToggle + + +run :: Maybe FilePath -> Maybe FilePath -> Toggle -> Toggle -> IO () +run mCabalPath mModulePath cabal modules = case (mCabalPath, mModulePath, cabal, modules) of + -- no options specified + (Nothing, Nothing, Enabled, Enabled) -> + findCabalFile >>= printAllModulesExtensions + + -- --no-modules + (Nothing, Nothing, Enabled, Disabled) -> + findCabalFile >>= printOnlyCabalExtensions + + -- --no-cabal + (Nothing, Nothing, Disabled, _modules) -> exitAfter $ do + errorMessage "No cabal file or module specified" + infoMessage "Use the --module-file-path option to print extensions for a module" + + -- --cabal-file-path + (Just cabalPath, Nothing, Enabled, Enabled) -> + withPath cabalPath (printAllModulesExtensions cabalPath) + + -- --cabal-file-path --no-modules + (Just cabalPath, Nothing, Enabled, Disabled) -> + withPath cabalPath (printOnlyCabalExtensions cabalPath) + + -- --cabal-file-path --no-cabal + (Just _cabalPath, _modulePath, Disabled, _modules) -> exitAfter $ + errorMessage "Both --cabal-file-path and --no-cabal are specified" + + -- --module-file-path --no-modules + (_cabalPath, Just _modulePath, _cabal, Disabled) -> exitAfter $ + errorMessage "Both --module-file-path and --no-modules are specified" + + -- --module-file-path + (Nothing, Just modulePath, Enabled, Enabled) -> withPath modulePath $ do + cabalPath <- findCabalFile + extsResult <- getModuleExtentions cabalPath modulePath + infoMessage $ "Cabal extensions and extensions in module " <> Text.pack modulePath + printExtensionsResult extsResult + + -- --module-file-path --no-cabal + (Nothing, Just modulePath, Disabled, Enabled) -> withPath modulePath $ + parseFile modulePath >>= \case + Left err -> + errorMessage $ "Error parsing module: " <> tshow err + Right ParsedExtensions{..} -> do + infoMessage $ "Extensions defined only in " <> Text.pack modulePath + printOnOffExtensions parsedExtensionsAll + case parsedExtensionsSafe of + Just safe -> print safe + Nothing -> pure () + + -- --cabal-file-path --module-file-path + (Just cabalPath, Just modulePath, Enabled, Enabled) -> + withPath cabalPath $ withPath modulePath $ do + extsResult <- getModuleExtentions cabalPath modulePath + infoMessage $ "Cabal extensions and extensions in module " <> Text.pack modulePath + printExtensionsResult extsResult + where + -- check whether the file exist under the path and run action only if exists + withPath :: FilePath -> IO a -> IO a + withPath path action = doesFileExist path >>= \pathExists -> + if pathExists + then action + else exitAfter $ errorMessage $ "File does not exist: " <> Text.pack path + +exitAfter :: IO a -> IO b +exitAfter action = action >> exitFailure + +-- | Find a @.cabal@ file in the current directory. +findCabalFile :: IO FilePath +findCabalFile = do + dirPath <- getCurrentDirectory + dirContent <- listDirectory dirPath + let cabalFiles = filter (\p -> takeExtension p == ".cabal") dirContent + let usageHint = infoMessage + "Use the --cabal-file-path option to specify path to .cabal file" + case cabalFiles of + [] -> exitAfter $ do + errorMessage ".cabal file not found in the current directory" + usageHint + [cabalFile] -> + pure $ dirPath cabalFile + l -> exitAfter $ do + errorMessage $ "Multiple .cabal files found: " + <> Text.intercalate ", " (map Text.pack l) + usageHint + +printAllModulesExtensions :: FilePath -> IO () +printAllModulesExtensions cabalPath = do + cabalExts <- handleCabalException $ getPackageExtentions cabalPath + infoMessage "Extensions for each module combined with 'default-extensions'" + + let modules = sortWith fst $ Map.toList cabalExts + forM_ modules $ \(path, extsRes) -> do + putStrLn path + case extsRes of + Left err -> errorMessage $ " Error: " <> tshow err + Right Extensions{..} -> do + mapM_ (TextIO.putStrLn . (" " <>) . showOnOffExtension) extensionsAll + case extensionsSafe of + Just safe -> putStrLn $ " " <> show safe + Nothing -> pure () + +printOnlyCabalExtensions :: FilePath -> IO () +printOnlyCabalExtensions cabalPath = do + cabalExts <- handleCabalException $ parseCabalFileExtensions cabalPath + let (g, x) = concatAll $ Map.elems cabalExts + let (exts, mSafe) = ( nub g , nub x) + + infoMessage $ "All language extensions defined in " <> Text.pack cabalPath + printOnOffExtensions exts + for_ mSafe $ \case + Just safe -> print safe + Nothing -> pure () + where + concatAll :: [ParsedExtensions] -> ([OnOffExtension], [Maybe SafeHaskellExtension]) + concatAll = foldMap (\ParsedExtensions{..} -> (parsedExtensionsAll, [parsedExtensionsSafe])) + +handleCabalException :: IO a -> IO a +handleCabalException action = action `catch` \(exc :: CabalException) -> exitAfter $ + errorMessage $ "Error processing .cabal file: " <> tshow exc + +printOnOffExtensions :: Foldable f => f OnOffExtension -> IO () +printOnOffExtensions = mapM_ (TextIO.putStrLn . showOnOffExtension) + +printExtensionsResult :: ExtensionsResult -> IO () +printExtensionsResult = \case + Left err -> errorMessage $ "Error in finding extensions: " <> tshow err + Right Extensions{..} -> do + printOnOffExtensions extensionsAll + case extensionsSafe of + Just safe -> print safe + Nothing -> pure () + +tshow :: Show a => a -> Text +tshow = Text.pack . show diff --git a/extensions.cabal b/extensions.cabal new file mode 100644 --- /dev/null +++ b/extensions.cabal @@ -0,0 +1,112 @@ +cabal-version: 2.4 +name: extensions +version: 0.0.0.0 +synopsis: Parse Haskell Language Extensions +description: Parse Haskell Language Extensions. + See [README.md](https://github.com/kowainik/extensions#extensions) for more details. +homepage: https://github.com/kowainik/extensions +bug-reports: https://github.com/kowainik/extensions/issues +license: MPL-2.0 +license-file: LICENSE +author: Veronika Romashkina, Dmitrii Kovanikov +maintainer: Kowainik +copyright: 2020 Kowainik +category: GHC, Parsing, Haskell +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.8.3 + GHC == 8.10.1 + +source-repository head + type: git + location: https://github.com/kowainik/extensions.git + +common common-options + build-depends: base >= 4.13.0.0 && < 4.15 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + if impl(ghc >= 8.10.1) + ghc-options: -Wunused-packages + + default-language: Haskell2010 + default-extensions: ConstraintKinds + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +library + import: common-options + hs-source-dirs: src + exposed-modules: Extensions + Extensions.Cabal + Extensions.Module + Extensions.Package + Extensions.Types + + build-depends: bytestring ^>= 0.10 + , Cabal >= 3.0 && < 3.3 + , containers ^>= 0.6 + , directory ^>= 1.3 + , filepath ^>= 1.4 + , ghc-boot-th >= 8.8.1 && < 8.11 + , parsec ^>= 3.1 + , text ^>= 1.2.3 + +executable extensions + import: common-options + hs-source-dirs: app + main-is: Main.hs + other-modules: Cli + build-depends: extensions + , base + , colourista ^>= 0.1.0.0 + , containers + , directory + , filepath + , optparse-applicative ^>= 0.15 + , text + +test-suite extensions-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Test.Extensions + Test.Extensions.Cabal + Test.Extensions.Module + Test.Extensions.Types + build-depends: extensions + , bytestring + , containers + , ghc-boot-th + , hedgehog ^>= 1.0 + , hspec + , hspec-hedgehog ^>= 0.0.1 + , text ^>= 1.2 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Extensions.hs b/src/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Extensions.hs @@ -0,0 +1,63 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Library to get Haskell Language Extensions from @.cabal@ files, Haskell Modules, +or get combined information from both sources preserving correct merge logic of +extensions. +-} + +module Extensions + ( -- $types + module Extensions.Types + -- $package + , module Extensions.Package + -- $cabal + , module Extensions.Cabal + -- $module + , module Extensions.Module + ) where + +import Extensions.Cabal +import Extensions.Module +import Extensions.Package +import Extensions.Types + +{- $types +Main data types to work with any kind of extensions and all possible errors +during the work of @extensions@ functions. + +To read more on Haskell Extensions, see the following documentation page: + + * [GHC Language Extensions](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html) + +In @extensions@ we support both @Haskell2010@ and @SafeHaskell@ +extensions. +-} + +{- $package +Main functions to get information of used extensions by combined information +from @.cabal@ files and Haskell modules. This module includes functions that +could work with file paths or file sources, these functions kindly combine +extensions information in a convenient way. However, there are functions that +return Cabal and Module information separately for specified modules. + +These functions use provided by "Extensions.Cabal" and "Extensions.Module" +functions to achieve that. +-} + +{- $cabal +Functions to extract extensions from the @.cabal@ files. + +Also, this module provides convenient functions for conversion of Cabal and GHC +extensions types. + +-} + +{- $module +Functions to extract extensions from the Haskell modules. + +Also, this module exports convenient internal parsing functions for Haskell +module extensions and necessary statements. +-} diff --git a/src/Extensions/Cabal.hs b/src/Extensions/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Extensions/Cabal.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE CPP #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Functions to extract extensions from the @.cabal@ files. +-} + +module Extensions.Cabal + ( parseCabalFileExtensions + , parseCabalExtensions + , extractCabalExtensions + + -- * Bridge between Cabal and GHC extensions + , cabalToGhcExtension + , toGhcExtension + , toSafeExtensions + ) where + +import Control.Exception (throwIO) +import Data.ByteString (ByteString) +import Data.Either (partitionEithers) +import Data.Foldable (toList) +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text (Text) +import Distribution.ModuleName (ModuleName (..), toFilePath) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) +import Distribution.Parsec.Error (PError, showPError) +import Distribution.Types.Benchmark (Benchmark (..)) +import Distribution.Types.BenchmarkInterface (BenchmarkInterface (..)) +import Distribution.Types.BuildInfo (BuildInfo (..)) +import Distribution.Types.CondTree (CondTree (..)) +import Distribution.Types.Executable (Executable (..)) +import Distribution.Types.ForeignLib (ForeignLib (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) +import Distribution.Types.Library (Library (..)) +import Distribution.Types.TestSuite (TestSuite (..)) +import Distribution.Types.TestSuiteInterface (TestSuiteInterface (..)) +import GHC.LanguageExtensions.Type (Extension (..)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), ()) + +import Extensions.Types (CabalException (..), OnOffExtension (..), ParsedExtensions (..), + SafeHaskellExtension (..)) + +import qualified Data.ByteString as ByteString +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Language.Haskell.Extension as Cabal + + +{- | Parse default extensions from a @.cabal@ file under given +'FilePath'. + +__Throws__: + +* 'CabalException' +-} +parseCabalFileExtensions :: FilePath -> IO (Map FilePath ParsedExtensions) +parseCabalFileExtensions cabalPath = doesFileExist cabalPath >>= \hasCabalFile -> + if hasCabalFile + then ByteString.readFile cabalPath >>= parseCabalExtensions cabalPath + else throwIO $ CabalFileNotFound cabalPath + +{- | Parse default extensions from a @.cabal@ file content. This +function takes a path to a @.cabal@ file. The path is only used for error +message. Pass empty string, if you don't have a path to @.cabal@ file. + +__Throws__: + +* 'CabalException' +-} +parseCabalExtensions :: FilePath -> ByteString -> IO (Map FilePath ParsedExtensions) +parseCabalExtensions path cabal = do + let (_warnings, res) = runParseResult $ parseGenericPackageDescription cabal + case res of + Left (_version, errors) -> + throwIO $ CabalParseError $ prettyCabalErrors errors + Right pkgDesc -> extractCabalExtensions pkgDesc + where + prettyCabalErrors :: Foldable f => f PError -> Text + prettyCabalErrors = Text.intercalate "\n" . map errorToText . toList + + errorToText :: PError -> Text + errorToText = Text.pack . showPError path + +{- | Extract Haskell Language extensions from a Cabal package +description. +-} +extractCabalExtensions :: GenericPackageDescription -> IO (Map FilePath ParsedExtensions) +extractCabalExtensions GenericPackageDescription{..} = mconcat + [ foldMap libraryToExtensions condLibrary + , foldSndMap libraryToExtensions condSubLibraries + , foldSndMap foreignToExtensions condForeignLibs + , foldSndMap exeToExtensions condExecutables + , foldSndMap testToExtensions condTestSuites + , foldSndMap benchToExtensions condBenchmarks + ] + where + foldSndMap :: Monoid m => (a -> m) -> [(b, a)] -> m + foldSndMap f = foldMap (f . snd) + + libraryToExtensions :: CondTree var deps Library -> IO (Map FilePath ParsedExtensions) + libraryToExtensions = condTreeToExtensions + (map toModulePath . exposedModules) + libBuildInfo + + foreignToExtensions :: CondTree var deps ForeignLib -> IO (Map FilePath ParsedExtensions) + foreignToExtensions = condTreeToExtensions (const []) foreignLibBuildInfo + + exeToExtensions :: CondTree var deps Executable -> IO (Map FilePath ParsedExtensions) + exeToExtensions = condTreeToExtensions (\Executable{..} -> [modulePath]) buildInfo + + testToExtensions :: CondTree var deps TestSuite -> IO (Map FilePath ParsedExtensions) + testToExtensions = condTreeToExtensions testMainPath testBuildInfo + where + testMainPath :: TestSuite -> [FilePath] + testMainPath TestSuite{..} = case testInterface of + TestSuiteExeV10 _ path -> [path] + TestSuiteLibV09 _ m -> [toModulePath m] + TestSuiteUnsupported _ -> [] + + benchToExtensions :: CondTree var deps Benchmark -> IO (Map FilePath ParsedExtensions) + benchToExtensions = condTreeToExtensions benchMainPath benchmarkBuildInfo + where + benchMainPath :: Benchmark -> [FilePath] + benchMainPath Benchmark{..} = case benchmarkInterface of + BenchmarkExeV10 _ path -> [path] + BenchmarkUnsupported _ -> [] + +condTreeToExtensions + :: (comp -> [FilePath]) + -- ^ Get all modules as file paths from a component, not listed in 'BuildInfo' + -> (comp -> BuildInfo) + -- ^ Extract 'BuildInfo' from component + -> CondTree var deps comp + -- ^ Cabal stanza + -> IO (Map FilePath ParsedExtensions) +condTreeToExtensions extractModules extractBuildInfo condTree = do + let comp = condTreeData condTree + let buildInfo = extractBuildInfo comp + let srcDirs = hsSourceDirs buildInfo + let modules = extractModules comp ++ + map toModulePath (otherModules buildInfo ++ autogenModules buildInfo) + let (safeExts, parsedExtensionsAll) = partitionEithers $ mapMaybe cabalToGhcExtension $ defaultExtensions buildInfo + parsedExtensionsSafe <- case nub safeExts of + [] -> pure Nothing + [x] -> pure $ Just x + x:xs -> throwIO $ CabalSafeExtensionsConflict $ x :| xs + + modulesToExtensions ParsedExtensions{..} srcDirs modules + +modulesToExtensions + :: ParsedExtensions + -- ^ List of default extensions in the stanza + -> [FilePath] + -- ^ hs-src-dirs + -> [FilePath] + -- ^ All modules in the stanza + -> IO (Map FilePath ParsedExtensions) +modulesToExtensions extensions srcDirs = case srcDirs of + [] -> findTopLevel + _ -> findInDirs [] + where + mapFromPaths :: [FilePath] -> Map FilePath ParsedExtensions + mapFromPaths = Map.fromList . map (, extensions) + + findInDirs :: [FilePath] -> [FilePath] -> IO (Map FilePath ParsedExtensions) + findInDirs res [] = pure $ mapFromPaths res + findInDirs res (m:ms) = findDir m srcDirs >>= \case + Nothing -> findInDirs res ms + Just modulePath -> findInDirs (modulePath : res) ms + + findTopLevel :: [FilePath] -> IO (Map FilePath ParsedExtensions) + findTopLevel modules = do + mPaths <- traverse (withDir Nothing) modules + pure $ mapFromPaths $ catMaybes mPaths + + -- Find directory where path exists and return full path + findDir :: FilePath -> [FilePath] -> IO (Maybe FilePath) + findDir modulePath = \case + [] -> pure Nothing + dir:dirs -> withDir (Just dir) modulePath >>= \case + Nothing -> findDir modulePath dirs + Just path -> pure $ Just path + + -- returns path if it exists inside optional dir + withDir :: Maybe FilePath -> FilePath -> IO (Maybe FilePath) + withDir mDir path = do + let fullPath = maybe path (\dir -> dir path) mDir + doesFileExist fullPath >>= \isFile -> + if isFile + then pure $ Just fullPath + else pure Nothing + +toModulePath :: ModuleName -> FilePath +toModulePath moduleName = toFilePath moduleName <.> "hs" + +-- | Convert 'Cabal.Extension' to 'OnOffExtension' or 'SafeHaskellExtension'. +cabalToGhcExtension :: Cabal.Extension -> Maybe (Either SafeHaskellExtension OnOffExtension) +cabalToGhcExtension = \case + Cabal.EnableExtension extension -> case (toGhcExtension extension, toSafeExtensions extension) of + (Nothing, safe) -> Left <$> safe + (ghc, _) -> Right . On <$> ghc + Cabal.DisableExtension extension -> Right . Off <$> toGhcExtension extension + Cabal.UnknownExtension _ -> Nothing + +-- | Convert 'Cabal.KnownExtension' to 'OnOffExtension'. +toGhcExtension :: Cabal.KnownExtension -> Maybe Extension +toGhcExtension = \case + Cabal.OverlappingInstances -> Just OverlappingInstances + Cabal.UndecidableInstances -> Just UndecidableInstances + Cabal.IncoherentInstances -> Just IncoherentInstances + Cabal.DoRec -> Just RecursiveDo + Cabal.RecursiveDo -> Just RecursiveDo + Cabal.ParallelListComp -> Just ParallelListComp + Cabal.MultiParamTypeClasses -> Just MultiParamTypeClasses + Cabal.MonomorphismRestriction -> Just MonomorphismRestriction + Cabal.FunctionalDependencies -> Just FunctionalDependencies + Cabal.Rank2Types -> Just RankNTypes + Cabal.RankNTypes -> Just RankNTypes + Cabal.PolymorphicComponents -> Just RankNTypes + Cabal.ExistentialQuantification -> Just ExistentialQuantification + Cabal.ScopedTypeVariables -> Just ScopedTypeVariables + Cabal.PatternSignatures -> Just ScopedTypeVariables + Cabal.ImplicitParams -> Just ImplicitParams + Cabal.FlexibleContexts -> Just FlexibleContexts + Cabal.FlexibleInstances -> Just FlexibleInstances + Cabal.EmptyDataDecls -> Just EmptyDataDecls + Cabal.CPP -> Just Cpp + Cabal.KindSignatures -> Just KindSignatures + Cabal.BangPatterns -> Just BangPatterns + Cabal.TypeSynonymInstances -> Just TypeSynonymInstances + Cabal.TemplateHaskell -> Just TemplateHaskell + Cabal.ForeignFunctionInterface -> Just ForeignFunctionInterface + Cabal.Arrows -> Just Arrows + Cabal.ImplicitPrelude -> Just ImplicitPrelude + Cabal.PatternGuards -> Just PatternGuards + Cabal.GeneralizedNewtypeDeriving -> Just GeneralizedNewtypeDeriving + Cabal.GeneralisedNewtypeDeriving -> Just GeneralizedNewtypeDeriving + Cabal.MagicHash -> Just MagicHash + Cabal.TypeFamilies -> Just TypeFamilies + Cabal.StandaloneDeriving -> Just StandaloneDeriving + Cabal.UnicodeSyntax -> Just UnicodeSyntax + Cabal.UnliftedFFITypes -> Just UnliftedFFITypes + Cabal.InterruptibleFFI -> Just InterruptibleFFI + Cabal.CApiFFI -> Just CApiFFI + Cabal.LiberalTypeSynonyms -> Just LiberalTypeSynonyms + Cabal.TypeOperators -> Just TypeOperators + Cabal.RecordWildCards -> Just RecordWildCards + Cabal.RecordPuns -> Just RecordPuns + Cabal.NamedFieldPuns -> Just RecordPuns + Cabal.DisambiguateRecordFields -> Just DisambiguateRecordFields + Cabal.TraditionalRecordSyntax -> Just TraditionalRecordSyntax + Cabal.OverloadedStrings -> Just OverloadedStrings + Cabal.GADTs -> Just GADTs + Cabal.GADTSyntax -> Just GADTSyntax + Cabal.RelaxedPolyRec -> Just RelaxedPolyRec + Cabal.ExtendedDefaultRules -> Just ExtendedDefaultRules + Cabal.UnboxedTuples -> Just UnboxedTuples + Cabal.DeriveDataTypeable -> Just DeriveDataTypeable + Cabal.AutoDeriveTypeable -> Just DeriveDataTypeable + Cabal.DeriveGeneric -> Just DeriveGeneric + Cabal.DefaultSignatures -> Just DefaultSignatures + Cabal.InstanceSigs -> Just InstanceSigs + Cabal.ConstrainedClassMethods -> Just ConstrainedClassMethods + Cabal.PackageImports -> Just PackageImports + Cabal.ImpredicativeTypes -> Just ImpredicativeTypes + Cabal.PostfixOperators -> Just PostfixOperators + Cabal.QuasiQuotes -> Just QuasiQuotes + Cabal.TransformListComp -> Just TransformListComp + Cabal.MonadComprehensions -> Just MonadComprehensions + Cabal.ViewPatterns -> Just ViewPatterns + Cabal.TupleSections -> Just TupleSections + Cabal.GHCForeignImportPrim -> Just GHCForeignImportPrim + Cabal.NPlusKPatterns -> Just NPlusKPatterns + Cabal.DoAndIfThenElse -> Just DoAndIfThenElse + Cabal.MultiWayIf -> Just MultiWayIf + Cabal.LambdaCase -> Just LambdaCase + Cabal.RebindableSyntax -> Just RebindableSyntax + Cabal.ExplicitForAll -> Just ExplicitForAll + Cabal.DatatypeContexts -> Just DatatypeContexts + Cabal.MonoLocalBinds -> Just MonoLocalBinds + Cabal.DeriveFunctor -> Just DeriveFunctor + Cabal.DeriveTraversable -> Just DeriveTraversable + Cabal.DeriveFoldable -> Just DeriveFoldable + Cabal.NondecreasingIndentation -> Just NondecreasingIndentation + Cabal.ConstraintKinds -> Just ConstraintKinds + Cabal.PolyKinds -> Just PolyKinds + Cabal.DataKinds -> Just DataKinds + Cabal.ParallelArrays -> Just ParallelArrays + Cabal.RoleAnnotations -> Just RoleAnnotations + Cabal.OverloadedLists -> Just OverloadedLists + Cabal.EmptyCase -> Just EmptyCase + Cabal.NegativeLiterals -> Just NegativeLiterals + Cabal.BinaryLiterals -> Just BinaryLiterals + Cabal.NumDecimals -> Just NumDecimals + Cabal.NullaryTypeClasses -> Just NullaryTypeClasses + Cabal.ExplicitNamespaces -> Just ExplicitNamespaces + Cabal.AllowAmbiguousTypes -> Just AllowAmbiguousTypes + Cabal.JavaScriptFFI -> Just JavaScriptFFI + Cabal.PatternSynonyms -> Just PatternSynonyms + Cabal.PartialTypeSignatures -> Just PartialTypeSignatures + Cabal.NamedWildCards -> Just NamedWildCards + Cabal.DeriveAnyClass -> Just DeriveAnyClass + Cabal.DeriveLift -> Just DeriveLift + Cabal.StaticPointers -> Just StaticPointers + Cabal.StrictData -> Just StrictData + Cabal.Strict -> Just Strict + Cabal.ApplicativeDo -> Just ApplicativeDo + Cabal.DuplicateRecordFields -> Just DuplicateRecordFields + Cabal.TypeApplications -> Just TypeApplications + Cabal.TypeInType -> Just TypeInType + Cabal.UndecidableSuperClasses -> Just UndecidableSuperClasses + Cabal.MonadFailDesugaring -> Just MonadFailDesugaring + Cabal.TemplateHaskellQuotes -> Just TemplateHaskellQuotes + Cabal.OverloadedLabels -> Just OverloadedLabels + Cabal.TypeFamilyDependencies -> Just TypeFamilyDependencies + Cabal.DerivingStrategies -> Just DerivingStrategies + Cabal.DerivingVia -> Just DerivingVia + Cabal.UnboxedSums -> Just UnboxedSums + Cabal.HexFloatLiterals -> Just HexFloatLiterals + Cabal.BlockArguments -> Just BlockArguments + Cabal.NumericUnderscores -> Just NumericUnderscores + Cabal.QuantifiedConstraints -> Just QuantifiedConstraints + Cabal.StarIsType -> Just StarIsType + Cabal.EmptyDataDeriving -> Just EmptyDataDeriving +#if __GLASGOW_HASKELL__ >= 810 + Cabal.CUSKs -> Just CUSKs + Cabal.ImportQualifiedPost -> Just ImportQualifiedPost + Cabal.StandaloneKindSignatures -> Just StandaloneKindSignatures + Cabal.UnliftedNewtypes -> Just UnliftedNewtypes +#endif + -- GHC extensions, parsed by both Cabal and GHC, but don't have an Extension constructor + Cabal.Safe -> Nothing + Cabal.Trustworthy -> Nothing + Cabal.Unsafe -> Nothing + -- non-GHC extensions + Cabal.Generics -> Nothing + Cabal.ExtensibleRecords -> Nothing + Cabal.RestrictedTypeSynonyms -> Nothing + Cabal.HereDocuments -> Nothing + Cabal.MonoPatBinds -> Nothing + Cabal.XmlSyntax -> Nothing + Cabal.RegularPatterns -> Nothing + Cabal.SafeImports -> Nothing + Cabal.NewQualifiedOperators -> Nothing + +-- | Convert 'Cabal.KnownExtension' to 'SafeHaskellExtension'. +toSafeExtensions :: Cabal.KnownExtension -> Maybe SafeHaskellExtension +toSafeExtensions = \case + Cabal.Safe -> Just Safe + Cabal.Trustworthy -> Just Trustworthy + Cabal.Unsafe -> Just Unsafe + _ -> Nothing diff --git a/src/Extensions/Module.hs b/src/Extensions/Module.hs new file mode 100644 --- /dev/null +++ b/src/Extensions/Module.hs @@ -0,0 +1,214 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Parser for Haskell Modules to get all Haskell Language Extensions used. +-} + +module Extensions.Module + ( parseFile + , parseSource + , parseSourceWithPath + + -- * Internal Parsers + , extensionsP + , singleExtensionsP + , extensionP + , languagePragmaP + , optionsGhcP + , pragmaP + , commentP + , cppP + ) where + +import Data.ByteString (ByteString) +import Data.Char (toLower, toUpper) +import Data.Either (partitionEithers) +import Data.Foldable (traverse_) +import Data.Functor ((<&>)) +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import System.Directory (doesFileExist) +import Text.Parsec (alphaNum, between, char, eof, many, many1, manyTill, noneOf, oneOf, parse, + sepBy1, try, (<|>)) +import Text.Parsec.ByteString (Parser) +import Text.Parsec.Char (anyChar, endOfLine, letter, newline, space, spaces, string) +import Text.Read (readMaybe) + +import Extensions.Types (ModuleParseError (..), OnOffExtension (..), ParsedExtensions (..), + SafeHaskellExtension (..), readOnOffExtension) + +import qualified Data.ByteString as BS + + +-- | Internal data type for known and unknown extensions. +data ParsedExtension + = KnownExtension OnOffExtension + | SafeExtension SafeHaskellExtension + | UnknownExtension String + +handleParsedExtensions :: [ParsedExtension] -> Either ModuleParseError ParsedExtensions +handleParsedExtensions = handleResult . partitionEithers . map toEither + where + toEither :: ParsedExtension -> Either String (Either SafeHaskellExtension OnOffExtension) + toEither (UnknownExtension ext) = Left ext + toEither (KnownExtension ext) = Right $ Right ext + toEither (SafeExtension ext) = Right $ Left ext + + -- Make sure that there is no conflicting 'SafeHaskellExtension's. + handleResult + :: ([String], [Either SafeHaskellExtension OnOffExtension]) + -> Either ModuleParseError ParsedExtensions + handleResult (unknown, knownAndSafe) = case unknown of + [] -> let (safe, known) = partitionEithers knownAndSafe in case nub safe of + [] -> Right ParsedExtensions + { parsedExtensionsAll = known + , parsedExtensionsSafe = Nothing + } + [s] -> Right ParsedExtensions + { parsedExtensionsAll = known + , parsedExtensionsSafe = Just s + } + s:ss -> Left $ ModuleSafeHaskellConflict $ s :| ss + x:xs -> Left $ UnknownExtensions $ x :| xs + +{- | By the given file path, reads the file and returns 'ParsedExtensions', if +parsing succeeds. +-} +parseFile :: FilePath -> IO (Either ModuleParseError ParsedExtensions) +parseFile file = doesFileExist file >>= \hasFile -> + if hasFile + then parseSourceWithPath file <$> BS.readFile file + else pure $ Left $ FileNotFound file + +{- | By the given file path and file source content, returns 'ParsedExtensions', +if parsing succeeds. + +This function takes a path to a Haskell source file. The path is only used for +error message. Pass empty string or use 'parseSource', if you don't have a path +to a Haskell module. +-} +parseSourceWithPath :: FilePath -> ByteString -> Either ModuleParseError ParsedExtensions +parseSourceWithPath path src = case parse extensionsP path src of + Left err -> Left $ ParsecError err + Right parsedExts -> handleParsedExtensions parsedExts + +{- | By the given file source content, returns 'ParsedExtensions', if parsing +succeeds. +-} +parseSource :: ByteString -> Either ModuleParseError ParsedExtensions +parseSource = parseSourceWithPath "SourceName" + +{- | The main parser of 'ParsedExtension'. + +It parses language pragmas or comments until end of file or the first line with +the function/import/module name. +-} +extensionsP :: Parser [ParsedExtension] +extensionsP = concat <$> manyTill + (try singleExtensionsP <|> try optionsGhcP <|> try commentP <|> try cppP) + (eof <|> (() <$ manyTill endOfLine letter)) + +{- | Single LANGUAGE pragma parser. + +@ + \{\-# LANGUAGE XXX + , YYY , + ZZZ + #\-\} +@ +-} +singleExtensionsP :: Parser [ParsedExtension] +singleExtensionsP = + languagePragmaP (commaSep (nonExtP *> extensionP <* nonExtP) <* spaces) + where + nonExtP :: Parser () + nonExtP = () <$ many (try cppP <|> try commentP) + +{- | Parses all known and unknown 'OnOffExtension's or 'SafeHaskellExtension's. +-} +extensionP :: Parser ParsedExtension +extensionP = (spaces *> many1 alphaNum <* spaces) <&> \txt -> + case readOnOffExtension txt of + Just ext -> KnownExtension ext + Nothing -> case readMaybe @SafeHaskellExtension txt of + Just ext -> SafeExtension ext + Nothing -> UnknownExtension txt + +{- | Parser for standard language pragma keywords: @\{\-\# LANGUAGE XXX \#\-\}@ +-} +languagePragmaP :: Parser a -> Parser a +languagePragmaP = pragmaP $ istringP "LANGUAGE" + +{- | Parser for GHC options pragma keywords: @\{\-\# OPTIONS_GHC YYY \#\-\}@ +-} +optionsGhcP :: Parser [a] +optionsGhcP = [] <$ optionsGhcPragmaP (many1 ghcOptionP) + where + ghcOptionP :: Parser String + ghcOptionP = newLines *> many1 (alphaNum <|> char '-') <* newLines + +optionsGhcPragmaP :: Parser a -> Parser a +optionsGhcPragmaP = pragmaP $ istringP "OPTIONS_GHC" + +-- | Parser for case-insensitive strings. +istringP :: String -> Parser () +istringP = traverse_ $ \c -> oneOf [toUpper c, toLower c] + +{- | Parser for GHC pragmas with a given pragma word. +-} +pragmaP :: Parser () -> Parser a -> Parser a +pragmaP pragmaNameP p = between + (string "{-#") (string "#-}" <* newLines) + (newLines *> pragmaNameP *> newLines *> p <* newLines) + +-- | Comma separated parser. Newlines and spaces are allowed around comma. +commaSep :: Parser a -> Parser [a] +commaSep p = p `sepBy1` (try $ newLines *> char ',' <* newLines) + +{- | Haskell comment parser. +Supports both single-line comments: + + @ + -- I am a single comment + @ + +and multi-line comments: + + @ + \{\- I + AM + MULTILINE + \-\} + @ +-} +commentP :: Parser [a] +commentP = newLines *> (try singleLineCommentP <|> try multiLineCommentP) <* newLines + where + singleLineCommentP :: Parser [a] + singleLineCommentP = [] <$ + (string "--" *> manyTill anyChar (try (() <$ endOfLine) <|> eof)) + + multiLineCommentP :: Parser [a] + multiLineCommentP = [] <$ + (string "{-" *> manyTill anyChar (try $ string "-}")) + +{- | CPP syntax parser. + + @ + #if \_\_GLASGOW_HASKELL\_\_ < 810 + -- Could be more Language pragmas that should be parsed + #endif + @ +-} +cppP :: Parser [a] +cppP = + [] <$ many newline + <* try (char '#' <* noneOf "-") + <* manyTill anyChar (try endOfLine) + <* newLines + +-- | Any combination of spaces and newlines. +newLines :: Parser () +newLines = () <$ many (space <|> endOfLine) diff --git a/src/Extensions/Package.hs b/src/Extensions/Package.hs new file mode 100644 --- /dev/null +++ b/src/Extensions/Package.hs @@ -0,0 +1,189 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Parse Haskell Language Extensions. +-} + +module Extensions.Package + ( -- * Package modules + getPackageExtentions + , getPackageExtentionsBySources + + -- * Single module + , getModuleAndCabalExtentions + , getModuleExtentions + , getModuleAndCabalExtentionsBySource + , getModuleExtentionsBySource + ) where + +import Control.Exception (catch) +import Data.ByteString (ByteString) +import Data.Functor ((<&>)) +import Data.Map.Merge.Strict (mapMissing, merge, zipWithMatched) +import Data.Map.Strict (Map) + +import Extensions.Cabal (parseCabalFileExtensions) +import Extensions.Module (parseFile, parseSourceWithPath) +import Extensions.Types (CabalAndModuleExtensions (..), CabalException, ExtensionsError (..), + ExtensionsResult, ModuleParseError, ParsedExtensions (..), + mergeAnyExtensions) + +import qualified Data.Map.Strict as Map + + +{- | By given path to @.cabal@ file, analyse extensions for each Haskell module +and return the corresponding 'Map' with 'ExtensionsResult's. + +__Throws__: + +* 'CabalException' +-} +getPackageExtentions + :: FilePath -- ^ Path to @.cabal@ file. + -> IO (Map FilePath ExtensionsResult) +getPackageExtentions cabalFile = do + cabalMap <- parseCabalFileExtensions cabalFile + Map.traverseWithKey perModuleParseMerge cabalMap + where + perModuleParseMerge :: FilePath -> ParsedExtensions -> IO ExtensionsResult + perModuleParseMerge path cabalExts = do + moduleRes <- parseFile path + pure $ mergeCabalAndModule cabalExts path moduleRes + +{- | By given path to @.cabal@ file and 'Map' of sources of all Haskell +modules, analyse extensions for each Haskell module and return the corresponding +'Map' with 'ExtensionsResult's. +-} +getPackageExtentionsBySources + :: FilePath -- ^ Path to @.cabal@ file. + -> Map FilePath ByteString -- ^ Path to modules with corresponding sources. + -> IO (Map FilePath ExtensionsResult) +getPackageExtentionsBySources cabalFile sourcesMap = + parseCabalHandleException cabalFile <&> \case + Left err -> Left err <$ sourcesMap + Right cabalMap -> merge + (mapMissing cabalNotSource) -- in cabal but not in sources + (mapMissing sourceNotCabal) -- in sources but not in cabal + (zipWithMatched cabalAndSource) -- in cabal and sources + cabalMap + sourcesMap + where + cabalNotSource :: FilePath -> ParsedExtensions -> ExtensionsResult + cabalNotSource path _cabalExts = Left $ SourceNotFound path + + sourceNotCabal :: FilePath -> ByteString -> ExtensionsResult + sourceNotCabal path _source = Left $ NotCabalModule path + + cabalAndSource + :: FilePath + -> ParsedExtensions + -> ByteString + -> ExtensionsResult + cabalAndSource path cabalExts source = + mergeCabalAndModule cabalExts path $ parseSourceWithPath path source + +{- | By given path to @.cabal@ file and path to Haskell module of the +corresponding package, analyse and return extensions for the +given module separately from .cabal file and from the module itself. +-} +getModuleAndCabalExtentions + :: FilePath -- ^ Path to @.cabal@ file. + -> FilePath -- ^ Path to Haskell module file. + -> IO (Either ExtensionsError CabalAndModuleExtensions) +getModuleAndCabalExtentions cabalFile path = + parseCabalHandleException cabalFile >>= \case + Left err -> pure $ Left err + Right cabalMap -> case Map.lookup path cabalMap of + Nothing -> pure $ Left $ NotCabalModule path + Just cabalExts -> getCabalAndModuleExts path cabalExts <$> parseFile path + +{- | By given path to @.cabal@ file and path to Haskell module of the +corresponding package, analyse and return summary set of extensions for the +given module. +-} +getModuleExtentions + :: FilePath -- ^ Path to @.cabal@ file. + -> FilePath -- ^ Path to Haskell module file. + -> IO ExtensionsResult +getModuleExtentions cabalFile path = + parseCabalHandleException cabalFile >>= \case + Left err -> pure $ Left err + Right cabalMap -> case Map.lookup path cabalMap of + Nothing -> pure $ Left $ NotCabalModule path + Just cabalExts -> do + moduleRes <- parseFile path + pure $ mergeCabalAndModule cabalExts path moduleRes + +{- | By given path to @.cabal@ file and path to Haskell module of the +corresponding package, analyse and return extensions extensions for the +given module separately from .cabal file and from the module itself. +-} +getModuleAndCabalExtentionsBySource + :: FilePath -- ^ Maybe path to @.cabal@ file. + -> FilePath -- ^ Path to the module's source (needed for matching with cabal file). + -> ByteString -- ^ Source of a Haskell module file. + -> IO (Either ExtensionsError CabalAndModuleExtensions) +getModuleAndCabalExtentionsBySource cabalFile path source = + parseCabalHandleException cabalFile <&> \case + Left cabalError -> Left cabalError + Right cabalMap -> case Map.lookup path cabalMap of + Nothing -> Left $ NotCabalModule path + Just cabalExts -> getCabalAndModuleExts path cabalExts + (parseSourceWithPath path source) + +{- | By given path to @.cabal@ file and path to Haskell module of the +corresponding package, analyse and return combined set of extensions for the +given module. +-} +getModuleExtentionsBySource + :: FilePath -- ^ Maybe path to @.cabal@ file. + -> FilePath -- ^ Path to the module's source (needed for matching with cabal file). + -> ByteString -- ^ Source of a Haskell module file. + -> IO ExtensionsResult +getModuleExtentionsBySource cabalFile path source = + parseCabalHandleException cabalFile <&> \case + Left cabalError -> Left cabalError + Right cabalMap -> case Map.lookup path cabalMap of + Nothing -> Left $ NotCabalModule path + Just cabalExts -> mergeCabalAndModule cabalExts path + (parseSourceWithPath path source) + +---------------------------------------------------------------------------- +-- Internal helpers +---------------------------------------------------------------------------- + +mergeCabalAndModule + :: ParsedExtensions + -> FilePath + -> Either ModuleParseError ParsedExtensions + -> ExtensionsResult +mergeCabalAndModule cabalExts path moduleRes = case moduleRes of + Right moduleExts -> mergeAnyExtensions cabalExts moduleExts + Left parseErr -> Left $ ModuleParseError path parseErr + +-- | 'parseCabalFileExtensions' with 'handleCabalException'. +parseCabalHandleException + :: FilePath + -> IO (Either ExtensionsError (Map FilePath ParsedExtensions)) +parseCabalHandleException cabalFile = (Right <$> parseCabalFileExtensions cabalFile) + `catch` handleCabalException + +-- | Handle 'CabalException' and return corresponding 'CabalError'. +handleCabalException + :: CabalException + -> IO (Either ExtensionsError (Map FilePath ParsedExtensions)) +handleCabalException = pure . Left . CabalError + +getCabalAndModuleExts + :: FilePath + -> ParsedExtensions + -> Either ModuleParseError ParsedExtensions + -> Either ExtensionsError CabalAndModuleExtensions +getCabalAndModuleExts path cabalExts moduleRes = case moduleRes of + Left err -> Left $ ModuleParseError path err + Right moduleExts -> Right $ CabalAndModuleExtensions + { cabalExtensions = cabalExts + , moduleExtensions = moduleExts + } diff --git a/src/Extensions/Types.hs b/src/Extensions/Types.hs new file mode 100644 --- /dev/null +++ b/src/Extensions/Types.hs @@ -0,0 +1,270 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DeriveAnyClass #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Data types and functions to work with different types of 'Extension's. + +@extensions@ library supports the following types of extensions: + + +-------------------------------------------+----------------------------+ + | @Haskell2010@ Default Enabled Extensions | 'On' of 'OnOffExtension's | + +-------------------------------------------+----------------------------+ + | @Haskell2010@ Default Disabled Extensions | 'Off' of 'OnOffExtension's | + +-------------------------------------------+----------------------------+ + | @SafeHaskell@ Extensions | 'SafeHaskellExtension's | + +-------------------------------------------+----------------------------+ + +-} + +module Extensions.Types + ( Extensions (..) + , ParsedExtensions (..) + , CabalAndModuleExtensions (..) + , ExtensionsResult + + -- * Errors + , ExtensionsError (..) + , CabalException (..) + , ModuleParseError (..) + + -- ** Defaults / empty data types + , emptyExtensions + , emptyParsedExtensions + + -- * Enabled/Disabled Haskell2010 Extensions + , OnOffExtension (..) + , showOnOffExtension + , readOnOffExtension + , readExtension + , mergeExtensions + , mergeAnyExtensions + , default2010Extensions + + -- * Safe Haskell Extensions + , SafeHaskellExtension (..) + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (Exception) +import Data.Foldable (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set (Set) +import Data.Text (Text) +import GHC.LanguageExtensions.Type (Extension (..)) +import Text.Read (readMaybe) + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Text.Parsec as Parsec + + +{- | Main returned data type that includes merged 'OnOffExtension's and possibly +one 'SafeHaskellExtension'. +-} +data Extensions = Extensions + { extensionsAll :: !(Set OnOffExtension) + , extensionsSafe :: !(Maybe SafeHaskellExtension) + } deriving stock (Show, Eq) + +{- | Extensions that are collected in the result of parsing @.cabal@ file or +Haskell module (both 'OnOffExtension' and possibly one 'SafeHaskellExtension'). + +'OnOffExtension's are not necessary unique. They reflect exactly the extensions +found during parsing. +-} +data ParsedExtensions = ParsedExtensions + { parsedExtensionsAll :: ![OnOffExtension] + , parsedExtensionsSafe :: !(Maybe SafeHaskellExtension) + } deriving stock (Show, Eq) + +-- | Stores extensions from @.cabal@ file and module separately. +data CabalAndModuleExtensions = CabalAndModuleExtensions + { cabalExtensions :: !ParsedExtensions + , moduleExtensions :: !ParsedExtensions + } deriving stock (Show, Eq) + +-- | Type alias for the result of extensions analysis. +type ExtensionsResult = Either ExtensionsError Extensions + +-- | Represents possible errors during the work of extensions analyser. +data ExtensionsError + -- | Parse error during module extensions parsing. + = ModuleParseError FilePath ModuleParseError + -- | Error during @.cabal@ file reading/parsing. + | CabalError CabalException + -- | File is in cabal file, but the source file is not provided where requested. + | SourceNotFound FilePath + -- | Source file is provided, but module is not in cabal file. + | NotCabalModule FilePath + -- | Conflicting 'SafeHaskellExtension's in one scope. + | SafeHaskellConflict (NonEmpty SafeHaskellExtension) + deriving stock (Show, Eq) + +{- | Exception that gets thrown when working with @.cabal@ files. +-} +data CabalException + -- | The @.cabal@ file is not found. + = CabalFileNotFound FilePath + -- | Parsing errors in the @.cabal@ file. + | CabalParseError Text + -- | Conflicting 'SafeHaskellExtension's in one scope. + | CabalSafeExtensionsConflict (NonEmpty SafeHaskellExtension) + deriving stock (Show, Eq) + deriving anyclass (Exception) + +-- | Error while parsing Haskell source file. +data ModuleParseError + -- | File parsing error. + = ParsecError Parsec.ParseError + -- | Uknown extensions were used in the module. + | UnknownExtensions (NonEmpty String) + -- | Conflicting 'SafeHaskellExtension's in one scope. + | ModuleSafeHaskellConflict (NonEmpty SafeHaskellExtension) + -- | Module file not found. + | FileNotFound FilePath + deriving stock (Show, Eq) + + +-- | Empty 'Extensions' with no specified 'SafeHaskellExtension'. +emptyExtensions :: Extensions +emptyExtensions = Extensions + { extensionsAll = mempty + , extensionsSafe = Nothing + } + +-- | Empty 'ParsedExtensions' with no specified 'SafeHaskellExtension'. +emptyParsedExtensions :: ParsedExtensions +emptyParsedExtensions = ParsedExtensions + { parsedExtensionsAll = [] + , parsedExtensionsSafe = Nothing + } + +{- | Language extensions that are used by Safe Haskell to indicate safety of the +code. + +To find out more, checkout the official documentation on @SafeHaskell@: + + * [Safe Language Pragmas](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html#safe-haskell) +-} +data SafeHaskellExtension + = Unsafe + | Trustworthy + | Safe + deriving stock (Show, Read, Eq, Ord, Enum, Bounded) + +-- | Represents enabled/disabled extensions. +data OnOffExtension + = On Extension + | Off Extension + deriving stock (Show, Eq, Ord) + +-- | Display 'OnOffExtension' as GHC recognizes it. +showOnOffExtension :: OnOffExtension -> Text +showOnOffExtension = \case + On ext -> showExtension ext + Off ext -> "No" <> showExtension ext + where + showExtension :: Extension -> Text + showExtension = \case + Cpp -> "CPP" + RecordPuns -> "NamedFieldPuns" + ext -> Text.pack $ show ext + +{- | Parse 'OnOffExtension' from a string that specifies extension. +-} +readOnOffExtension :: String -> Maybe OnOffExtension +readOnOffExtension s = + (On <$> readExtension s) <|> (Off <$> readOffExtension) + where + readOffExtension :: Maybe Extension + readOffExtension = do + ("No", ext) <- Just $ splitAt 2 s + readExtension ext + +{- | Parse 'Extension' from a string. 'Read' instance for 'Extension' +doesn't always work since some extensions are named differently. +-} +readExtension :: String -> Maybe Extension +readExtension = \case + "GeneralisedNewtypeDeriving" -> Just GeneralizedNewtypeDeriving + "NamedFieldPuns" -> Just RecordPuns + "RecordPuns" -> Nothing + "Rank2Types" -> Just RankNTypes + "CPP" -> Just Cpp + "Cpp" -> Nothing + s -> readMaybe s + +{- | Take accumulated 'OnOffExtension's, and merge them into one 'Set', +excluding enabling of 'default2010Extensions'. + +If the default extension is enabled manually it still won't count as it doesn't +affect real behaviour. However, disabling of default extension will be included +in the list. + +So, basically, this set will only have 'On' extensions that are not defaults, +and 'Off' extensions of defaults. + +'foldl\'' is used in order to process them in the right order: first all cabal +extensions and then extensions from the module in the order of appearance. +-} +mergeExtensions :: [OnOffExtension] -> Set OnOffExtension +mergeExtensions = foldl' handleExt Set.empty + where + handleExt :: Set OnOffExtension -> OnOffExtension -> Set OnOffExtension + handleExt exts (On e) + | e `elem` default2010Extensions = Set.delete (Off e) exts + | otherwise = Set.insert (On e) exts + handleExt exts (Off e) + | e `elem` default2010Extensions = Set.insert (Off e) exts + | otherwise = Set.delete (On e) exts + +{- | Similar to 'mergeExtensions', but also merge 'SafeHaskellExtension's. +In case of conflicting 'SafeHaskellExtension' returns 'Left' with the pair of +conflicting extension constructors under 'SafeHaskellConflict' error. +-} +mergeAnyExtensions + :: ParsedExtensions -- ^ Cabal parsed extensions. + -> ParsedExtensions -- ^ Module parsed extensions. + -> ExtensionsResult +mergeAnyExtensions (ParsedExtensions exts1 safe1) (ParsedExtensions exts2 safe2) = case (safe1, safe2) of + (Nothing, safe) -> Right $ Extensions + { extensionsAll = mergedExts + , extensionsSafe = safe + } + (safe, Nothing) -> Right $ Extensions + { extensionsAll = mergedExts + , extensionsSafe = safe + } + (Just s1, Just s2) -> + if safe1 == safe2 + then Right $ Extensions + { extensionsAll = mergedExts + , extensionsSafe = safe1 + } + else Left $ SafeHaskellConflict $ s1 :| [s2] + where + mergedExts :: Set OnOffExtension + mergedExts = mergeExtensions (exts1 <> exts2) + +-- | Default enabled extensions for @Haskell2010@ +default2010Extensions :: [Extension] +default2010Extensions = + [ ImplicitPrelude + , StarIsType + , MonomorphismRestriction + , DatatypeContexts + , TraditionalRecordSyntax + , EmptyDataDecls + , ForeignFunctionInterface + , PatternGuards + , DoAndIfThenElse + , RelaxedPolyRec + ] + +deriving stock instance Read Extension +deriving stock instance Ord Extension diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Test.Hspec (hspec) + +import Test.Extensions (getExtensionsSpec) +import Test.Extensions.Cabal (cabalSpec) +import Test.Extensions.Module (moduleParserSpec) +import Test.Extensions.Types (onOffSpec) + + +main :: IO () +main = hspec $ do + onOffSpec + cabalSpec + moduleParserSpec + getExtensionsSpec diff --git a/test/Test/Extensions.hs b/test/Test/Extensions.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extensions.hs @@ -0,0 +1,98 @@ +module Test.Extensions + ( getExtensionsSpec + ) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import GHC.LanguageExtensions.Type (Extension (..)) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Extensions (getModuleExtentions, getModuleExtentionsBySource, getPackageExtentions, + getPackageExtentionsBySources) +import Extensions.Types (Extensions (..), ExtensionsError (..), ExtensionsResult, + OnOffExtension (..), ParsedExtensions (..)) +import Test.Extensions.Cabal (defaultExtensions) + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + + +getExtensionsSpec :: Spec +getExtensionsSpec = describe "Get Extensions" $ do + it "should getPackageExtensions" $ + getPackageExtentions cabal >>= \res -> res `shouldBe` resultMap + it "should getPackageExtensionsBySource" $ do + res <- sources >>= getPackageExtentionsBySources cabal + res `shouldBe` resultMap + it "should getPackageExtensionsBySource, return NonCabalModule" $ do + srcs <- sources + res <- getPackageExtentionsBySources cabal $ + Map.insert unknownModule "Hello" srcs + res `shouldBe` Map.insert unknownModule (Left $ NotCabalModule unknownModule) resultMap + it "should getPackageExtensionsBySource, return SourceNotFound" $ do + srcs <- sources + res <- getPackageExtentionsBySources cabal $ + Map.delete knownModule srcs + res `shouldBe` Map.insert knownModule (Left $ SourceNotFound knownModule) resultMap + it "should getModuleExtensions" $ do + res <- getModuleExtentions cabal knownModule + res `shouldBe` Right exts + it "should getModuleExtensions, return NotCabalModule" $ do + res <- getModuleExtentions cabal unknownModule + res `shouldBe` Left (NotCabalModule unknownModule) + it "should getModuleExtensionsBySource" $ do + res <- knownSource >>= getModuleExtentionsBySource cabal knownModule + res `shouldBe` Right exts + it "should getModuleExtensions, return NotCabalModule" $ do + res <- getModuleExtentionsBySource cabal unknownModule "Hello" + res `shouldBe` Left (NotCabalModule unknownModule) + +resultMap :: Map FilePath ExtensionsResult +resultMap = Map.fromList + [ "app/Cli.hs" `to` Right + (extsPlus $ Set.singleton (On ApplicativeDo)) + , "app/Main.hs" `to` Right exts + , "src/Extensions.hs" `to` Right exts + , "src/Extensions/Cabal.hs" `to` Right + (extsPlus $ Set.singleton $ On Cpp ) + , "src/Extensions/Module.hs" `to` Right exts + , "src/Extensions/Package.hs" `to` Right exts + , "src/Extensions/Types.hs" `to` Right + (extsPlus $ Set.singleton $ On DeriveAnyClass ) + , "test/Test/Extensions.hs" `to` Right exts + , "test/Test/Extensions/Cabal.hs" `to` Right exts + , "test/Test/Extensions/Module.hs" `to` Right exts + , "test/Test/Extensions/Types.hs" `to` Right exts + , "test/Spec.hs" `to` Right exts + ] + where + to = (,) + +exts :: Extensions +exts = Extensions + { extensionsAll = Set.fromList $ parsedExtensionsAll defaultExtensions + , extensionsSafe = Nothing + } + +extsPlus :: Set OnOffExtension -> Extensions +extsPlus s = exts + { extensionsAll = extensionsAll exts <> s + } + +sources :: IO (Map FilePath ByteString) +sources = Map.traverseWithKey (\f _ -> BS.readFile f) resultMap + +cabal :: FilePath +cabal = "extensions.cabal" + +unknownModule :: FilePath +unknownModule = "src/Unknown.hs" + +knownModule :: FilePath +knownModule = "src/Extensions.hs" + +knownSource :: IO ByteString +knownSource = fromMaybe "" . Map.lookup knownModule <$> sources diff --git a/test/Test/Extensions/Cabal.hs b/test/Test/Extensions/Cabal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extensions/Cabal.hs @@ -0,0 +1,229 @@ +module Test.Extensions.Cabal + ( cabalSpec + , defaultExtensions + ) where + +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import GHC.LanguageExtensions.Type (Extension (..)) +import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow) + +import Extensions.Cabal (parseCabalExtensions, parseCabalFileExtensions) +import Extensions.Types (CabalException (..), OnOffExtension (..), ParsedExtensions (..), + SafeHaskellExtension (..), emptyParsedExtensions) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + + +cabalSpec :: Spec +cabalSpec = describe "Cabal file Extensions Parser" $ do + it "should throw the 'CabalFileNotFound' exception on non-existing file" $ + parseCabalFileExtensions "xno-extensions.cabal" `shouldThrow` + (== CabalFileNotFound "xno-extensions.cabal") + it "should throw 'CabalParseError'" $ + parseCabalExtensions exampleCabal "stack.yaml" `shouldThrow` + (== CabalParseError "example.cabal:0:0: \"name\" field missing") + it "should throw 'CabalSafeExtensionsConflict'" $ + parseCabalExtensions exampleCabal conflictSafeCabal `shouldThrow` + (== CabalSafeExtensionsConflict (Safe :| [Unsafe])) + it "should parse minimal Cabal file" $ + parseCabalExtensions exampleCabal minimalCabal >>= \extMap -> + extMap `shouldBe` mempty + it "should parse Cabal file with a single module in a library" $ + parseCabalExtensions exampleCabal singleModuleCabal >>= \extMap -> + extMap `shouldBe` singleModuleMap + it "should parse Cabal file with multiple directories" $ + parseCabalExtensions exampleCabal multipleDirsCabal >>= \extMap -> + extMap `shouldBe` singleModuleMap + it "should parse Cabal file with default-extensions" $ + parseCabalExtensions exampleCabal singleExtensionCabal >>= \extMap -> + extMap `shouldBe` singleExtensionMap + it "should parse Cabal file with default-extensions inside common stanza" $ + parseCabalExtensions exampleCabal commonStanzaCabal >>= \extMap -> + extMap `shouldBe` singleExtensionMap + it "should parse Cabal file with Safe in default-extensions" $ + parseCabalExtensions exampleCabal safeHaskellCabal >>= \extMap -> + extMap `shouldBe` safeExtensionMap + it "should parse Cabal file with different safe extensions in different stanzas" $ + parseCabalExtensions exampleCabal manySafeCabal >>= \extMap -> + extMap `shouldBe` manySafeMap + it "should parse extensions.cabal" $ + parseCabalFileExtensions "extensions.cabal" >>= \extMap -> + extMap `shouldBe` expectedMap + where + to :: FilePath -> ParsedExtensions -> (FilePath, ParsedExtensions) + to = (,) + + exampleCabal :: FilePath + exampleCabal = "example.cabal" + + singleModuleMap :: Map FilePath ParsedExtensions + singleModuleMap = Map.singleton "src/Extensions.hs" emptyParsedExtensions + + singleExtensionMap :: Map FilePath ParsedExtensions + singleExtensionMap = Map.singleton "src/Extensions.hs" emptyParsedExtensions + { parsedExtensionsAll = [On TypeApplications] + } + + safeExtensionMap :: Map FilePath ParsedExtensions + safeExtensionMap = Map.singleton "src/Extensions.hs" emptyParsedExtensions + { parsedExtensionsSafe = Just Safe + } + + manySafeMap :: Map FilePath ParsedExtensions + manySafeMap = Map.fromList + [ "src/Extensions.hs" `to` emptyParsedExtensions + { parsedExtensionsSafe = Just Safe + } + , "test/Spec.hs" `to` emptyParsedExtensions + { parsedExtensionsSafe = Just Trustworthy + } + ] + + -- Map for the project itself + expectedMap :: Map FilePath ParsedExtensions + expectedMap = Map.fromList + [ "app/Cli.hs" `to` defaultExtensions + , "app/Main.hs" `to` defaultExtensions + , "src/Extensions.hs" `to` defaultExtensions + , "src/Extensions/Cabal.hs" `to` defaultExtensions + , "src/Extensions/Module.hs" `to` defaultExtensions + , "src/Extensions/Package.hs" `to` defaultExtensions + , "src/Extensions/Types.hs" `to` defaultExtensions + , "test/Test/Extensions.hs" `to` defaultExtensions + , "test/Test/Extensions/Cabal.hs" `to` defaultExtensions + , "test/Test/Extensions/Module.hs" `to` defaultExtensions + , "test/Test/Extensions/Types.hs" `to` defaultExtensions + , "test/Spec.hs" `to` defaultExtensions + ] + + -- Minimal cabal file with no modules and no extensions + minimalCabal :: ByteString + minimalCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + ] + + -- Cabal file with a single directory and single module + singleModuleCabal :: ByteString + singleModuleCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + ] + + -- Cabal file with multiple directories + multipleDirsCabal :: ByteString + multipleDirsCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: foo, bar, baz, quux, src" + , " exposed-modules: Extensions" + ] + + -- Cabal file with a single directory, single module and single extension + singleExtensionCabal :: ByteString + singleExtensionCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + , " default-extensions: TypeApplications" + ] + + -- Cabal file with a common stanza + commonStanzaCabal :: ByteString + commonStanzaCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "common common-extensions" + , " default-extensions: TypeApplications" + , "" + , "library" + , " import: common-extensions" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + ] + + -- Cabal file with safe haskell extension + safeHaskellCabal :: ByteString + safeHaskellCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + , " default-extensions: Safe" + ] + + -- Cabal file with conflicting safe haskell extensions + conflictSafeCabal :: ByteString + conflictSafeCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + , " default-extensions: Safe, Unsafe" + ] + + -- Cabal file with different Safe extensions + manySafeCabal :: ByteString + manySafeCabal = Text.encodeUtf8 $ Text.unlines + [ "cabal-version: 2.4" + , "name: example" + , "version: 0.0.0.0" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Extensions" + , " default-extensions: Safe" + , "" + , "test-suite example-test" + , " type: exitcode-stdio-1.0" + , " hs-source-dirs: test" + , " main-is: Spec.hs" + , " default-extensions: Trustworthy" + ] + +defaultExtensions :: ParsedExtensions +defaultExtensions = emptyParsedExtensions + { parsedExtensionsAll = map On + [ ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , GeneralizedNewtypeDeriving + , InstanceSigs + , KindSignatures + , LambdaCase + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , ViewPatterns + ] + } diff --git a/test/Test/Extensions/Module.hs b/test/Test/Extensions/Module.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extensions/Module.hs @@ -0,0 +1,427 @@ +module Test.Extensions.Module + ( moduleParserSpec + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (pack) +import Data.Text.Encoding (encodeUtf8) +import GHC.LanguageExtensions.Type (Extension (..)) +import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, shouldBe) + +import Extensions.Module (parseFile, parseSource) +import Extensions.Types (ModuleParseError (..), OnOffExtension (..), ParsedExtensions (..), + SafeHaskellExtension (..), emptyParsedExtensions) + + +moduleParserSpec :: Spec +moduleParserSpec = describe "Haskell file Extensions Parser" $ do + failSpec + onlyExtensionsSpec + singleLineCommentsSpec + multiLineCommentsSpec + cppSpec + optionsGhcSpec + mixSpec + +failSpec :: Spec +failSpec = describe "Expected test failures" $ do + it "should throw FileNotFound" $ + parseFile "Java.hs" >>= \res -> + res `shouldBe` Left (FileNotFound "Java.hs") + itShouldFail + "{-# LANGUAGE DependentTypes #-}" + (UnknownExtensions $ "DependentTypes" :| []) + itShouldFail (unlines + [ "{-# LANGUAGE LambdaCase #-}" + , "{-# LANGUAGE Cpp #-}" + ]) + (UnknownExtensions $ "Cpp" :| []) + itShouldFail (unlines + [ "{-# LANGUAGE Safe #-}" + , "{-# LANGUAGE Unsafe #-}" + ]) + (ModuleSafeHaskellConflict $ Safe :| [Unsafe]) + itShouldFail + "{-# LANGUAGE Safe, Trustworthy, Unsafe #-}" + (ModuleSafeHaskellConflict $ Safe :| [Trustworthy, Unsafe]) + itShouldFail + "{-# LANGUAGE NoSafe #-}" + (UnknownExtensions $ "NoSafe" :| []) + +onlyExtensionsSpec :: Spec +onlyExtensionsSpec = describe "Parsing only extensions without anything else" $ do + itShouldParse "" [] + itShouldParse "{-# LANGUAGE TypeApplications #-}" [TypeApplications] + itShouldParse "{-# LaNgUaGe CPP #-}" [Cpp] + + itShouldParseSafe "{-# LANGUAGE Safe #-}" Safe + itShouldParseSafe "{-# LANGUAGE Trustworthy #-}" Trustworthy + itShouldParseSafe "{-# LANGUAGE Unsafe #-}" Unsafe + itShouldParseSafe (unlines + [ "{-# LANGUAGE Safe #-}" + , "{-# LANGUAGE Safe #-}" + ]) + Safe + + itShouldParseOnOff + "{-# LANGUAGE NoImplicitPrelude #-}" + [Off ImplicitPrelude] + itShouldParseOnOff + "{-# LANGUAGE NondecreasingIndentation #-}" + [On NondecreasingIndentation] + itShouldParse "{-#language TypeApplications#-}" [TypeApplications] + itShouldParse "{-# LANGUAGE TypeApplications, LambdaCase#-}" [TypeApplications, LambdaCase] + itShouldParse "{-# LANGUAGE TypeApplications , LambdaCase #-}" [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" + , "{-# LANGUAGE GeneralisedNewtypeDeriving #-}" + ]) + [GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving] + itShouldParse (unlines + [ "{-# LANGUAGE" + , " TypeApplications," + , " LambdaCase " + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , " CPP" + , " , TypeApplications" + , " , LambdaCase" + , "#-}" + ]) + [Cpp, TypeApplications, LambdaCase] + +singleLineCommentsSpec :: Spec +singleLineCommentsSpec = describe "Parsing extensions with single-line comments" $ do + itShouldParse (unlines + [ "-- hello" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE LambdaCase #-}" + , "-- hello " + ]) + [LambdaCase] + itShouldParse + "{-# LANGUAGE LambdaCase #-} -- this is extension for \\case" + [LambdaCase] + itShouldParse (unlines + [ "-- For better syntax" + , "{-# LANGUAGE LambdaCase #-}" + , "-- For explicit type annotations" + , "{-# LANGUAGE TypeApplications #-}" + ]) + [LambdaCase, TypeApplications] + itShouldParse (unlines + [ "-- For better syntax" + , "{-# LANGUAGE LambdaCase #-} -- this is extension for \\case " + , "-- For explicit type annotations" + , "{-# LANGUAGE TypeApplications #-} -- this is extension for @Int" + ]) + [LambdaCase, TypeApplications] + itShouldParse (unlines + [ " -- Comment with indentation" + , "{-# LANGUAGE LambdaCase #-}" + , " -- Another comment with indentation" + , "{-# LANGUAGE TypeApplications #-}" + ]) + [LambdaCase, TypeApplications] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "-- hello" + , "LambdaCase " + , "#-}" + ]) + [LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "TypeApplications," + , "-- hello" + , "LambdaCase " + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , " TypeApplications," + , " -- hello" + , " LambdaCase " + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , " -- For explicit type annotations" + , " TypeApplications," + , " -- For nicer syntax" + , " LambdaCase " + , " -- That's all folks!" + , "#-}" + ]) + [TypeApplications, LambdaCase] + +multiLineCommentsSpec :: Spec +multiLineCommentsSpec = describe "Parsing extensions with multi-line comments" $ do + itShouldParse + "{-# LANGUAGE {- WHAT IS -} LambdaCase {- THIS SYNTAX? o_O -} #-}" + [LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications , LambdaCase #-}" + , "{- hello -}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications #-}" + , "{- hello -}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse + "{-# LANGUAGE LambdaCase #-} {- hello -}" + [LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications #-}" + , " " + , "{- hello -}" + , "{-# LANGUAGE LambdaCase #-}" + , "" + , "hello :: IO ()" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications #-}" + , "{- This is" + , "a very long" + , "multiline" + , "comment" + , "-}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications #-} {- Long comment" + , "explaining why this extension is required -}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + +cppSpec :: Spec +cppSpec = describe "Parsing extensions with CPP" $ do + itShouldParse (unlines + [ "#if __GLASGOW_HASKELL__ < 810" + , "{-# LANGUAGE TypeApplications #-}" + , "#endif" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "#if __GLASGOW_HASKELL__ < 810" + , "{-# LANGUAGE TypeApplications #-}" + , "#else" + , "{-# LANGUAGE LambdaCase #-}" + , "#endif" + , "{-# LANGUAGE DerivingStrategies #-}" + ]) + [TypeApplications, LambdaCase, DerivingStrategies] + itShouldParse (unlines + [ "#if __GLASGOW_HASKELL__ < 810" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE LambdaCase #-}" + , "#endif" + , "{-# LANGUAGE DerivingStrategies #-}" + ]) + [TypeApplications, LambdaCase, DerivingStrategies] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "#if WHAT_IS THIS_SYNTAX o_O" + , "TypeApplications," + , "#else" + , "LambdaCase" + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "#if WHAT_IS THIS_SYNTAX o_O" + , " TypeApplications," + , "#else" + , " LambdaCase" + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "#if WHAT_IS THIS_SYNTAX o_O" + , "TypeApplications," + , "#else" + , "LambdaCase " + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "#if WHAT_IS THIS_SYNTAX o_O" + , "TypeApplications," + , "#else" + , "LambdaCase" + , "#endif" + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "#if WHAT_IS THIS_SYNTAX o_O" + , "TypeApplications," + , "#else" + , "LambdaCase " + , "#endif" + , "#-}" + ]) + [TypeApplications, LambdaCase] + +optionsGhcSpec :: Spec +optionsGhcSpec = describe "Parsing LANGUAGE and OPTIONS_GHC pragmas" $ do + itShouldParse + "{-# OPTIONS_GHC -fno-warn-orphans #-}" + [] + itShouldParse + "{-# options_ghc -freverse-errors #-}" + [] + itShouldParse + "{-# OPTIONS_GHC -fno-warn-orphans -freverse-errors #-}" + [] + itShouldParse (unlines + [ "{-# OPTIONS_GHC" + , " -fno-warn-orphans" + , " -freverse-errors " + , "#-}" + ]) + [] + itShouldParse (unlines + [ "{-# OPTIONS_GHC -fno-warn-orphans #-}" + , "{-# OPTIONS_GHC -freverse-errors #-}" + ]) + [] + itShouldParse (unlines + [ "{-# OPTIONS_GHC -fno-warn-orphans #-}" + , "" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [LambdaCase] + itShouldParse (unlines + [ "{-# OPTIONS_GHC -fno-warn-orphans #-}" + , "" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "{-# OPTIONS_GHC -fno-warn-orphans #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# OPTIONS_GHC -freverse-errors #-}" + , "{-# LANGUAGE LambdaCase #-}" + ]) + [TypeApplications, LambdaCase] + +mixSpec :: Spec +mixSpec = describe "Parsing combinations of different parts" $ do + itShouldParse (unlines + [ "{-# LANGUAGE TypeApplications, LambdaCase #-}" + , "{-# language CPP #-}" + , "{-# LANGUAGE" + , " DerivingVia," + , " DerivingStrategies" + , "#-}" + ]) + [TypeApplications, LambdaCase, Cpp, DerivingVia, DerivingStrategies] + itShouldParse (unlines + [ "-- first language extension" + , "{-# LANGUAGE TypeApplications #-} {- this is type applications -}" + , "{- This is nice syntax for \\case instead of" + , " case mx of" + , " Nothing -> ..." + , " Just x -> ... -}" + , "{-# LANGUAGE LambdaCase {- CASE -} #-}" + , " -- That's all folks!" + , "" + , "main :: IO ()" + , "main = putStrLn \"LANGUAGE\"" + ]) + [TypeApplications, LambdaCase] + itShouldParse (unlines + [ "-- this is super new extension" + , "#if __GLASGOW_HASKELL__ < 810" + , "{-# LANGUAGE TypeApplications #-}" + , "-- for old GHC versions we can use another one" + , "#else" + , "-- or maybe not..." + , "{-# LANGUAGE LambdaCase #-}" + , "-- YES!" + , "#endif" + , "{- We can also always use strategies -}" + , "{-# LANGUAGE DerivingStrategies #-}" + ]) + [TypeApplications, LambdaCase, DerivingStrategies] + itShouldParse (unlines + [ "{-# LANGUAGE" + , "-- this is really weird?" + , "#if WHAT_IS THIS_SYNTAX o_O" + , " {- or is it?.. -}" + , " TypeApplications," + , " {- YES! Nobody should write" + , " such language pragmas!" + , " -}" + , "#else" + , " -- this is fine though" + , " -- i said, this is fine" + , " LambdaCase" + , "#endif" + , "-- innocent comment at the end" + , "#-}" + ]) + [TypeApplications, LambdaCase] + itShouldParseExtensions (unlines + [ "{-# LANGUAGE CPP #-}" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + , "" + , "-- |" + , "-- Module : Data.ByteString.Base64" + ]) + ParsedExtensions + { parsedExtensionsAll = [On Cpp] + , parsedExtensionsSafe = Just Trustworthy + } + +itShouldParse :: String -> [Extension] -> SpecWith (Arg Expectation) +itShouldParse s = itShouldParseOnOff s . map On + +itShouldParseOnOff :: String -> [OnOffExtension] -> SpecWith (Arg Expectation) +itShouldParseOnOff input res = itShouldParseExtensions input $ emptyParsedExtensions + { parsedExtensionsAll = res + } + +itShouldParseSafe :: String -> SafeHaskellExtension -> SpecWith (Arg Expectation) +itShouldParseSafe input res = itShouldParseExtensions input $ emptyParsedExtensions + { parsedExtensionsSafe = Just res + } + +itShouldParseExtensions :: String -> ParsedExtensions -> SpecWith (Arg Expectation) +itShouldParseExtensions input res = it ("should parse:\n" <> indent input) $ + parseSource (encodeUtf8 $ pack input) `shouldBe` Right res + +itShouldFail :: String -> ModuleParseError -> SpecWith (Arg Expectation) +itShouldFail input err = it ("should not parse:\n" <> indent input) $ + parseSource (encodeUtf8 $ pack input) `shouldBe` Left err + +indent :: String -> String +indent = unlines . map (" " <>) . lines diff --git a/test/Test/Extensions/Types.hs b/test/Test/Extensions/Types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extensions/Types.hs @@ -0,0 +1,64 @@ +module Test.Extensions.Types + ( onOffSpec + ) where + +import GHC.LanguageExtensions.Type (Extension (..)) +import Hedgehog (Gen, PropertyT, forAll, tripping) +import Test.Hspec (Expectation, Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Extensions.Types (OnOffExtension (..), mergeExtensions, readOnOffExtension, + showOnOffExtension) + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Hedgehog.Gen as Gen + + +onOffSpec :: Spec +onOffSpec = describe "OnOffExtension tests" $ do + mergeSpec + propertiesSpec + +mergeSpec :: Spec +mergeSpec = describe "Merging on-off extensions" $ do + it "should enable non default ext" $ + checkMerge [On LambdaCase] [On LambdaCase] + it "should not add default ext" $ + checkMerge [On ImplicitPrelude] [] + it "should disable default ext" $ + checkMerge [Off ImplicitPrelude] [Off ImplicitPrelude] + it "should not affect disabling non default ext" $ + checkMerge [Off LambdaCase] [] + it "should not affect enable+disable non default ext" $ + checkMerge [On LambdaCase, Off LambdaCase] [] + it "should enable when disable+enable non default ext" $ + checkMerge [Off LambdaCase, On LambdaCase] [On LambdaCase] + it "should not affect disable+enable non default ext" $ + checkMerge [Off ImplicitPrelude, On ImplicitPrelude] [] + it "should enable when disable+enable non default ext" $ + checkMerge [On ImplicitPrelude, Off ImplicitPrelude] [Off ImplicitPrelude] + where + checkMerge :: [OnOffExtension] -> [OnOffExtension] -> Expectation + checkMerge exts res = mergeExtensions exts `shouldBe` Set.fromList res + +propertiesSpec :: Spec +propertiesSpec = describe "Property tests" $ + it "read . show ≡ Just" roundtripProperty + +roundtripProperty :: PropertyT IO () +roundtripProperty = hedgehog $ do + onOffExtension <- forAll genOnOffExtension + tripping + onOffExtension + showOnOffExtension + (readOnOffExtension . Text.unpack) + +genOnOffExtension :: Gen OnOffExtension +genOnOffExtension = Gen.choice + [ On <$> genExtension + , Off <$> genExtension + ] + where + genExtension :: Gen Extension + genExtension = Gen.enumBounded