Skip to content

Commit

Permalink
Refactor ModuleName
Browse files Browse the repository at this point in the history
  • Loading branch information
@phadej
phadej committed Mar 20, 2020
1 parent 494bdf5 commit e3dff2a
Show file tree
Hide file tree
Showing 34 changed files with 361 additions and 377 deletions.
4 changes: 2 additions & 2 deletions Cabal/Distribution/Backpack.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -117,7 +117,7 @@ instance Pretty OpenUnitId where
--Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
--
-- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId
-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName ["Str"],OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName ["Data","Text","Text"]))]))
-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))]))
--
instance Parsec OpenUnitId where
parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
Expand Down Expand Up @@ -180,7 +180,7 @@ instance Pretty OpenModule where
-- |
--
-- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule
-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName ["Database","MySQL"]))
-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL"))
--
instance Parsec OpenModule where
parsec = parsecModuleVar <|> parsecOpenModule
Expand Down
119 changes: 51 additions & 68 deletions Cabal/Distribution/ModuleName.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ModuleName
Expand All @@ -13,7 +14,7 @@
-- Data type for Haskell module names.

module Distribution.ModuleName (
ModuleName (..), -- TODO: move Parsec instance here, don't export constructor
ModuleName,
fromString,
fromComponents,
components,
Expand All @@ -33,30 +34,54 @@ import Distribution.Utils.ShortText (ShortText, fromShortText, toShortTex
import System.FilePath (pathSeparator)

import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.DList as DList
import qualified Text.PrettyPrint as Disp

-- | A valid Haskell module name.
--
newtype ModuleName = ModuleName ShortTextLst
newtype ModuleName = ModuleName ShortText
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)

unModuleName :: ModuleName -> String
unModuleName (ModuleName s) = fromShortText s

instance Binary ModuleName
instance Structured ModuleName

instance NFData ModuleName where
rnf (ModuleName ms) = rnf ms

instance Pretty ModuleName where
pretty (ModuleName ms) =
Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms))
pretty = Disp.text . unModuleName

instance Parsec ModuleName where
parsec = fromComponents <$> toList <$> P.sepByNonEmpty component (P.char '.')
where
component = do
c <- P.satisfy isUpper
cs <- P.munch validModuleChar
return (c:cs)
parsec = parsecModuleName

parsecModuleName :: forall m. CabalParsing m => m ModuleName
parsecModuleName = state0 DList.empty where
upper :: m Char
!upper = P.satisfy isUpper

ch :: m Char
!ch = P.satisfy (\c -> validModuleChar c || c == '.')

alt :: m ModuleName -> m ModuleName -> m ModuleName
!alt = (<|>)

state0 :: DList.DList Char -> m ModuleName
state0 acc = do
c <- upper
state1 (DList.snoc acc c)

state1 :: DList.DList Char -> m ModuleName
state1 acc = state1' acc `alt` return (fromString (DList.toList acc))

state1' :: DList.DList Char -> m ModuleName
state1' acc = do
c <- ch
case c of
'.' -> state0 (DList.snoc acc c)
_ -> state1 (DList.snoc acc c)

instance Described ModuleName where
describe _ = REMunch1 (reChar '.') component where
Expand All @@ -67,8 +92,7 @@ validModuleChar c = isAlphaNum c || c == '_' || c == '\''

validModuleComponent :: String -> Bool
validModuleComponent [] = False
validModuleComponent (c:cs) = isUpper c
&& all validModuleChar cs
validModuleComponent (c:cs) = isUpper c && all validModuleChar cs

-- | Construct a 'ModuleName' from a valid module name 'String'.
--
Expand All @@ -77,77 +101,36 @@ validModuleComponent (c:cs) = isUpper c
-- are parsing user input then use 'Distribution.Text.simpleParse' instead.
--
instance IsString ModuleName where
fromString string = fromComponents (split string)
where
split cs = case break (=='.') cs of
(chunk,[]) -> chunk : []
(chunk,_:rest) -> chunk : split rest
fromString = ModuleName . toShortText

