From 984a1846a1ea2df1d6aa7f10593d5b2218626e47 Mon Sep 17 00:00:00 2001
From: Bryan Donlan <bdonlan@fushizen.net>
Date: Sun, 24 Aug 2008 02:36:39 -0400
Subject: [PATCH] Parse and store javadoc-style docstrings at toplevel

---
 src/Kaos/Compile.hs  |  1 +
 src/Kaos/Parser.hs   | 62 +++++++++++++++++++++++++++++++++++++++++-----------
 src/Kaos/Toplevel.hs |  1 +
 3 files changed, 51 insertions(+), 13 deletions(-)

diff --git a/src/Kaos/Compile.hs b/src/Kaos/Compile.hs
index f5d9ca0..9566afa 100644
--- a/src/Kaos/Compile.hs
+++ b/src/Kaos/Compile.hs
@@ -134,6 +134,7 @@ emitRemove iss = modify $
 
 
 compileUnit :: KaosUnit -> CompileM ()
+compileUnit (DocString _) = return ()
 compileUnit (InstallScript s) = compileCode s >>= emitInstall
 compileUnit (RemoveScript s)  = compileCode s >>= emitRemove
 compileUnit (AgentScript (SContext c i) code) =
diff --git a/src/Kaos/Parser.hs b/src/Kaos/Parser.hs
index 6418ea6..b83fc07 100644
--- a/src/Kaos/Parser.hs
+++ b/src/Kaos/Parser.hs
@@ -26,6 +26,7 @@ import Text.ParserCombinators.Parsec.Expr
 
 import Control.Monad
 import Data.Maybe
+import Data.Char
 import Kaos.AST
 --import Debug.Trace
 import Kaos.Emit (emitConst)
@@ -47,22 +48,32 @@ typeName = (reserved "agent"    >> return typeObj)
 
 root :: Parser KaosSource
 root =  many1 kaosUnit
-    <|> simpleScript
+    <|> (whiteSpace >> simpleScript)
 
 simpleScript :: Parser KaosSource
 simpleScript = liftM (\x -> [InstallScript x]) bareBlock
 
 kaosUnit :: Parser KaosUnit
-kaosUnit =  (installScript <?> "install script")
-        <|> (removeScript  <?> "removal script")
-        <|> (macroBlock    <?> "macro definition")
-        <|> (agentScript   <?> "normal script")
-        <|> (ovdecl        <?> "object variable declaration")
-        <|> (nullOp)
+kaosUnit = tlWhiteSpace >> kaosUnit' >>> tlWhiteSpace
+kaosUnit' :: Parser KaosUnit
+kaosUnit' = mzero
+         <|> (docString     <?> "documentation block")
+         <|> (installScript <?> "install script")
+         <|> (removeScript  <?> "removal script")
+         <|> (macroBlock    <?> "macro definition")
+         <|> (agentScript   <?> "normal script")
+         <|> (ovdecl        <?> "object variable declaration")
+         <|> (nullOp)
+
+docString :: Parser KaosUnit
+docString = do
+    try $ (tlWhiteSpace >> try (char '/' >> many1 (char '*')))
+    s <- manyTill anyChar (try $ many1 (char '*') >> char '/')
+    return $ DocString s
 
 nullOp :: Parser KaosUnit
 nullOp = do
-    reservedOp ";"
+    string ";"
     return $ InstallScript (SBlock [])
 
 ovdecl :: Parser KaosUnit
@@ -72,6 +83,7 @@ ovdecl = do
     t <- typeName
     name <- identifier
     idx <- option Nothing $ fmap Just idxM
+    string ";" -- don't skip whitespace, as this would consume docstrings
     return $ OVDecl name idx t ctx
     where
         idxM :: Parser Int
@@ -83,10 +95,10 @@ ovdecl = do
 
 
 installScript :: Parser KaosUnit
-installScript = reserved "install" >> liftM InstallScript (braces bareBlock)
+installScript = reserved "install" >> liftM InstallScript (tlBraces bareBlock)
 
 removeScript :: Parser KaosUnit
-removeScript  = reserved "remove" >> liftM RemoveScript (braces bareBlock)
+removeScript  = reserved "remove" >> liftM RemoveScript (tlBraces bareBlock)
 
 macroArg :: Parser MacroArg
 macroArg = do
@@ -130,7 +142,7 @@ macroBlock = try constDecl <|> do
     retType <- option typeVoid (reserved "returning" >> typeName)
     when (retType /= typeVoid && mtyp /= MacroRValue) $
         fail "Non-rvalue macros must be void"
-    code <- braces bareBlock
+    code <- tlBraces bareBlock
     return $ MacroBlock ctx $ defaultMacro  { mbName = name
                                             , mbType = mtyp
                                             , mbArgs = args
@@ -186,7 +198,7 @@ agentScript = do
     symbol ","
     scrp <- expr
     symbol ")"
-    code <- braces bareBlock
+    code <- tlBraces bareBlock
     let hblk = SContext ctx $ SScriptHead [fmly, gnus, spcs, scrp]
     return $ AgentScript hblk code
     
@@ -214,6 +226,30 @@ reservedOp= P.reservedOp lexer
 braces :: Parser t -> Parser t
 braces    = P.braces lexer
 
+-- Skip whitespace, except for doc comments
+tlWhiteSpace :: Parser ()
+tlWhiteSpace = do
+        skipMany (simpleSpace <|> oneLineComment <|> multiLineNoDoc)
+        return ()
+    where
+        simpleSpace = skipMany1 (satisfy isSpace) >> return ()
+        oneLineComment = do
+            try $ string "//"
+            skipMany (satisfy (/= '\n'))
+            return ()
+        multiLineNoDoc = try $ do
+            string "/*"
+            satisfy (/= '*')
+            manyTill anyChar (try $ string "*/")
+            return ()
+
+tlBraces :: Parser a -> Parser a
+tlBraces m = do
+    symbol "{"
+    r <- m
+    string "}"
+    return r
+
 -- Do two things, return the first
 (>>>) :: Monad m => m a -> m b -> m a
 a >>> b = do { r <- a; b; return r }
@@ -452,7 +488,7 @@ bareBlock = do
     <?> "bare script"
 
 parser :: Parser KaosSource
-parser = whiteSpace >> root >>> eof
+parser = tlWhiteSpace >> root >>> eof
 
 
 inlineCAOS :: Parser (Statement String)
diff --git a/src/Kaos/Toplevel.hs b/src/Kaos/Toplevel.hs
index 282211f..f62104f 100644
--- a/src/Kaos/Toplevel.hs
+++ b/src/Kaos/Toplevel.hs
@@ -140,6 +140,7 @@ data KaosUnit = InstallScript (Statement String)
               | AgentScript { asHead    :: Statement String
                             , asCode    :: Statement String
                             }
+              | DocString String
               deriving (Show)
 
 type KaosSource = [KaosUnit]
-- 
2.11.4.GIT