add documentation to generated codeHEADmain

4 files changed, 65 insertions, 32 deletions

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