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 +++++++++++++++++++--------- 1 file changed, 56 insertions(+), 25 deletions(-) (limited to 'protocols/codegen/Wayland/CodeGen/CodeGen.hs') 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 -- cgit v1.3.1