Fix module renaming in compile-proto-file

proto3-suite.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.0
 name:                proto3-suite
-version:             0.4.3
+version:             0.5.0
 synopsis:            A higher-level API to the proto3-wire library
 description:
   This library provides a higher-level API to <https://github.com/awakesecurity/proto3-wire the `proto3-wire` library>

src/Proto3/Suite/DotProto/Generate.hs

@@ -26,6 +26,7 @@ module Proto3.Suite.DotProto.Generate
   , CompileArgs(..)
   , compileDotProtoFile
   , compileDotProtoFileOrDie
+  , renameProtoFile
   , hsModuleForDotProto
   , renderHsModuleForDotProto
   , readDotProtoWithContext
@@ -61,6 +62,7 @@ import           Proto3.Wire.Types              (FieldNumber (..))
 import qualified Turtle
 import           Turtle                         (FilePath)
 
+--------------------------------------------------------------------------------
 
 --
 -- * Public interface
@@ -75,20 +77,21 @@ data CompileArgs = CompileArgs
 -- | Generate a Haskell module corresponding to a @.proto@ file
 compileDotProtoFile :: CompileArgs -> IO (Either CompileError ())
 compileDotProtoFile CompileArgs{..} = runExceptT $ do
-    (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto
-
-    modulePathPieces <- traverse typeLikeName . components . metaModulePath . protoMeta $ dotProto
+  (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto
+  modulePathPieces <- traverse renameProtoFile (toModuleComponents dotProto)
 
-    let relativePath = FP.concat (map fromString $ NE.toList modulePathPieces) <.> "hs"
-    let modulePath   = outputDir </> relativePath
+  let relativePath = FP.concat (map fromString $ NE.toList modulePathPieces) <.> "hs"
+  let modulePath = outputDir </> relativePath
 
-    Turtle.mktree (Turtle.directory modulePath)
+  Turtle.mktree (Turtle.directory modulePath)
 
-    extraInstances <- foldMapM getExtraInstances extraInstanceFiles
+  extraInstances <- foldMapM getExtraInstances extraInstanceFiles
+  haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext
 
-    haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext
-
-    liftIO (writeFile (FP.encodeString modulePath) haskellModule)
+  liftIO (writeFile (FP.encodeString modulePath) haskellModule)
+  where
+    toModuleComponents :: DotProto -> NonEmpty String
+    toModuleComponents = components . metaModulePath . protoMeta
 
 -- | Same as 'compileDotProtoFile', except terminates the program with an error
 -- message on failure.
@@ -105,6 +108,46 @@ compileDotProtoFileOrDie args = compileDotProtoFile args >>= \case
     |]
   _ -> pure ()
 
+-- | Renaming protobuf file names to valid Haskell module names.
+--
+-- By convention, protobuf filenames are snake case. 'rnProtoFile' renames
+-- snake-cased protobuf filenames by:
+--
+-- * Replacing occurrences of one or more underscores followed by an
+-- alphabetical character with one less underscore.
+--
+-- * Capitalizing the first character following the string of underscores.
+--
+-- ==== __Examples__
+--
+-- >>> renameProtoFile @(Either CompileError) "abc_xyz"
+-- Right "AbcXyz"
+--
+-- >>> renameProtoFile @(Either CompileError) "abc_1bc"
+-- Left (InvalidModuleName "_1bc")
+--
+-- >>> renameProtoFile @(Either CompileError) "_"
+-- Left (InvalidModuleName "_")
+renameProtoFile :: MonadError CompileError m => String -> m String
+renameProtoFile str = do
+  -- @underscores@ is zero or more underscore characters prefixing the remaining
+  -- substring @rest.
+  let (underscores, rest) = span (== '_') str
+
+  unless (isValidName rest) $ do
+    throwError (InvalidModuleName str)
+
+  case break (== '_') rest of
+    (prefix, suffix)
+      | null suffix -> pure (toUpperFirst prefix)
+      | otherwise -> do
+        let renamed = drop 1 underscores ++ toUpperFirst prefix
+        suffix' <- renameProtoFile suffix
+        pure (renamed ++ suffix')
+  where
+    isValidName "" = False
+    isValidName (c : _) = isAlpha c
+
 -- | Compile a 'DotProto' AST into a 'String' representing the Haskell
 --   source of a module implementing types and instances for the .proto
 --   messages and enums.

src/Proto3/Suite/DotProto/Internal.hs

@@ -365,10 +365,11 @@ isMap _ = False
 -- * Name resolution
 --
 
-
-
-concatDotProtoIdentifier :: MonadError CompileError m
-                         => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
+concatDotProtoIdentifier ::
+  MonadError CompileError m =>
+  DotProtoIdentifier ->
+  DotProtoIdentifier ->
+  m DotProtoIdentifier
 concatDotProtoIdentifier i1 i2 = case (i1, i2) of
   (Qualified{}  ,  _           ) -> internalError "concatDotProtoIdentifier: Qualified"
   (_            , Qualified{}  ) -> internalError "concatDotProtoIdentifier Qualified"
@@ -391,17 +392,35 @@ toPascalCase xs = foldMap go (segmentBy (== '_') xs)
 
 -- | @'toCamelCase' xs@ sends a snake-case string @xs@ to a camel-cased string.
 toCamelCase :: String -> String
-toCamelCase xs = case toPascalCase xs of
-  "" -> ""
-  x : xs' -> toLower x : xs'
+toCamelCase xs =
+  case toPascalCase xs of
+    "" -> ""
+    x : xs' -> toLower x : xs'
 
--- | @'toUpperFirst' xs@ sends the first character @x@ in @xs@ to be upper case, @'toUpperFirst' "" = ""@.
+-- | Uppercases the first character of a string.
+--
+-- ==== __Examples__
+--
+-- >>> toUpperFirst "abc"
+-- "Abc"
+--
+-- >>> toUpperFirst ""
+-- ""
 toUpperFirst :: String -> String
-toUpperFirst [] = []
+toUpperFirst "" = ""
 toUpperFirst (x : xs) = toUpper x : xs
 
--- | @'segmentBy' p xs@  partitions @xs@ into segments of @'Either' [a] [a]@ where @'Right' xs'@ satisfy @p@ and
--- @'Left' xs'@ segments satisfy @'not' . p@.
+-- | @'segmentBy' p xs@  partitions @xs@ into segments of @'Either' [a] [a]@
+-- with:
+--
+-- * 'Right' sublists containing elements satisfying @p@, otherwise;
+--
+-- * 'Left' sublists containing elements that do not satisfy @p@
+--
+-- ==== __Examples__
+--
+-- >>> segmentBy (\c -> c == '_') "abc_123_xyz"
+-- [Left "abc",Right "_",Left "123",Right "_",Left "xyz"]
 segmentBy :: (a -> Bool) -> [a] -> [Either [a] [a]]
 segmentBy p xs = case span p xs of
   ([], []) -> []
@@ -454,7 +473,7 @@ typeLikeName s@(x : xs)
 
     -- Only valid as a secondary character.
     -- First character of a Haskell name can only be "isAlpha".
-    isValidNameChar x = isAlphaNum x || x == '_'
+    isValidNameChar ch = isAlphaNum ch || ch == '_'
 
 -- | @'fieldLikeName' field@ is the casing transformation used to produce record selectors from message fields. If
 -- @field@ is prefixed by a span of uppercase characters then that prefix will be lowercased while the remaining string
@@ -625,18 +644,19 @@ oneofSubDisjunctBinder = intercalate "_or_" . fmap oneofSubBinder
 --
 
 data CompileError
-  = CircularImport          FilePath
-  | CompileParseError       ParseError
-  | InternalError           String
-  | InvalidPackageName      DotProtoIdentifier
-  | InvalidMethodName       DotProtoIdentifier
-  | InvalidTypeName         String
-  | InvalidMapKeyType       String
+  = CircularImport FilePath
+  | CompileParseError ParseError
+  | InternalError String
+  | InvalidPackageName DotProtoIdentifier
+  | InvalidMethodName DotProtoIdentifier
+  | InvalidModuleName String
+  | InvalidTypeName String
+  | InvalidMapKeyType String
   | NoPackageDeclaration
-  | NoSuchType              DotProtoIdentifier
+  | NoSuchType DotProtoIdentifier
   | NonzeroFirstEnumeration String DotProtoIdentifier Int32
-  | EmptyEnumeration        String
-  | Unimplemented           String
+  | EmptyEnumeration String
+  | Unimplemented String
   deriving (Show, Eq)