module-munging (empty) → 0.1.0.0
raw patch · 8 files changed
+686/−0 lines, 8 filesdep +basedep +hspecdep +module-munging
Dependencies added: base, hspec, module-munging, string-interpolate
Files
- CHANGELOG.md +3/−0
- LICENSE.md +23/−0
- README.md +26/−0
- library/ModuleMunging.hs +230/−0
- module-munging.cabal +73/−0
- package.yaml +72/−0
- test-suite/Driver.hs +1/−0
- test-suite/Test/ModuleMungingSpec.hs +258/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1.0.0++* Initial release
+ LICENSE.md view
@@ -0,0 +1,23 @@+[The MIT License (MIT)][]++Copyright (c) 2024 Jason Shipman++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.++[The MIT License (MIT)]: https://opensource.org/licenses/MIT
+ README.md view
@@ -0,0 +1,26 @@+# [module-munging][]++[![Build badge][]][build]+[![Version badge][]][version]++## Synopsis++Thin (threadbare), low-tech means of smashing together raw text to create+Haskell modules. This can be useful for code generation, preprocessors, etc.++## Goals++`module-munging` exists primarily to ease building preprocessors. Preprocessors+require smashing together text to make modules, and it gets tiresome quickly+dealing again and again with things like imports, exports, etc. Additionally,+many preprocessors are simple enough that pulling in something like+`haskell-src-exts` is very much overkill. `module-munging` aims to provide as+thin of a wrapper as possible over smashing together text while making the act+of doing so a bit more pleasant.++[module-munging]: https://github.com/jship/module-munging+[Build badge]: https://github.com/jship/module-munging/workflows/CI/badge.svg+[build]: https://github.com/jship/module-munging/actions+[Version badge]: https://img.shields.io/hackage/v/module-munging?color=brightgreen&label=version&logo=haskell+[version]: https://hackage.haskell.org/package/module-munging+[Haddocks]: https://hackage.haskell.org/package/module-munging
+ library/ModuleMunging.hs view
@@ -0,0 +1,230 @@+module ModuleMunging+ ( Module(..)+ , ModuleName(..)+ , buildModule+ , displayModule+ , ModuleFragment(..)+ , ModuleExport(..)+ , ModuleImport(..)+ , ModuleImportStyle(..)+ , ModuleDeclaration(..)+ , DeclName(..)+ , DeclBody(..)+ ) where++import Prelude++import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Kind (Type)+import Data.String (IsString)+import Text.Printf (printf)++import Data.Char qualified as Char+import Data.List qualified as List+import Data.Maybe qualified as Maybe++type Module :: Type+data Module = Module+ { moduleName :: String+ , moduleExports :: [String]+ , moduleImports :: [ModuleImport]+ , moduleDeclarations :: [ModuleDeclaration]+ } deriving stock (Eq, Show)++type ModuleName :: Type+data ModuleName+ = ModuleNameExact String+ | ModuleNameFromFilePath FilePath++moduleNameFromFilePath :: FilePath -> Maybe String+moduleNameFromFilePath fp = do+ fp' <- List.reverse <$> List.stripPrefix "sh." (List.reverse fp)+ n : _ <- pure $ dropWhile (not . Char.isUpper . head) $ List.tails fp'+ pure $ n & map \case+ c | Char.isAlphaNum c || c == '_' -> c+ | otherwise -> '.'++buildModule :: ModuleName -> ModuleFragment -> Module+buildModule name modFragment =+ Module+ { moduleName =+ case name of+ ModuleNameExact n -> n+ ModuleNameFromFilePath fp+ | Just n <- moduleNameFromFilePath fp -> n+ | otherwise -> error $ printf "buildModule: Failed to convert filepath \"%s\" to module" fp+ , moduleExports = toExports $ moduleFragmentDeclarations modFragment+ , moduleImports =+ flattenModuleImportGroups+ $ List.groupBy groupModuleImports+ $ List.sort+ $ moduleFragmentImports modFragment+ , moduleDeclarations = moduleFragmentDeclarations modFragment+ }+ where+ toExports :: [ModuleDeclaration] -> [String]+ toExports = filter (not . null) . fmap \case+ ModuleDeclaration shouldExport (DeclName funName) _+ | shouldExport -> funName+ | otherwise -> []++ flattenModuleImportGroups :: [[ModuleImport]] -> [ModuleImport]+ flattenModuleImportGroups = foldMap \case+ [] -> []+ x : xs ->+ case moduleImportStyle x of+ ModuleImportStyleOpen -> pure x+ ModuleImportStyleExplicit ids ->+ pure x+ { moduleImportStyle =+ ModuleImportStyleExplicit+ $ List.sort+ $ List.nub+ $ ids <> idsFromModuleImportGroup (moduleImportStyle <$> xs)+ }+ ModuleImportStyleQualified {} -> pure x++ idsFromModuleImportGroup :: [ModuleImportStyle] -> [String]+ idsFromModuleImportGroup = foldMap \case+ ModuleImportStyleExplicit ids -> ids+ _ -> []++ groupModuleImports :: ModuleImport -> ModuleImport -> Bool+ groupModuleImports x y =+ moduleImportName x == moduleImportName y &&+ case (moduleImportStyle x, moduleImportStyle y) of+ (ModuleImportStyleOpen, ModuleImportStyleOpen) -> True+ (ModuleImportStyleExplicit {}, ModuleImportStyleExplicit {}) -> True+ (ModuleImportStyleQualified qx, ModuleImportStyleQualified qy) -> qx == qy+ (_, _) -> False++displayModule :: Module -> String+displayModule m =+ unlines+ $ "-- Auto-generated - do not manually modify!"+ : "{-# LANGUAGE ImportQualifiedPost #-}"+ : "module " <> moduleName+ : " ( " <> List.intercalate "\n , " moduleExports+ : " ) where"+ : mconcat+ [ spacingIfNotNull openImportLines+ , spacingIfNotNull explicitImportLines+ , spacingIfNotNull qualifiedImportLines+ , spacingIfNotNull moduleDeclarationLines+ ]+ where+ spacingIfNotNull :: [String] -> [String]+ spacingIfNotNull xs+ | null xs = []+ | otherwise = [List.intercalate "\n" $ "" : xs]++ openImportLines :: [String]+ openImportLines =+ openImports <&> \n -> "import " <> n++ openImports :: [String]+ openImports =+ moduleImports & Maybe.mapMaybe \case+ ModuleImport { moduleImportName = n, moduleImportStyle = s }+ | ModuleImportStyleOpen <- s -> Just n+ _ -> Nothing++ explicitImportLines :: [String]+ explicitImportLines =+ explicitImports+ & fmap \(n, xs) -> "import " <> n <> " (" <> List.intercalate ", " xs <> ")"++ explicitImports :: [(String, [String])]+ explicitImports =+ moduleImports & Maybe.mapMaybe \case+ ModuleImport { moduleImportName = n, moduleImportStyle = s }+ | ModuleImportStyleExplicit xs <- s -> Just (n, xs)+ _ -> Nothing++ qualifiedImportLines :: [String]+ qualifiedImportLines =+ qualifiedImports+ & fmap \case+ (n, Just q) -> "import " <> n <> " qualified as " <> q+ (n, Nothing) -> "import " <> n <> " qualified"++ qualifiedImports :: [(String, Maybe String)]+ qualifiedImports =+ moduleImports & Maybe.mapMaybe \case+ ModuleImport { moduleImportName = n, moduleImportStyle = s }+ | ModuleImportStyleQualified q <- s -> Just (n, q)+ _ -> Nothing++ moduleDeclarationLines :: [String]+ moduleDeclarationLines =+ zip [0 :: Int ..] moduleDeclarations+ & fmap \case+ (n, ModuleDeclaration _ (DeclName {}) (DeclBody body))+ | n < 1 -> body+ | otherwise -> "\n" <> body++ Module+ { moduleName+ , moduleExports+ , moduleImports+ , moduleDeclarations+ } = m++type ModuleFragment :: Type+data ModuleFragment = ModuleFragment+ { moduleFragmentImports :: [ModuleImport]+ , moduleFragmentDeclarations :: [ModuleDeclaration]+ } deriving stock (Eq, Show)++instance Semigroup ModuleFragment where+ (<>) :: ModuleFragment -> ModuleFragment -> ModuleFragment+ mf1 <> mf2 =+ ModuleFragment+ { moduleFragmentImports = moduleFragmentImports mf1 <> moduleFragmentImports mf2+ , moduleFragmentDeclarations = moduleFragmentDeclarations mf1 <> moduleFragmentDeclarations mf2+ }++instance Monoid ModuleFragment where+ mempty :: ModuleFragment+ mempty =+ ModuleFragment+ { moduleFragmentImports = []+ , moduleFragmentDeclarations = []+ }++type ModuleExport :: Type+newtype ModuleExport = ModuleExport String+ deriving stock (Eq, Show)+ deriving newtype (IsString)++type ModuleImport :: Type+data ModuleImport = ModuleImport+ { moduleImportName :: String+ , moduleImportStyle :: ModuleImportStyle+ } deriving stock (Eq, Ord, Show)++type ModuleImportStyle :: Type+data ModuleImportStyle+ = ModuleImportStyleOpen+ | ModuleImportStyleExplicit [String]+ | ModuleImportStyleQualified (Maybe String)+ deriving stock (Eq, Ord, Show)++type ModuleDeclaration :: Type+data ModuleDeclaration =+ ModuleDeclaration+ Bool -- ^ 'True' to export, 'False' to not export+ DeclName+ DeclBody+ deriving stock (Eq, Show)++type DeclName :: Type+newtype DeclName = DeclName String+ deriving stock (Eq, Show)+ deriving newtype (IsString)++type DeclBody :: Type+newtype DeclBody = DeclBody String+ deriving stock (Eq, Show)+ deriving newtype (IsString)
+ module-munging.cabal view
@@ -0,0 +1,73 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: module-munging+version: 0.1.0.0+synopsis: Smash together text to make modules.+description: Thin, low-tech wrapper for smashing together raw text to make Haskell modules.+category: Codegen+homepage: https://github.com/jship/module-munging#readme+bug-reports: https://github.com/jship/module-munging/issues+author: Jason Shipman+maintainer: Jason Shipman+license: MIT+build-type: Simple+extra-source-files:+ CHANGELOG.md+ LICENSE.md+ package.yaml+ README.md++source-repository head+ type: git+ location: https://github.com/jship/module-munging++flag recent-hspec-discover+ description: Assumes hspec-discover version is 2.10.3++ manual: True+ default: True++library+ exposed-modules:+ ModuleMunging+ other-modules:+ Paths_module_munging+ hs-source-dirs:+ library+ default-extensions:+ BlockArguments+ DerivingStrategies+ ImportQualifiedPost+ LambdaCase+ ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode+ build-depends:+ base >=4.11.0.0 && <5+ default-language: GHC2021++test-suite module-munging-test-suite+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ Test.ModuleMungingSpec+ Paths_module_munging+ hs-source-dirs:+ test-suite+ default-extensions:+ BlockArguments+ DerivingStrategies+ ImportQualifiedPost+ LambdaCase+ ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode -rtsopts -threaded -with-rtsopts "-N"+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ base+ , hspec+ , module-munging+ , string-interpolate+ default-language: GHC2021+ if !flag(recent-hspec-discover)+ ghc-options: -Wno-prepositive-qualified-module -Wno-missing-export-lists
+ package.yaml view
@@ -0,0 +1,72 @@+name: module-munging+version: '0.1.0.0'+github: jship/module-munging+license: MIT+author: Jason Shipman+maintainer: Jason Shipman+synopsis: Smash together text to make modules.+description: |+ Thin, low-tech wrapper for smashing together raw text to make Haskell modules.+category: Codegen++extra-source-files:+- CHANGELOG.md+- LICENSE.md+- package.yaml+- README.md++language: GHC2021++default-extensions:+- BlockArguments+- DerivingStrategies+- ImportQualifiedPost+- LambdaCase++ghc-options:+# Draws heavy inspiration from this list: https://medium.com/mercury-bank/enable-all-the-warnings-a0517bc081c3+- -Weverything+- -Wno-missing-local-signatures # Warns if polymorphic local bindings do not have signatures+- -Wno-missing-exported-signatures # missing-exported-signatures turns off the more strict -Wmissing-signatures. See https://ghc.haskell.org/trac/ghc/ticket/14794#ticket+- -Wno-missing-import-lists # Requires explicit imports of _every_ function (e.g. ‘$’); too strict+- -Wno-missed-specializations # When GHC can’t specialize a polymorphic function+- -Wno-all-missed-specializations # See missed-specializations+- -Wno-unsafe # Don’t use Safe Haskell warnings+- -Wno-safe # Don’t use Safe Haskell warnings+- -Wno-missing-safe-haskell-mode # Don't warn if the Safe Haskell mode is unspecified++library:+ dependencies:+ - base >=4.11.0.0 && <5+ source-dirs: library++tests:+ module-munging-test-suite:+ source-dirs: test-suite+ main: Driver.hs+ build-tools:+ - hspec-discover+ dependencies:+ - base+ - module-munging+ - hspec+ - string-interpolate+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts "-N"+ # Disabling these because of hspec-discover-2.9.7 version in lts-20.26.+ # 2.10.3+ has automatic disabling of warnings in the generated driver, and+ # that version is available in lts-21 and onward.+ # See https://github.com/hspec/hspec/issues/702 for details.+ when:+ - condition: "!flag(recent-hspec-discover)"+ ghc-options:+ - -Wno-prepositive-qualified-module+ - -Wno-missing-export-lists++flags:+ recent-hspec-discover:+ description: Assumes hspec-discover version is 2.10.3++ default: true+ manual: true
+ test-suite/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-suite/Test/ModuleMungingSpec.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.ModuleMungingSpec+ ( spec+ ) where++import Data.Kind (Type)+import Data.String.Interpolate (__i)+import GHC.Stack (HasCallStack)+import ModuleMunging+import Prelude+import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe)++spec :: Spec+spec = parallel do+ describe "Example" do+ it "empty module fragment" do+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo"+ , moduleExports = []+ , moduleImports = []+ , moduleDeclarations = []+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo+ ( \n ) where\n+ |]+ , testModuleName = ModuleNameExact "Foo"+ , testModuleFragment = mempty+ }++ it "simple" do+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo.Bar"+ , moduleExports = ["foo"]+ , moduleImports =+ [ ModuleImport "Custom.Prelude" ModuleImportStyleOpen+ , ModuleImport "Foo.Baz" $ ModuleImportStyleExplicit ["baz"]+ , ModuleImport "Qualified.Module.A" $ ModuleImportStyleQualified $ Just "A"+ , ModuleImport "Qualified.Module.B" $ ModuleImportStyleQualified $ Just "Module.B"+ ]+ , moduleDeclarations =+ [ ModuleDeclaration True "foo" $ DeclBody [__i|+ bar :: Int -> Int+ bar = quux+ |]+ , ModuleDeclaration False "quux" $ DeclBody [__i|+ quux :: Int -> Int+ quux = Module.B.quux . A.quux+ |]+ ]+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo.Bar+ ( foo+ ) where++ import Custom.Prelude++ import Foo.Baz (baz)++ import Qualified.Module.A qualified as A+ import Qualified.Module.B qualified as Module.B++ bar :: Int -> Int+ bar = quux++ quux :: Int -> Int+ quux = Module.B.quux . A.quux\n+ |]+ , testModuleName = ModuleNameExact "Foo.Bar"+ , testModuleFragment = ModuleFragment+ { moduleFragmentImports =+ [ ModuleImport "Qualified.Module.B" $ ModuleImportStyleQualified $ Just "Module.B"+ , ModuleImport "Custom.Prelude" ModuleImportStyleOpen+ , ModuleImport "Foo.Baz" $ ModuleImportStyleExplicit ["baz"]+ , ModuleImport "Qualified.Module.A" $ ModuleImportStyleQualified $ Just "A"+ ]+ , moduleFragmentDeclarations =+ [ ModuleDeclaration True "foo" $ DeclBody [__i|+ bar :: Int -> Int+ bar = quux+ |]+ , ModuleDeclaration False "quux" $ DeclBody [__i|+ quux :: Int -> Int+ quux = Module.B.quux . A.quux+ |]+ ]+ }+ }++ it "two fragments" do+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo.Bar"+ , moduleExports = ["foo"]+ , moduleImports =+ [ ModuleImport "Custom.Prelude" ModuleImportStyleOpen+ , ModuleImport "Foo.Baz" $ ModuleImportStyleExplicit ["baz"]+ , ModuleImport "Qualified.Module.A" $ ModuleImportStyleQualified $ Just "A"+ , ModuleImport "Qualified.Module.B" $ ModuleImportStyleQualified $ Just "Module.B"+ , ModuleImport "Qualified.Module.C" $ ModuleImportStyleQualified Nothing+ ]+ , moduleDeclarations =+ [ ModuleDeclaration True "foo" $ DeclBody [__i|+ bar :: Int -> Int+ bar = quux+ |]+ , ModuleDeclaration False "quux" $ DeclBody [__i|+ quux :: Int -> Int+ quux = Qualified.Module.C.quux . Module.B.quux . A.quux+ |]+ ]+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo.Bar+ ( foo+ ) where++ import Custom.Prelude++ import Foo.Baz (baz)++ import Qualified.Module.A qualified as A+ import Qualified.Module.B qualified as Module.B+ import Qualified.Module.C qualified++ bar :: Int -> Int+ bar = quux++ quux :: Int -> Int+ quux = Qualified.Module.C.quux . Module.B.quux . A.quux\n+ |]+ , testModuleName = ModuleNameExact "Foo.Bar"+ , testModuleFragment = mconcat+ [ ModuleFragment+ { moduleFragmentImports =+ [ ModuleImport "Qualified.Module.B" $ ModuleImportStyleQualified $ Just "Module.B"+ , ModuleImport "Custom.Prelude" ModuleImportStyleOpen+ , ModuleImport "Foo.Baz" $ ModuleImportStyleExplicit ["baz"]+ , ModuleImport "Qualified.Module.A" $ ModuleImportStyleQualified $ Just "A"+ ]+ , moduleFragmentDeclarations =+ [ ModuleDeclaration True "foo" $ DeclBody [__i|+ bar :: Int -> Int+ bar = quux+ |]+ ]+ }+ , ModuleFragment+ { moduleFragmentImports =+ [ ModuleImport "Qualified.Module.C" $ ModuleImportStyleQualified Nothing+ , ModuleImport "Custom.Prelude" ModuleImportStyleOpen+ ]+ , moduleFragmentDeclarations =+ [ ModuleDeclaration False "quux" $ DeclBody [__i|+ quux :: Int -> Int+ quux = Qualified.Module.C.quux . Module.B.quux . A.quux+ |]+ ]+ }+ ]+ }++ it "module name from filepath" do+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo"+ , moduleExports = []+ , moduleImports = []+ , moduleDeclarations = []+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo+ ( \n ) where\n+ |]+ , testModuleName = ModuleNameFromFilePath "Foo.hs"+ , testModuleFragment = mempty+ }+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo.Bar"+ , moduleExports = []+ , moduleImports = []+ , moduleDeclarations = []+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo.Bar+ ( \n ) where\n+ |]+ , testModuleName = ModuleNameFromFilePath "Foo/Bar.hs"+ , testModuleFragment = mempty+ }+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo.Bar"+ , moduleExports = []+ , moduleImports = []+ , moduleDeclarations = []+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo.Bar+ ( \n ) where\n+ |]+ , testModuleName = ModuleNameFromFilePath "library/Foo/Bar.hs"+ , testModuleFragment = mempty+ }+ runTest TestCase+ { expectedModule = Module+ { moduleName = "Foo.Bar"+ , moduleExports = []+ , moduleImports = []+ , moduleDeclarations = []+ }+ , expectedDisplay = [__i|+ -- Auto-generated - do not manually modify!+ {-\# LANGUAGE ImportQualifiedPost \#-}+ module Foo.Bar+ ( \n ) where\n+ |]+ , testModuleName = ModuleNameFromFilePath "library\\Foo\\Bar.hs"+ , testModuleFragment = mempty+ }++type TestCase :: Type+data TestCase = TestCase+ { expectedModule :: Module+ , expectedDisplay :: String+ , testModuleName :: ModuleName+ , testModuleFragment :: ModuleFragment+ }++runTest :: HasCallStack => TestCase -> Expectation+runTest testCase = do+ actualModule `shouldBe` expectedModule+ displayModule actualModule `shouldBe` expectedDisplay+ where+ actualModule = buildModule testModuleName testModuleFragment+ TestCase+ { expectedModule+ , expectedDisplay+ , testModuleName+ , testModuleFragment+ } = testCase