-- | Construct a 'ModuleName' from valid module components, i.e. parts
-- separated by dots.
fromComponents :: [String] -> ModuleName
fromComponents components'
| null components' = error zeroComponents
| all validModuleComponent components' = ModuleName (stlFromStrings components')
| otherwise = error badName
where
zeroComponents = "ModuleName.fromComponents: zero components"
badName = "ModuleName.fromComponents: invalid components " ++ show components'
fromComponents comps = fromString (intercalate "." comps)
{-# DEPRECATED fromComponents "Exists for cabal-install only" #-}

-- | The module name @Main@.
--
main :: ModuleName
main = ModuleName (stlFromStrings ["Main"])
main = ModuleName (fromString "Main")

-- | The individual components of a hierarchical module name. For example
--
-- > components (fromString "A.B.C") = ["A", "B", "C"]
--
components :: ModuleName -> [String]
components (ModuleName ms) = stlToStrings ms
components mn = split (unModuleName mn)
where
split cs = case break (=='.') cs of
(chunk,[]) -> chunk : []
(chunk,_:rest) -> chunk : split rest

-- | Convert a module name to a file path, but without any file extension.
-- For example:
--
-- > toFilePath (fromString "A.B.C") = "A/B/C"
--
toFilePath :: ModuleName -> FilePath
toFilePath = intercalate [pathSeparator] . components

----------------------------------------------------------------------------
-- internal helper

-- | Strict/unpacked representation of @[ShortText]@
data ShortTextLst = STLNil
| STLCons !ShortText !ShortTextLst
deriving (Eq, Generic, Ord, Typeable, Data)

instance NFData ShortTextLst where
rnf = flip seq ()

instance Show ShortTextLst where
showsPrec p = showsPrec p . stlToList


instance Read ShortTextLst where
readsPrec p = map (first stlFromList) . readsPrec p

instance Binary ShortTextLst where
put = put . stlToList
get = stlFromList <$> get

instance Structured ShortTextLst

stlToList :: ShortTextLst -> [ShortText]
stlToList STLNil = []
stlToList (STLCons st next) = st : stlToList next

stlToStrings :: ShortTextLst -> [String]
stlToStrings = map fromShortText . stlToList

stlFromList :: [ShortText] -> ShortTextLst
stlFromList [] = STLNil
stlFromList (x:xs) = STLCons x (stlFromList xs)

stlFromStrings :: [String] -> ShortTextLst
stlFromStrings = stlFromList . map toShortText
toFilePath = map f . unModuleName where
f '.' = pathSeparator
f c = c
4 changes: 2 additions & 2 deletions Cabal/Distribution/Parsec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,13 +46,13 @@ module Distribution.Parsec (
parsecUnqualComponentName,
) where

import Data.ByteString (ByteString)
import Data.Char (digitToInt, intToDigit)
import Data.List (transpose)
import Distribution.CabalSpecVersion
import Distribution.Compat.Prelude
import Distribution.Parsec.Error (PError (..), showPError)
import Data.ByteString (ByteString)
import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromString, fieldLineStreamFromBS)
import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString)
import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos)
import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning)
import Numeric (showIntAtBase)
Expand Down
6 changes: 3 additions & 3 deletions Cabal/tests/ParserTests/ipi/Includes2.expr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ InstalledPackageInfo
`UnitId "Includes2-0.1.0.0-inplace-mysql"`],
description = "",
exposed = False,
exposedModules = [`ExposedModule {exposedName = ModuleName ["Mine"], exposedReexport = Nothing}`],
exposedModules = [`ExposedModule {exposedName = ModuleName "Mine", exposedReexport = Nothing}`],
extraGHCiLibraries = [],
extraLibraries = [],
frameworkDirs = [],
Expand All @@ -30,11 +30,11 @@ InstalledPackageInfo
installedComponentId_ = `ComponentId ""`,
installedUnitId = `UnitId "Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"`,
instantiatedWith = [_×_
`ModuleName ["Database"]`
`ModuleName "Database"`
(OpenModule
(DefiniteUnitId
(DefUnitId `UnitId "Includes2-0.1.0.0-inplace-mysql"`))
`ModuleName ["Database","MySQL"]`)],
`ModuleName "Database.MySQL"`)],
ldOptions = [],
libVisibility = LibraryVisibilityPrivate,
libraryDirs = ["/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"],
Expand Down
2 changes: 1 addition & 1 deletion Cabal/tests/ParserTests/ipi/internal-preprocessor-test.expr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ InstalledPackageInfo
depends = [`UnitId "base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d"`],
description = "See https://github.com/haskell/cabal/issues/1541#issuecomment-30155513",
exposed = True,
exposedModules = [`ExposedModule {exposedName = ModuleName ["A"], exposedReexport = Nothing}`],
exposedModules = [`ExposedModule {exposedName = ModuleName "A", exposedReexport = Nothing}`],
extraGHCiLibraries = [],
extraLibraries = [],
frameworkDirs = [],
Expand Down
44 changes: 22 additions & 22 deletions Cabal/tests/ParserTests/ipi/issue-2276-ghc-9885.expr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,28 +32,28 @@ InstalledPackageInfo
"the @mtl@ or @monads-tf@ packages, which automatically lift operations\n",
"introduced by monad transformers through other transformers."],
exposed = True,
exposedModules = [`ExposedModule {exposedName = ModuleName ["Control","Applicative","Backwards"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Applicative","Lift"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Signatures"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Class"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Cont"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Error"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Except"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Identity"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","List"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Maybe"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","RWS"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","RWS","Lazy"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","RWS","Strict"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Reader"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","State"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","State","Lazy"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","State","Strict"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Writer"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Writer","Lazy"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Control","Monad","Trans","Writer","Strict"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Data","Functor","Constant"], exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName ["Data","Functor","Reverse"], exposedReexport = Nothing}`],
exposedModules = [`ExposedModule {exposedName = ModuleName "Control.Applicative.Backwards", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Applicative.Lift", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Signatures", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Class", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Cont", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Error", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Except", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Identity", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.List", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Maybe", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.RWS", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.RWS.Lazy", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.RWS.Strict", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Reader", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.State", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.State.Lazy", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.State.Strict", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Writer", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Writer.Lazy", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Control.Monad.Trans.Writer.Strict", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Data.Functor.Constant", exposedReexport = Nothing}`,
`ExposedModule {exposedName = ModuleName "Data.Functor.Reverse", exposedReexport = Nothing}`],
extraGHCiLibraries = [],
extraLibraries = [],
frameworkDirs = [],
Expand Down
Loading

0 comments on commit e3dff2a

Please sign in to comment.