From 7b2990b55da8a43e1fe4d8c04e77a76ebac446c8 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Wed, 14 Aug 2024 22:34:25 +0200 Subject: add documentation to generated code --- protocols/codegen/Wayland/CodeGen/CodeGen.hs | 81 +++++++++++++++++++--------- protocols/codegen/Wayland/CodeGen/Parser.hs | 12 +++-- protocols/codegen/Wayland/CodeGen/Types.hs | 2 - protocols/codegen/Wayland/CodeGen/Utils.hs | 2 +- 4 files changed, 65 insertions(+), 32 deletions(-) (limited to 'protocols/codegen') diff --git a/protocols/codegen/Wayland/CodeGen/CodeGen.hs b/protocols/codegen/Wayland/CodeGen/CodeGen.hs index 67d02dd..02a4f76 100644 --- a/protocols/codegen/Wayland/CodeGen/CodeGen.hs +++ b/protocols/codegen/Wayland/CodeGen/CodeGen.hs @@ -6,8 +6,6 @@ module Wayland.CodeGen.CodeGen , generateInterfaceBoot ) where --- TODO: Documentation - import Wayland.CodeGen.Types import Wayland.CodeGen.Utils import Control.Monad.State.Strict (State, runState) @@ -19,10 +17,16 @@ import Control.Monad.Reader (ReaderT (..), asks) import Data.Map ((!)) import qualified Data.Map as M +data DocComment + = DocCommentBefore + | DocCommentAfter + deriving (Show, Eq) + newtype Declaration = Declaration { declLines :: [String] } -data Import = Import { imModule :: !String - , imSource :: !Bool - } +data Import + = Import { imModule :: !String + , imSource :: !Bool + } deriving (Show, Eq) data GeneratorState @@ -74,7 +78,7 @@ emitImport :: Import -> Generator () emitImport i = stateImports %= \is -> if i `elem` is then is else i:is emitExport :: String -> Generator () -emitExport e = stateExports %= (e:) +emitExport e = stateExports %= \es -> es ++ [e] emitExtension :: String -> Generator () emitExtension e = stateExtensions %= (e:) @@ -158,8 +162,9 @@ emit = do emitExtension "GeneralizedNewtypeDeriving" emitExtension "EmptyDataDeriving" emitExtension "FlexibleInstances" - emitDecl [ "newtype Object = Object " ++ anyObject - , " deriving (Show, Eq, Ord, " ++ hashable ++ ")" ] + emitDecl (formatDescription "" DocCommentBefore (ifDescription i) ++ + [ "newtype Object = Object " ++ anyObject + , " deriving (Show, Eq, Ord, " ++ hashable ++ ")" ]) emitExport "Object" mapM_ (emitMessageDesc requestDescName) (ifRequests i) mapM_ (emitMessageDesc eventDescName) (ifEvents i) @@ -256,7 +261,8 @@ emitInterfaceDesc = do ifRequests' <- resolve "Wayland.Server" "ifRequests" ifEvents' <- resolve "Wayland.Server" "ifEvents" i <- asks genInterface - emitDecl [ "interface :: " ++ interfaceDesc + emitDecl [ "-- | Description of the interface." + , "interface :: " ++ interfaceDesc , "interface =" , " " ++ interfaceDesc , " { " ++ ifName' ++ " = " ++ escapeStr (ifName i) @@ -273,13 +279,14 @@ eventConstructor :: MessageDesc -> String eventConstructor m = "Ev" ++ pascalCase (msgName m) emitRequests :: [MessageDesc] -> Generator () -emitRequests ms = emitMessages ms typeRequestArgs (\m -> requestConstructor m ++ " Object") "Request" +emitRequests ms = emitMessages ms typeRequestArgs formatConstructor "Request" "Requests supported by the interface." + where formatConstructor m = requestConstructor m ++ " Object" emitEvents :: [MessageDesc] -> Generator () -emitEvents ms = emitMessages ms typeEventArgs eventConstructor "Event" +emitEvents ms = emitMessages ms typeEventArgs eventConstructor "Event" "Events supported by the interface." -emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentName) -> (MessageDesc -> String) -> String -> Generator () -emitMessages ms argTypes formatConstructor type' = do +emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentName) -> (MessageDesc -> String) -> String -> String -> Generator () +emitMessages ms argTypes formatConstructor type' comment = do typeable <- resolve "Data.Typeable" "Typeable" messageClass <- resolve "Wayland.Server" "MessageClass" typeClass <- resolve "Wayland.Server" (type' ++ "Class") @@ -288,9 +295,11 @@ emitMessages ms argTypes formatConstructor type' = do constructorArg ArgumentNameNone = pure "" constructorArg (ArgumentNameSingle a) = (++) " " <$> resolveArgument a constructorArg (ArgumentNameRecord _ r) = pure $ " " ++ r - let constructor m = (++) (formatConstructor m) <$> constructorArg (args ! msgName m) + let constructor m = do arg <- constructorArg (args ! msgName m) + pure $ (formatConstructor m ++ arg) : formatDescription " " DocCommentAfter (msgDescription m) constructors <- mapM constructor ms - emitDecl $ [ "data " ++ type' ] + emitDecl $ [ "-- | " ++ comment + , "data " ++ type' ] ++ dataConstructors constructors ++ [ " deriving (" ++ typeable ++ ", Show, Eq)" ] emitExport $ type' ++ "(..)" @@ -309,7 +318,7 @@ demarshalRequest m = do pure ([ " demarshalRequest o " ++ show (msgOpCode m) ++ " = do" ] ++ fmap apply as ++ [ " pure $ " ++ requestConstructor m ++ " o $ " ++ r ] - ++ formatBrackets " {" " ," " }" (fmap field as)) + ++ formatBrackets " {" " ," " }" (fmap (pure . field) as)) marshalEvent :: MessageDesc -> Generator [String] marshalEvent m = do @@ -331,8 +340,10 @@ emitEnum e = do let EnumName _ name = types ! enumName e let constructorName entry = name ++ pascalCase (entryName entry) let constructorNames = fmap constructorName (enumEntries e) - let constructors = dataConstructors constructorNames - emitDecl ([ "data " ++ name ] + let constructorDecl (cName, entry) = cName : formatDescription " " DocCommentAfter (entryDescription entry) + let constructors = dataConstructors (fmap constructorDecl (zip constructorNames (enumEntries e))) + emitDecl (formatDescription "" DocCommentBefore (enumDescription e) ++ + [ "data " ++ name ] ++ constructors ++ [ " deriving (Show, Eq)" ]) emitExport $ name ++ "(..)" @@ -375,13 +386,14 @@ emitMarshallableBitfield name values = do , " x <- " ++ demarshalUInt' , " let val v v' = if x " ++ bitAnd ++ " v == v then Just v' else Nothing" , " pure $ " ++ catMaybes' ] - ++ formatBrackets " [" " ," " ]" (fmap demarshalVal values)) + ++ formatBrackets " [" " ," " ]" (fmap (pure . demarshalVal) values)) emitArguments :: ArgumentName -> Generator () emitArguments ArgumentNameNone = pure () emitArguments (ArgumentNameSingle _) = pure () emitArguments (ArgumentNameRecord args name) = do - let field (a, aName) = recordField name (camelCase (argName a)) ++ " :: " ++ aName + let field (a, aName) = (recordField name (camelCase (argName a)) ++ " :: " ++ aName) + : formatDescription " " DocCommentAfter (argDescription a) resolvedArgs <- mapM resolveArgument args emitDecl ([ "data " ++ name , " = " ++ name ] @@ -389,16 +401,35 @@ emitArguments (ArgumentNameRecord args name) = do [ " deriving (Show, Eq)" ]) emitExport $ name ++ "(..)" -formatBrackets :: String -> String -> String -> [String] -> [String] +formatBrackets :: String -> String -> String -> [[String]] -> [String] formatBrackets open sep close ls = format ls ++ [close] where format [] = [open] - format (x:xs) = (open ++ " " ++ x) : fmap format' xs - format' x = sep ++ " " ++ x + format (x:xs) = addPrefix (open ++ " ") x ++ concatMap (addPrefix (sep ++ " ")) xs -dataConstructors :: [String] -> [String] -dataConstructors (c:cs) = (" = " ++ c) : fmap (" | " ++) cs +dataConstructors :: [[String]] -> [String] +dataConstructors (c:cs) = addPrefix " = " c ++ concatMap (addPrefix " | ") cs dataConstructors [] = [] +formatDescription :: String -> DocComment -> Maybe Description -> [String] +formatDescription _ _ Nothing = [] +formatDescription indent comment (Just desc) = formatLines $ intercalate [""] sections + where sections = lines (descSummary desc) : [bodySection | not (null bodySection)] + bodySection = trim [""] $ trim "\t " <$> lines (descBody desc) + formatLines :: [String] -> [String] + formatLines [] = [] + formatLines (x:xs) = (indent ++ "-- " ++ startComment comment ++ x) : fmap formatLine' xs + formatLine' x = indent ++ "-- " ++ x + startComment DocCommentBefore = "| " + startComment DocCommentAfter = "^ " + +trim :: Eq a => [a] -> [a] -> [a] +trim xs = f . f + where f = reverse . dropWhile (`elem` xs) + +addPrefix :: [a] -> [[a]] -> [[a]] +addPrefix p [] = [p] +addPrefix p (x:xs) = (p ++ x) : xs + escapeStr :: String -> String escapeStr str = "\"" ++ escapeInner str ++ "\"" where escapeInner ('\"':xs) = "\\\"" ++ escapeInner xs diff --git a/protocols/codegen/Wayland/CodeGen/Parser.hs b/protocols/codegen/Wayland/CodeGen/Parser.hs index 15afbb9..c7023ed 100644 --- a/protocols/codegen/Wayland/CodeGen/Parser.hs +++ b/protocols/codegen/Wayland/CodeGen/Parser.hs @@ -6,6 +6,7 @@ import Data.Maybe (fromMaybe) import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc) import Text.Read (readEither) import Wayland.CodeGen.Types +import Control.Applicative ((<|>)) parseProtocolSpec :: String -> Either String Protocol parseProtocolSpec s = case parseXMLDoc s of @@ -71,8 +72,7 @@ processEntry el = do let summary = findAttrBy (matchName "summary") el pure $ EntryDesc { entryName = name , entryValue = value - , entryDescription = description - , entrySummary = summary + , entryDescription = description <|> simpleDescription <$> summary , entrySince = fromMaybe 1 since , entryDeprecatedSince = deprecatedSince } @@ -105,8 +105,7 @@ processArgument el = do let enum = findAttrBy (matchName "enum") el pure $ ArgumentDesc { argName = name , argType = type' - , argDescription = description - , argSummary = summary + , argDescription = description <|> simpleDescription <$> summary , argInterface = interface , argEnum = enum , argAllowNull = fromMaybe False allowNull @@ -142,3 +141,8 @@ readArgumentType "fd" = Right ArgumentFD readArgumentType "new_id" = Right ArgumentNewID readArgumentType "object" = Right ArgumentObject readArgumentType x = Left $ "Expected an argument type, got " ++ x + +simpleDescription :: String -> Description +simpleDescription summary = Description { descSummary = summary + , descBody = "" + } diff --git a/protocols/codegen/Wayland/CodeGen/Types.hs b/protocols/codegen/Wayland/CodeGen/Types.hs index b582a27..11b5be8 100644 --- a/protocols/codegen/Wayland/CodeGen/Types.hs +++ b/protocols/codegen/Wayland/CodeGen/Types.hs @@ -57,7 +57,6 @@ data EntryDesc = EntryDesc { entryName :: !String , entryValue :: !Int , entryDescription :: !(Maybe Description) - , entrySummary :: !(Maybe String) , entrySince :: !Int , entryDeprecatedSince :: !(Maybe Int) } @@ -83,7 +82,6 @@ data ArgumentDesc = ArgumentDesc { argName :: !String , argType :: !ArgumentType , argDescription :: !(Maybe Description) - , argSummary :: !(Maybe String) , argInterface :: !(Maybe String) , argEnum :: !(Maybe String) , argAllowNull :: !Bool diff --git a/protocols/codegen/Wayland/CodeGen/Utils.hs b/protocols/codegen/Wayland/CodeGen/Utils.hs index 9f43ab0..b8596f1 100644 --- a/protocols/codegen/Wayland/CodeGen/Utils.hs +++ b/protocols/codegen/Wayland/CodeGen/Utils.hs @@ -74,7 +74,7 @@ resolveMessageType m = case msgArguments m of resolveEnumType :: EnumDesc -> State TypeInfo EnumName resolveEnumType e = EnumName e <$> name - where name = getFreeTypeName (pascalCase (enumName e)) $ if enumBitfield e then Just "Flag" else Nothing + where name = getFreeTypeName (pascalCase (enumName e)) $ Just (if enumBitfield e then "Flag" else "Value") getFreeTypeName :: String -> Maybe String -> State TypeInfo String getFreeTypeName requested conflictSuffix = attemptRequested -- cgit v1.3.1