Extend topicidl quasi-quoter

1. Handle # <lineno> ... lines output by CPP, so that one can do
     {-# LANGUAGE CPP #-}
     [topicidl|
     #include "topics.idl"
     |]
2. Interpret lines of the form
     #pragma prefix T P
   to set the fieldname prefix of struct T to P, so that it can be set
   differently for each struct.

Author: Erik Boasson

src/DDS/IDL.hs

@@ -1,9 +1,10 @@
 module DDS.IDL where
 
 import DDS.TopicXML
-import Control.Monad (void)
+import Control.Monad (void, liftM)
 import Data.List (intercalate, intersperse)
 import Data.Char (isSpace)
+import Data.Maybe
 import Debug.Trace
 import Text.Megaparsec
 import Text.Megaparsec.String
@@ -16,19 +17,21 @@ parseIDL idl = case parse specification "(anonymous)" idl of
 
 manySemi = flip endBy semi
 
-specification = sc *> many definition_or_keylist <* eof
+specification = sc *> definitions <* eof
 
-definition_or_keylist = keylist <|> definition
+definitions = liftM catMaybes $ many definition_or_keylist
+
+definition_or_keylist = hashline <|> definition
 
 definition = do
   d <- def_module <|> def_enum <|> def_type <|> def_struct <|> def_union <|> def_const <?> "definition"
   semi
-  return d
+  return $ Just d
 
 def_module = do
   reserved "module"
   name <- identifier
-  defs <- braces $ many definition_or_keylist
+  defs <- braces $ definitions
   return $ DM name defs
 
 def_enum = do
@@ -141,15 +144,31 @@ basetype =
   (sname      >>= return . TR) <?>
   "type"
 
+hashline = symbol "#" >> (pragma <|> linenumber)
+
+pragma = symbol "pragma" >> (keylist <|> prefix)
+
 keylist = do
-  symbol "#"
-  symbol "pragma"
   symbol "keylist"
   name <- snameE
   keys <- many fieldE
   void eol <|> eof
   sc
-  return $ DK name keys
+  return $ Just (DK name keys)
+
+prefix = do
+  symbol "prefix"
+  name <- snameE
+  prefix <- identifierE
+  void eol <|> eof
+  sc
+  return $ Just (DP name prefix)
+
+linenumber = do
+  integer
+  L.skipLineComment ""
+  sc
+  return Nothing
 
 fieldE =
   sepBy1 identifierE dotE >>= return . intercalate "."

src/DDS/TH.hs

@@ -156,6 +156,15 @@ genStruct deriv pfx sc (DS tn ms) = mkStructDataD deriv tn' cs
     cs = map (makeConstructor pfx sc) ms
     tn' = mkName $ cooknameU tn
 
+overridePrefix :: String -> Scope -> String -> String
+overridePrefix pfx sc nm
+  | (isNothing . scParent) sc = pfx
+  | isJust mpfx' = pfx'
+  | otherwise = pfx
+  where
+    (_, mpfx') = lookupDef (nm ++ "'Prefix") sc
+    Just (DP _ pfx') = mpfx'
+
 genUnion :: [TH.Name] -> String -> Scope -> Def -> [Dec]
 genUnion deriv pfx sc (DU tn dt cs) = mkUnionDataD deriv tn' ccs
   where
@@ -172,7 +181,9 @@ genEnum deriv pfx sc (DE tn es) =
     tn' = mkName $ cooknameU tn
 
 genDef :: [TH.Name] -> String -> Scope -> Def -> [Dec]
-genDef deriv pfx sc def@(DS tn _) = genStruct deriv pfx sc def ++ genSerdes pfx tn
+genDef deriv pfx sc def@(DS tn _) = genStruct deriv pfx' sc def ++ genSerdes pfx' tn
+  where
+    pfx' = overridePrefix pfx sc tn
 genDef deriv pfx sc def@(DE tn _) = genEnum deriv "" sc def ++ genSerdes "" tn
 genDef deriv pfx sc def@(DU tn _ _) = genUnion deriv pfx sc def ++ genSerdes pfx tn
 

src/DDS/TopicXML.hs

@@ -38,6 +38,7 @@ topicsFromMetaData md = concatMap (fDef "" sc) ds
     fDef pr sc (DE n es) = []
     fDef pr sc (DK n ks) = [makeTopicMD pr sc n ks]
     fDef pr sc (DC n v)  = []
+    fDef pr sc (DP n pfx) = []
     fT :: String -> Scope -> T -> [TopicMD]
     fT pr sc (TDef d)    = fDef pr sc d
     fT pr sc (TSeq b t)  = fT pr sc t
@@ -179,7 +180,7 @@ xpMetaData = xpWrap (MD, \(MD ds) -> ds) $
              xpElem "MetaData" $ xpAddFixedAttr "version" "1.0.0" $ xpickle
 
 type Name = String
-data Def = DT Name T | DM Name [Def] | DS Name [M] | DU Name T [UC] | DE Name [E] | DC Name Int | DK Name [Name] deriving (Show, Eq)
+data Def = DT Name T | DM Name [Def] | DS Name [M] | DU Name T [UC] | DE Name [E] | DC Name Int | DK Name [Name] | DP Name Name deriving (Show, Eq)
 instance XmlPickler Def where
   xpickle = xpAlt tag ps
     where
@@ -190,6 +191,7 @@ instance XmlPickler Def where
       tag (DE _ _) = 4
       tag (DC _ _) = 5 -- Const isn't part of OSPL meta data, temp for getting enum const in Scope
       tag (DK _ _) = 6 -- Keylist isn't part, but should've been :) (certainly makes parsing IDL easier)
+      tag (DP _ _) = 7 -- Field prefix (Haskell specific)
       ps = [ xpWrap (uncurry DT, \(DT nm t) -> (nm, t)) $
              (xpElem "TypeDef" $ xpPair (xpAttr "name" xpText) xpickle)
            , xpWrap (uncurry DM, \(DM nm ds) -> (nm, ds)) $
@@ -204,6 +206,8 @@ instance XmlPickler Def where
              (xpElem "Const" $ xpPair (xpAttr "name" xpText) $ xpickle)
            , xpWrap (\(nm, ks) -> DK nm (splitOn "," ks), \(DK nm ks) -> (nm, intercalate "," ks)) $
              (xpElem "KeyList" $ xpPair (xpAttr "name" xpText) (xpAttr "keys" xpText))
+           , xpWrap (\(nm, pfx) -> DP nm pfx, \(DP nm pfx) -> (nm, pfx)) $
+             (xpElem "FieldPrefix" $ xpPair (xpAttr "name" xpText) (xpAttr "prefix" xpText))
            ]
 
 data E = E Name Int deriving (Show, Eq)
@@ -307,6 +311,7 @@ cDef ps t@(DE nm es) = res
 cDef ps t@(DT nm _) = Scope ps [] [(nm, t)]
 cDef ps t@(DC nm _) = Scope ps [] [(nm, t)]
 cDef ps (DK _ _) = Scope ps [] []
+cDef ps t@(DP nm pfx) = Scope ps [] [(nm ++ "'Prefix", t)] -- a bit of a hack to use a 'Prefix suffix
 
 cT :: Maybe Scope -> T -> Scope
 cT ps (TDef d) = cDef ps d