proto3-suite-0.9.4: src/Proto3/Suite/DotProto/Internal.hs
-- | This module provides misc internal helpers and utilities
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Proto3.Suite.DotProto.Internal where
import Control.Applicative
import qualified Control.Foldl as FL
import Control.Lens (Lens', lens, over)
import Control.Lens.Cons (_head)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Except
import Data.Bifunctor (first)
import Data.Char
import Data.Coerce
import Data.Either
import Data.Foldable
import Data.Functor.Compose
import Data.Int (Int32)
import Data.List (intercalate, sort)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Tuple (swap)
import qualified NeatInterpolation as Neat
import Prelude hiding (FilePath)
import Proto3.Suite.DotProto.AST
import Proto3.Suite.DotProto.AST.Lens
import Proto3.Suite.DotProto.Parsing
import Proto3.Wire.Types (FieldNumber (..))
import System.FilePath (isPathSeparator)
import Text.Parsec (ParseError)
import qualified Turtle hiding (absolute, collapse)
import qualified Turtle.Compat as Turtle (absolute, collapse)
import Turtle (ExitCode (..), FilePath, Text,
(</>))
import Turtle.Format ((%))
import qualified Turtle.Format as F
-------------------------------------------------------------------------------
--
-- * Utilities
--
#if !(MIN_VERSION_mtl(2,2,2))
liftEither :: MonadError e m => Either e a -> m a
liftEither = either throwError pure
#endif
-- | Like 'foldMap', but with an effectful projection.
foldMapM ::
(Foldable t, Monad m, Monoid b, Semigroup b) => (a -> m b) -> t a -> m b
foldMapM f = foldM (\b a -> (b <>) <$> f a) mempty
-- | Like 'Control.Lens.Getter.Getting', but allows for retrieving the 'r'
-- element in some Applicative context 'm'.
type GettingM r s a = forall m. Applicative m => (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s
-- | Given an effectful projection from 'a' into a monoid 'r', retrieve the sum
-- of all 'a' values in an 's' structure as targetted by the 'GettingM' optic.
-- Note that the Monoid constraint on 'r' is implicit via 'Const', but we
-- note it in the type for clarity.
foldMapOfM :: (Applicative m, Monoid r) => GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM l f = fmap getConst . getCompose . l (Compose . fmap Const . f)
mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a)
mapKeysM f = fmap M.fromList . traverse (fmap swap . traverse f . swap) . M.assocs
-- $setup
-- >>> :set -XOverloadedStrings
dieLines :: MonadIO m => Text -> m a
dieLines (Turtle.textToLines -> msg) = do
mapM_ Turtle.err msg
Turtle.exit (ExitFailure 1)
-- | The proposition that some third value comes strictly after
-- the first argument but strictly before the second argument.
nonconsecutive :: (Enum a, Ord a) => a -> a -> Bool
nonconsecutive x y = x < y && succ x < y
-- The check that @x < y@ avoids the potential for arithmetic overflow in @succ x@.
{-# INLINABLE nonconsecutive #-} -- To allow specialization to particular type class instances.
-- | This function yields 'Just' of the union of its arguments if that union
-- can be expressed as a single interval, and otherwise yields 'Nothing'.
joinIntervals :: (Enum a, Ord a) => (a, a) -> (a, a) -> Maybe (a, a)
joinIntervals (a, b) (c, d)
| b < a = Just (c, d) -- (a, b) is empty; we can just drop it
| d < c = Just (a, b) -- (c, d) is empty; we can just drop it
| a <= c = if
| nonconsecutive b c -> Nothing -- (a, b), then something strictly between, then (c, d)
| otherwise -> Just (a, max b d) -- no value lies strictly between b and c
| otherwise = if
| nonconsecutive d a -> Nothing -- (c, d), then something strictly between, then (a, b)
| otherwise -> Just (c, max b d) -- no value lies strictly between d and a
{-# INLINABLE joinIntervals #-} -- To allow specialization to particular type class instances.
-- | Finds the unique shortest list of intervals having the same
-- set union as the given list and nondecreasing low endpoints.
--
-- The result also satisfies the definition of /normal/ given below.
--
-- Each interval is specified by pairing its low and high endpoints,
-- which are included in the interval, except when the first component
-- of the pair exceeds the second, in which case the interval is empty.
--
-- = Supporting Theory
--
-- == Definition of /normal/
--
-- Call a list of intervals /normal/ when it excludes empty intervals
-- and for any two consecutive intervals /[a .. b]/ and /[c .. d]/,
-- there exists an /x/ such that /b < x < c/.
--
-- We claim that, among those interval lists having any given union,
-- normality is equivalent to having minimal length and nondecreasing
-- low endpoints.
--
-- == Normal implies minimal length
--
-- To see why, first consider any normal interval list /N/. Clearly its
-- low endpoints are nondecreasing--and in fact are strictly increasing
-- with gaps inbetween. Therefore any interval intersecting at least two
-- intervals of /N/ necessarily includes at least one point in such a gap,
-- and that point is outside the union of /N/. Hence every interval list
-- with the same union as /N/ consists of (possibly empty) subintervals of
-- intervals listed by /N/. Hence /N/ has minimal length among such lists.
--
-- == Minimal length implies normal
--
-- To establish the converse, consider any interval list /N/ having
-- nondecreasing endpoints and minimal length. Deleting empty intervals
-- from /N/ would only decrease its length, so /N/ must not include any.
-- Next note that if /[a .. b]/ and /[c .. d]/ are consecutive intervals
-- within /N/, then either there exists an /x/ such that /b < x < c/, or
-- else we may shorten /N/ without changing its union by replacing both
-- /[a .. b]/ and /[c .. d]/ by the single interval /[a .. max b d]/,
-- which would contradict the minimality of the length of /N/. Thus
-- /N/ fulfills all the requirements of being a normal interval list.
--
-- == Existence
--
-- Having proved the desired equivalence, we turn to the question of
-- the existence of the shortest interval list having the same union
-- as any given interval list and nondecreasing low endpoints.
--
-- Consider the set /S/ of interval lists having the same union as
-- the given interval list and nondecreasing low endpoints. Note
-- that by performing a stable sort on the given interval list we
-- immediately find that /S/ is nonempty. Being nonempty, it must
-- contain at least one element of minimal length.
--
-- == Uniqueness
--
-- But could there be two different interval lists of minimal length
-- for their common union, both with nondecreasing low endpoints?
--
-- We claim the answer is no, and proceed by induction on that shared
-- minimal length. The base case is trivial: if both lists are empty,
-- then they cannot differ.
--
-- For the induction step, suppose that there are two interval lists
-- that share the same positive minimal length among those that
-- have nondecreasing low endpoints and a given same union.
-- Call them /L/ and /N/. We will prove that /L = N/.
--
-- Let /(a, b) = head L/ and /(e, f) = head N/.
--
-- If /a < e/ then /a/ is in /union L/ but not in /union N/,
-- contradicting our assumpion that /union L = union N/. Likewise
-- we may exclude /e < a/, leaving /a = e/ and /(a, f) = head N/.
--
-- Next suppose that /b < f/. If /tail L == []/ then clearly /f/
-- is outside of /union L/ and yet inside of /union N/, which is
-- once again beyond our scenario. Let /(c, d) = head (tail L)/.
-- By the equivalence we established earlier, /L/ is normal and
-- hence there exists an /x/ such that /b < x < c/. If /x <= f/,
-- then /x/ is in /[a .. f]/ and yet outside of /union L/, once
-- again contradicting our hypotheses. Otherwise /f < x < c/, and
-- hence /f/ is outside of /union L/, a similar contradiction.
-- Therefore our supposition that /b < f/ must be impossible,
-- and we can likewise exclude /f < b/. Hence /b = f/.
--
-- Having establishing both /a = e/ and /b = f/, we conclude that
-- /head L = head N/. It follows that /tail L/ and /tail N/ have
-- the same union as each other. Both tails must be minimal in
-- length, because otherwise there would also be a way to shorten
-- /L/ or /N/ in a union-preserving way. Invoking our induction
-- hypothesis we find that /tail L = tail N/; therefore /L = N/.
--
-- = Conclusions
--
-- In conclusion, the desired behavior of this function is well defined
-- by the first paragraph in this comment block, and the second paragraph
-- (once combined with a requirement to preserve the union) provides
-- an equivalent definition.
--
-- To check that the implementation actually fulfills these requirements,
-- note that it filters out empty intervals, sorts those that remain,
-- and then merges intervals until the resulting list becomes normal.
--
-- There are also unit tests checking that the result is
-- normal and has the same union as the given list.
normalizeIntervals :: (Enum a, Ord a) => [(a, a)] -> [(a, a)]
normalizeIntervals = mergeIntervals . filter \(x, y) -> x <= y
{-# INLINABLE normalizeIntervals #-} -- To allow specialization to particular type class instances.
-- | Returns a sorted list that contains all intervals from the minimal set of
-- intervals to represent the given list of intervals.
--
-- "Merges" overlapping intervals in a list of intervals. Think disjunctive
-- normal form.
mergeIntervals :: forall a . (Enum a, Ord a) => [(a, a)] -> [(a, a)]
mergeIntervals = foldr step [] . sort
where
step :: (a, a) -> [(a, a)] -> [(a, a)]
step x [] = [x]
step x (y : ys) = case joinIntervals x y of
Nothing -> x : y : ys
-- In this case @x@ and @y@ could not be merged, and therefore there is
-- some value strictly inbetween the end of @x@ and the start of @y@.
-- Compare this property to the definition of /normal/ (above).
Just xy -> step xy ys
-- Recursion is necessary here because @x@ may end later than did @y@,
-- possibly making @xy@ mergable with some prefix of @ys@, unlike @y@.
-- By merging @x@ and @y@ into @xy@ we have shortened the overall
-- length of the list, and therefore this recursion must terminate.
{-# INLINABLE mergeIntervals #-} -- To allow specialization to particular type class instances.
--------------------------------------------------------------------------------
--
-- * Reading files
--
-- | toModulePath takes an include-relative path to a .proto file and produces a
-- "module path" which is used during code generation.
--
-- Note that, with the exception of the '.proto' portion of the input filepath,
-- this function interprets '.' in the filename components as if they were
-- additional slashes (assuming that the '.' is not the first character, which
-- is merely ignored). So e.g. "google/protobuf/timestamp.proto" and
-- "google.protobuf.timestamp.proto" map to the same module path.
--
-- >>> toModulePath "/absolute/path/fails.proto"
-- Left "expected include-relative path"
--
-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails"
-- Left "expected .proto suffix"
--
-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails.txt"
-- Left "expected .proto suffix"
--
-- >>> toModulePath "../foo.proto"
-- Left "expected include-relative path, but the path started with ../"
--
-- >>> toModulePath "foo..proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "foo/bar/baz..proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "foo.bar../baz.proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "google/protobuf/timestamp.proto"
-- Right (Path {components = "Google" :| ["Protobuf","Timestamp"]})
--
-- >>> toModulePath "a/b/c/google.protobuf.timestamp.proto"
-- Right (Path {components = "A" :| ["B","C","Google","Protobuf","Timestamp"]})
--
-- >>> toModulePath "foo/FiLeName_underscore.and.then.some.dots.proto"
-- Right (Path {components = "Foo" :| ["FiLeName_underscore","And","Then","Some","Dots"]})
--
#if MIN_VERSION_turtle(1,6,0)
-- >>> toModulePath "foo/bar/././baz/../boggle.proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
#else
-- >>> toModulePath "foo/bar/././baz/../boggle.proto"
-- Right (Path {components = "Foo" :| ["Bar","Boggle"]})
#endif
--
-- >>> toModulePath "./foo.proto"
-- Right (Path {components = "Foo" :| []})
--
-- NB: We ignore preceding single '.' characters
-- >>> toModulePath ".foo.proto"
-- Right (Path {components = "Foo" :| []})
toModulePath :: FilePath -> Either String Path
toModulePath fp0@(fromMaybe fp0 . Turtle.stripPrefix "./" -> fp)
| Turtle.absolute fp
= Left "expected include-relative path"
| Turtle.extension fp /= Just "proto"
= Left "expected .proto suffix"
| otherwise
= case Turtle.stripPrefix "../" fp of
Just{} -> Left "expected include-relative path, but the path started with ../"
Nothing
| T.isInfixOf ".." . Turtle.format F.fp . Turtle.collapse $ fp
-> Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
| otherwise
-> maybe (Left "empty path after canonicalization") (Right . Path)
. NE.nonEmpty
. dropWhile null -- Remove a potential preceding empty component which
-- arose from a preceding '.' in the input path, which we
-- want to ignore. E.g. ".foo.proto" => ["","Foo"].
. fmap (T.unpack . over _head toUpper)
. concatMap (T.splitOn ".")
. T.split isPathSeparator
. Turtle.format F.fp
. Turtle.collapse
. Turtle.dropExtension
$ fp
-- | @importProto searchPaths toplevel inc@ attempts to import include-relative
-- @inc@ after locating it somewhere in the @searchPaths@; @toplevel@ is simply
-- the path of toplevel .proto being processed so we can report it in an error
-- message. This function terminates the program if it cannot find the file to
-- import or if it cannot construct a valid module path from it.
importProto :: (MonadIO m, MonadError CompileError m)
=> [FilePath] -> FilePath -> FilePath -> m DotProto
importProto paths toplevelProto protoFP =
findProto paths protoFP >>= \case
Left e
-> dieLines (badModulePathErrorMsg protoFP e)
Right Nothing
| toplevelProto == protoFP
-> dieLines (toplevelNotFoundErrorMsg paths toplevelProto)
| otherwise
-> dieLines (importNotFoundErrorMsg paths toplevelProto protoFP)
Right (Just (mp, fp))
-> liftEither . first CompileParseError =<< parseProtoFile mp fp
type FindProtoResult = Either String (Maybe (Path, FilePath))
-- | Attempts to locate the first (if any) filename that exists on the given
-- search paths, and constructs the "module path" from the given
-- include-relative filename (2nd parameter). Terminates the program with an
-- error if the given pathname is not relative.
findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult
findProto searchPaths protoFP
| Turtle.absolute protoFP = dieLines absolutePathErrorMsg
| otherwise = forM (toModulePath protoFP) $ \mp ->
flip Turtle.fold FL.head $ do
sp <- Turtle.select searchPaths
let fp = sp </> protoFP
True <- Turtle.testfile fp
pure (mp, fp)
-- * Pretty Error Messages
badModulePathErrorMsg :: FilePath -> String -> T.Text
badModulePathErrorMsg (Turtle.format F.fp -> fp) (T.pack -> rsn) =
[Neat.text|
Error: failed when computing the "module path" for "${fp}": ${rsn}
Please ensure that the provided path to a .proto file is specified as
relative to some --includeDir path and that it has the .proto suffix.
|]
importNotFoundErrorMsg :: [FilePath] -> FilePath -> FilePath -> T.Text
importNotFoundErrorMsg paths toplevelProto protoFP =
[Neat.text|
Error: while processing include statements in "${toplevelProtoText}", failed
to find the imported file "${protoFPText}", after looking in the following
locations (controlled via the --includeDir switch(es)):
$pathsText
|]
where
pathsText = T.unlines (Turtle.format (" "%F.fp) . (</> protoFP) <$> paths)
toplevelProtoText = Turtle.format F.fp toplevelProto
protoFPText = Turtle.format F.fp protoFP
toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> T.Text
toplevelNotFoundErrorMsg searchPaths toplevelProto =
[Neat.text|
Error: failed to find file "${toplevelProtoText}", after looking in
the following locations (controlled via the --includeDir switch(es)):
$searchPathsText
|]
where
searchPathsText = T.unlines (Turtle.format (" "%F.fp) . (</> toplevelProto) <$> searchPaths)
toplevelProtoText = Turtle.format F.fp toplevelProto
absolutePathErrorMsg :: T.Text
absolutePathErrorMsg =
[Neat.text|
Error: Absolute paths to .proto files, whether on the command line or
in include directives, are not currently permitted; rather, all .proto
filenames must be relative to the current directory, or relative to some
search path specified via --includeDir.
This is because we currently use the include-relative name to decide
the structure of the Haskell module tree that we emit during code
generation.
|]
--------------------------------------------------------------------------------
--
-- * Type context
--
-- | A mapping from .proto type identifiers to their type information
type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo
-- | Information about messages and enumerations
data DotProtoTypeInfo = DotProtoTypeInfo
{ dotProtoTypeInfoPackage :: DotProtoPackageSpec
-- ^ The package this type is defined in
, dotProtoTypeInfoParent :: DotProtoIdentifier
-- ^ The message this type is nested under, or 'Anonymous' if it's top-level
, dotProtoTypeChildContext :: TypeContext
-- ^ The context that should be used for declarations within the
-- scope of this type
, dotProtoTypeInfoKind :: DotProtoKind
-- ^ Whether this type is an enumeration or message
, dotProtoTypeInfoModulePath :: Path
-- ^ The include-relative module path used when importing this module
} deriving Show
tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier
tiParent = lens dotProtoTypeInfoParent (\d p -> d{ dotProtoTypeInfoParent = p })
-- | Whether a definition is an enumeration or a message
data DotProtoKind = DotProtoKindEnum
| DotProtoKindMessage
deriving (Show, Eq, Ord, Enum, Bounded)
-- ** Generating type contexts from ASTs
dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext
dotProtoTypeContext DotProto{..} =
foldMapM (definitionTypeContext (metaModulePath protoMeta)) protoDefinitions
definitionTypeContext :: MonadError CompileError m
=> Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext modulePath (DotProtoMessage _ msgIdent parts) = do
let updateParent = tiParent (concatDotProtoIdentifier msgIdent)
childTyContext <- foldMapOfM (traverse . _DotProtoMessageDefinition)
(definitionTypeContext modulePath >=> traverse updateParent)
parts
qualifiedChildTyContext <- mapKeysM (concatDotProtoIdentifier msgIdent) childTyContext
let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage
, dotProtoTypeInfoParent = Anonymous
, dotProtoTypeChildContext = childTyContext
, dotProtoTypeInfoKind = DotProtoKindMessage
, dotProtoTypeInfoModulePath = modulePath
}
pure $ M.singleton msgIdent tyInfo <> qualifiedChildTyContext
definitionTypeContext modulePath (DotProtoEnum _ enumIdent _) = do
let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage
, dotProtoTypeInfoParent = Anonymous
, dotProtoTypeChildContext = mempty
, dotProtoTypeInfoKind = DotProtoKindEnum
, dotProtoTypeInfoModulePath = modulePath
}
pure (M.singleton enumIdent tyInfo)
definitionTypeContext _ _ = pure mempty
isMessage :: TypeContext -> DotProtoIdentifier -> Bool
isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt)
boolOption :: String -> [DotProtoOption] -> Maybe Bool
boolOption desired opts =
case find (\(DotProtoOption name _) -> name == Single desired) opts of
Just (DotProtoOption _ (BoolLit x)) -> Just x
_ -> Nothing
isPacked :: [DotProtoOption] -> Bool
isPacked = fromMaybe False . boolOption "packed"
isUnpacked :: [DotProtoOption] -> Bool
isUnpacked = maybe False not . boolOption "packed"
-- | Returns 'True' if the given primitive type is packable. The 'TypeContext'
-- is used to distinguish Named enums and messages, only the former of which are
-- packable.
isPackable :: TypeContext -> DotProtoPrimType -> Bool
isPackable _ Bytes = False
isPackable _ String = False
isPackable _ Int32 = True
isPackable _ Int64 = True
isPackable _ SInt32 = True
isPackable _ SInt64 = True
isPackable _ UInt32 = True
isPackable _ UInt64 = True
isPackable _ Fixed32 = True
isPackable _ Fixed64 = True
isPackable _ SFixed32 = True
isPackable _ SFixed64 = True
isPackable _ Bool = True
isPackable _ Float = True
isPackable _ Double = True
isPackable ctxt (Named tyName) =
Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup tyName ctxt)
isMap :: DotProtoType -> Bool
isMap Map{} = True
isMap _ = False
--------------------------------------------------------------------------------
--
-- * Name resolution
--
concatDotProtoIdentifier ::
MonadError CompileError m =>
DotProtoIdentifier ->
DotProtoIdentifier ->
m DotProtoIdentifier
concatDotProtoIdentifier i1 i2 = case (i1, i2) of
(Qualified{} , _ ) -> internalError "concatDotProtoIdentifier: Qualified"
(_ , Qualified{} ) -> internalError "concatDotProtoIdentifier Qualified"
(Anonymous , Anonymous ) -> pure Anonymous
(Anonymous , b ) -> pure b
(a , Anonymous ) -> pure a
(Single a , b ) -> concatDotProtoIdentifier (Dots (Path (pure a))) b
(a , Single b ) -> concatDotProtoIdentifier a (Dots (Path (pure b)))
(Dots (Path a), Dots (Path b)) -> pure (Dots (Path (a <> b)))
-- | @'toPascalCase' xs'@ sends a snake-case string @xs@ to a pascal-cased string. Trailing underscores are not dropped
-- from the input string and exactly double underscores are replaced by a single underscore.
toPascalCase :: String -> String
toPascalCase xs = foldMap go (segmentBy (== '_') xs)
where
go (Left seg) = toUpperFirst seg
go (Right seg)
| seg == "__" = "_"
| otherwise = ""
-- | @'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'
-- | Uppercases the first character of a string.
--
-- ==== __Examples__
--
-- >>> toUpperFirst "abc"
-- "Abc"
--
-- >>> toUpperFirst ""
-- ""
toUpperFirst :: String -> String
toUpperFirst "" = ""
toUpperFirst (x : xs) = toUpper x : xs
-- | @'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
([], []) -> []
(ys, []) -> [Right ys]
([], ys) -> Left seg : segmentBy p ys'
where
(seg, ys') = break p ys
(xs', ys) -> Right xs' : Left seg : segmentBy p ys'
where
(seg, ys') = break p ys
-- | @'suffixBy' p xs@ yields @'Right' (xs', suf)@ if @suf@ is the longest suffix satisfying @p@ and @xs'@ is the rest
-- of the rest, otherwise the string is given back as @'Left' xs@ signifying @xs@ had no suffix satisfying @p@.
suffixBy :: forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy p xs' = do
(pref, suf) <- foldr go (Left []) xs'
if null suf
then Left pref
else return (pref, suf)
where
go :: a -> Either [a] ([a], [a]) -> Either [a] ([a], [a])
go x (Right (xs, suf)) = Right (x : xs, suf)
go x (Left xs)
| p x = Left (x : xs)
| otherwise = Right ([x], xs)
-- | @'typeLikeName' xs@ produces either the pascal-cased version of the string @xs@ if it begins with an alphabetical
-- character or underscore - which is replaced with 'X'. A 'CompileError' is emitted if the starting character is
-- non-alphabetic or if @xs == ""@.
typeLikeName :: MonadError CompileError m => String -> m String
typeLikeName "" = invalidTypeNameError "<empty name>"
typeLikeName s@(x : xs)
| isAlpha x = pure $ case suffixBy (== '_') s of
Left xs' -> invalidToCamelCase $ toPascalCase xs'
Right (xs', suf) -> invalidToCamelCase $ toPascalCase xs' <> suf
| x == '_' = pure $ case suffixBy (== '_') xs of
Left xs' -> invalidToCamelCase $ 'X' : toPascalCase xs'
Right (xs', suf) -> invalidToCamelCase $ 'X' : (toPascalCase xs' <> suf)
| otherwise = invalidTypeNameError s
where
-- Transforms special characters that are not valid as a part of a Haskell name to CamelCase.
-- For instance “foo-bar---baz” will become “FooBarBaz”.
-- This function presumes that the first character of the initial value satisfies "isAlpha".
-- This must be checked outside of this function.
invalidToCamelCase a =
case span isValidNameChar a of
("", "") -> ""
("", cs) -> invalidToCamelCase . dropWhile (not . isValidNameChar) $ cs
(b : bs, cs) -> toUpper b : bs <> invalidToCamelCase cs
-- Only valid as a secondary character.
-- First character of a Haskell name can only be "isAlpha".
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
-- is left unchanged.
fieldLikeName :: String -> String
fieldLikeName "" = ""
fieldLikeName (x : xs)
| isUpper x = map toLower prefix ++ suffix
| otherwise = x : xs
where (prefix, suffix) = span isUpper (x : xs)
prefixedEnumFieldName :: String -> String -> String
prefixedEnumFieldName enumName enumItem = enumName ++ enumItem
prefixedConName :: MonadError CompileError m => String -> String -> m String
prefixedConName msgName conName = do
constructor <- typeLikeName conName
return (msgName ++ constructor)
-- | @'prefixedMethodName' service method@ produces a Haskell record selector name for the service method @method@ by
-- joining the names @service@, @method@ under concatenation on a camel-casing transformation.
prefixedMethodName :: MonadError CompileError m => String -> String -> m String
prefixedMethodName _ "" = invalidTypeNameError "<empty name>"
prefixedMethodName serviceName (x : xs)
| isLower x = return (fieldLikeName serviceName ++ fieldLikeName (x : xs))
| otherwise = do
method <- typeLikeName (x : xs)
return (fieldLikeName serviceName ++ method)
-- | @'prefixedFieldName' prefix field@ constructs a Haskell record selector name by prepending @prefix@ in camel-case
-- to the message field/service method name @field@.
prefixedFieldName :: MonadError CompileError m => String -> String -> m String
prefixedFieldName msgName fieldName = do
field <- typeLikeName fieldName
return (fieldLikeName msgName ++ field)
dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentUnqualName (Single name) = pure name
dpIdentUnqualName (Dots (Path names)) = pure (NE.last names)
dpIdentUnqualName (Qualified _ next) = dpIdentUnqualName next
dpIdentUnqualName Anonymous = internalError "dpIdentUnqualName: Anonymous"
dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentQualName (Single name) = pure name
dpIdentQualName (Dots (Path names)) = pure (intercalate "." (NE.toList names))
dpIdentQualName (Qualified _ _) = internalError "dpIdentQualName: Qualified"
dpIdentQualName Anonymous = internalError "dpIdentQualName: Anonymous"
-- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name
-- of this type, generate the corresponding Haskell name
nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String
nestedTypeName Anonymous nm = typeLikeName nm
nestedTypeName (Single parent) nm = intercalate "_" <$> traverse typeLikeName [parent, nm]
nestedTypeName (Dots (Path parents)) nm = intercalate "_" . (<> [nm]) <$> traverse typeLikeName (NE.toList parents)
nestedTypeName (Qualified {}) _ = internalError "nestedTypeName: Qualified"
qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName parentIdent msgIdent = nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent
qualifiedMessageTypeName :: MonadError CompileError m =>
TypeContext ->
DotProtoIdentifier ->
DotProtoIdentifier ->
m String
qualifiedMessageTypeName ctxt parentIdent msgIdent = do
xs <- parents parentIdent []
case xs of
[] -> nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent
x : xs' -> nestedTypeName (Dots . Path $ x NE.:| xs') =<< dpIdentUnqualName msgIdent
where
parents par@(Single x) xs =
case M.lookup par ctxt of
Just (DotProtoTypeInfo { dotProtoTypeInfoParent = parentIdent' }) ->
parents parentIdent' $ x : xs
Nothing ->
pure $ x : xs
parents Anonymous xs =
pure xs
parents par _ =
internalError $ "qualifiedMessageTypeName: wrong parent " <> show par
--------------------------------------------------------------------------------
--
-- ** Codegen bookkeeping helpers
--
-- | Bookeeping for qualified fields
data QualifiedField = QualifiedField
{ recordFieldName :: FieldName
, fieldInfo :: FieldInfo
} deriving Show
-- | Bookkeeping for fields
data FieldInfo
= FieldOneOf FieldName OneofField
| FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption]
deriving Show
-- | Bookkeeping for oneof fields
data OneofField = OneofField
{ oneofType :: String
, subfields :: [OneofSubfield]
} deriving Show
-- | Bookkeeping for oneof subfields
data OneofSubfield = OneofSubfield
{ subfieldNumber :: FieldNumber
, subfieldConsName :: String
, subfieldName :: FieldName
, subfieldType :: DotProtoType
, subfieldOptions :: [DotProtoOption]
} deriving Show
getQualifiedFields :: MonadError CompileError m
=> String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case
DotProtoMessageField DotProtoField{..} -> do
fieldName <- dpIdentUnqualName dotProtoFieldName
qualName <- prefixedFieldName msgName fieldName
pure . (:[]) $ QualifiedField { recordFieldName = coerce qualName
, fieldInfo = FieldNormal (coerce fieldName)
dotProtoFieldNumber
dotProtoFieldType
dotProtoFieldOptions
}
DotProtoMessageOneOf _ [] ->
throwError (InternalError "getQualifiedFields: encountered oneof with no oneof fields")
DotProtoMessageOneOf oneofIdent fields -> do
ident <- dpIdentUnqualName oneofIdent
oneofName <- prefixedFieldName msgName ident
oneofTypeName <- prefixedConName msgName ident
let mkSubfield DotProtoField{..} = do
s <- dpIdentUnqualName dotProtoFieldName
c <- prefixedConName oneofTypeName s
pure [ OneofSubfield
{ subfieldNumber = dotProtoFieldNumber
, subfieldConsName = c
, subfieldName = coerce s
, subfieldType = dotProtoFieldType
, subfieldOptions = dotProtoFieldOptions
}
]
fieldElems <- foldMapM mkSubfield fields
pure . (:[]) $ QualifiedField
{ recordFieldName = coerce oneofName
, fieldInfo = FieldOneOf (coerce ident) (OneofField ident fieldElems)
}
_ -> pure []
-- | Project qualified fields, given a projection function per field type.
foldQF :: (FieldName -> FieldNumber -> a) -- ^ projection for normal fields
-> (OneofField -> a) -- ^ projection for oneof fields
-> QualifiedField
-> a
foldQF f _ (QualifiedField _ (FieldNormal fldName fldNum _ _)) = f fldName fldNum
foldQF _ g (QualifiedField _ (FieldOneOf _ fld)) = g fld
fieldBinder :: FieldNumber -> String
fieldBinder = ("f" ++) . show
oneofSubBinder :: OneofSubfield -> String
oneofSubBinder = fieldBinder . subfieldNumber
oneofSubDisjunctBinder :: [OneofSubfield] -> String
oneofSubDisjunctBinder = intercalate "_or_" . fmap oneofSubBinder
--------------------------------------------------------------------------------
--
-- * Errors
--
data CompileError
= CircularImport FilePath
| CompileParseError ParseError
| InternalError String
| InvalidPackageName DotProtoIdentifier
| InvalidMethodName DotProtoIdentifier
| InvalidModuleName String
| InvalidTypeName String
| InvalidMapKeyType String
| NoPackageDeclaration
| NoSuchType DotProtoIdentifier
| NonzeroFirstEnumeration String DotProtoIdentifier Int32
| EmptyEnumeration String
| Unimplemented String
| RedefinedFields (Histogram FieldName) (Histogram FieldNumber)
-- ^ At least one field/oneof name and or field number was
-- used more than once within the same message definition,
-- which violates the protobuf specification. The histograms
-- mention only the repeated names and numbers, not the ones
-- used only once.
deriving (Show, Eq)
internalError :: MonadError CompileError m => String -> m a
internalError = throwError . InternalError
invalidTypeNameError :: MonadError CompileError m => String -> m a
invalidTypeNameError = throwError . InvalidTypeName
_unimplementedError :: MonadError CompileError m => String -> m a
_unimplementedError = throwError . Unimplemented
invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a
invalidMethodNameError = throwError . InvalidMethodName
noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a
noSuchTypeError = throwError . NoSuchType
newtype Histogram a = Histogram (M.Map a Int)
deriving stock (Eq, Ord, Show)
instance Ord a => Semigroup (Histogram a)
where
Histogram x <> Histogram y = Histogram (M.unionWith (+) x y)
instance Ord a => Monoid (Histogram a)
where
mempty = Histogram M.empty
oneOccurrence :: a -> Histogram a
oneOccurrence k = Histogram (M.singleton k 1)
mulipleOccurrencesOnly :: Histogram a -> Histogram a
mulipleOccurrencesOnly (Histogram m) = Histogram (M.filter (1 <) m)