Merge branch 'nnmrts-master'

Registry/Grammar.hs

@@ -41,6 +41,18 @@ lookup key dict = let head = dict !! 0 in
      else
          lookup key (tail dict)
 
+lookupsmaybe :: String -> [(String, String)] -> Maybe [String]
+lookupsmaybe key [] = Nothing
+lookupsmaybe key dict = let head = dict !! 0 in
+     if key == fst head then
+      let rest = lookupsmaybe key (tail dict) in
+        if isJust rest then
+          Just ((snd head) : fromJust rest)
+        else
+          Just ([snd head])
+     else
+         lookupsmaybe key (tail dict)
+
 lookups :: String -> [(String, String)] -> [String]
 lookups key [] = []
 lookups key dict = let head = dict !! 0 in
@@ -67,7 +79,7 @@ recordFactory r =
                 (lookup "Macrolanguage" r)
                 (lookup "Deprecated" r)
                 (lookup "Scope" r)
-                (lookup "Comments" r)
+                (lookupsmaybe "Comments" r)
                                    ))
          "extlang" -> Right (Extl (Extlang
                 (fromJust (lookup "Subtag" r))
@@ -84,20 +96,20 @@ recordFactory r =
                 (lookups "Description" r)
                 (fromJust (lookup "Added" r))
                 (lookup "Deprecated" r)
-                (lookup "Comments" r)))
+                (lookupsmaybe "Comments" r)))
          "region" -> Right (Reg (Region
                 (fromJust (lookup "Subtag" r))
                 (lookups "Description" r)
                 (fromJust (lookup "Added" r))
                 (lookup "Deprecated" r)
-                (lookup "Comments" r)))
+                (lookupsmaybe "Comments" r)))
          "variant" -> Right (Var (Variant
                 (fromJust (lookup "Subtag" r))
                 (lookups "Description" r)
                 (fromJust (lookup "Added" r))
                 (lookups "Prefix" r)
                 (lookup "Deprecated" r)
-                (lookup "Comments" r)))
+                (lookupsmaybe "Comments" r)))
          "redundant" -> Right (Red (Redundant
                 (fromJust (lookup "Tag" r))
                 (lookups "Description" r)

Registry/Types.hs

@@ -9,7 +9,7 @@ data Language = Language {lang'subtag::String, lang'descr::[String],
                          lang'macroLanguage::Maybe String, 
                          lang'deprecated::Maybe DateTime,
                          lang'scope::Maybe String,
-                         lang'comment::Maybe String
+                         lang'comment::Maybe [String]
                          } 
                      deriving Show
 
@@ -22,16 +22,16 @@ data Extlang = Extlang {extlang'subtag::String, extlang'descr::[String],
                      deriving Show
 
 data Script = Script {script'subtag::String, script'descr::[String],
-                       script'added::DateTime, script'deprecated::Maybe DateTime, script'comment::Maybe String} deriving Show
+                       script'added::DateTime, script'deprecated::Maybe DateTime, script'comment::Maybe [String]} deriving Show
 
 data Region = Region {region'subtag::String, region'descr::[String],
-                      region'added::DateTime, region'deprecated::Maybe DateTime, region'comment::Maybe String} deriving Show
+                      region'added::DateTime, region'deprecated::Maybe DateTime, region'comment::Maybe [String]} deriving Show
                       -- TODO: PreferredValue
 
 data Variant = Variant {variant'subtag::String, variant'descr::[String],
                       variant'added::DateTime, variant'prefix::[String],
                       variant'deprecated::Maybe DateTime,
-                      variant'comment::Maybe String} deriving Show
+                      variant'comment::Maybe [String]} deriving Show
 
 data Redundant = Redundant {redundant'tag::String, redundant'descr::[String],
                       redundant'added::DateTime} deriving Show

Registry/Utils.hs

@@ -100,6 +100,8 @@ toSubtag (Red r) = (redundant'tag r)
 
 maybeToString Nothing = ""
 maybeToString (Just s) = s
+maybeListToString Nothing = ""
+maybeListToString (Just s) = (foldr (++) "" s)
 dateToString d = d
 descrToString a = concat (List.intersperse " / " a)
 prefixesToString a = concat (List.intersperse " / " a)
@@ -107,21 +109,21 @@ toString (Lang l) = (lang'subtag l) ++ "\t" ++ dateToString (lang'added l) ++ "\
                      descrToString (lang'descr l) ++ "\t" ++
                      (maybeToString (lang'script l)) ++ "\t" ++
                      (maybeToString (lang'deprecated l)) ++ "\t" ++ 
-                     (maybeToString (lang'comment l)) ++ "\n"
+                     (maybeListToString (lang'comment l)) ++ "\n"
 toString (GF t) = (gf'tag t) ++ "\n"
 toString (Scr s) = (script'subtag s) ++ "\t" ++ dateToString (script'added s) ++ "\t" ++
                      descrToString (script'descr s) ++ "\t" ++
                      (maybeToString (script'deprecated s)) ++ "\t" ++ 
-                     (maybeToString (script'comment s)) ++ "\n"
+                     (maybeListToString (script'comment s)) ++ "\n"
 toString (Reg r) = (region'subtag r) ++ "\t" ++ dateToString (region'added r) ++ "\t" ++
                      descrToString (region'descr r) ++ "\t" ++
                      (maybeToString (region'deprecated r)) ++ "\t" ++ 
-                     (maybeToString (region'comment r)) ++ "\n"
+                     (maybeListToString (region'comment r)) ++ "\n"
 toString (Var v) = (variant'subtag v) ++ "\t" ++ dateToString (variant'added v) ++ "\t" ++
                      descrToString (variant'descr v) ++ "\t" ++ 
                      prefixesToString (variant'prefix v) ++ "\t" ++
                      (maybeToString (variant'deprecated v)) ++ "\t" ++ 
-                     (maybeToString (variant'comment v)) ++ "\n"
+                     (maybeListToString (variant'comment v)) ++ "\n"
 toString (Red r) = (redundant'tag r) ++ "\t" ++ dateToString (redundant'added r) ++ "\t" ++
                      descrToString (redundant'descr r) ++ "\n"
 
@@ -130,7 +132,7 @@ addedToXML d = "<added>" ++ d ++ "</added>"
 deprecatedToXML Nothing = ""
 deprecatedToXML (Just d) = "<deprecated>" ++ d ++ "</deprecated>"
 commentToXML Nothing = ""
-commentToXML (Just c) = "<comments>" ++ (escapexml c) ++ "</comments>"
+commentToXML (Just c) = "<comments>" ++ (foldr (++) "" (map escapexml c)) ++ "</comments>" -- TODO Add whitespace if there are several comments before concatenation.
 sscriptToXML Nothing = ""
 sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>"
 prefToXML Nothing = ""
@@ -208,7 +210,7 @@ descrToHTML a = concat (List.intersperse " / " (map onedescrToHTML a))
 oneprefixToHTML s = " Possible prefix: <code><a href=\"../language/" ++ s ++ ".html\">" ++ s ++ "</a></code>"
 prefixesToHTML a = concat (map oneprefixToHTML a)
 commentToHTML Nothing = ""
-commentToHTML (Just s) = " Comment: " ++ (escapexml s)
+commentToHTML (Just s) = " Comment: " ++ (foldr (++) "" (map escapexml s))
 deprecatedToHTML Nothing = ""
 deprecatedToHTML (Just s) = " Deprecated: " ++ s
 

Registry/Utils/PostgreSQL.hs

@@ -11,6 +11,8 @@ escape = concatMap fixChar
 
 maybeToPostgreSQL Nothing = "NULL"
 maybeToPostgreSQL (Just s) = "'" ++ (escape s) ++ "'"
+maybeListToPostgreSQL Nothing = ""
+maybeListToPostgreSQL (Just s) = "'" ++ (foldr (++) "" s) ++ "'"
 
 onedescrToPostgreSQL "language" i s = "INSERT INTO Descriptions (description) " ++
                          "    VALUES ('" ++ (escape s) ++ "');\n" ++ 
@@ -37,7 +39,7 @@ toPostgreSQL (Lang l) = "INSERT INTO Languages (code, suppressscript, " ++
                             (maybeToPostgreSQL (lang'script l)) ++ ", " ++
                             (maybeToPostgreSQL (lang'preferredValue l)) ++ ", " ++
                             (maybeToPostgreSQL (lang'deprecated l)) ++ ", " ++ 
-                            (maybeToPostgreSQL (lang'comment l)) ++ ", " ++ 
+                            (maybeListToPostgreSQL (lang'comment l)) ++ ", " ++ 
                             "'" ++ (lang'added l) ++ "');\n" ++
                          (descrToPostgreSQL "language" (lang'descr l) (lang'subtag l))
 
@@ -45,7 +47,7 @@ toPostgreSQL (Scr s) = "INSERT INTO Scripts (code, deprecated, comments, added)
                           "VALUES (" ++
                             "'" ++ (script'subtag s) ++ "', " ++
                             (maybeToPostgreSQL (script'deprecated s)) ++ ", " ++ 
-                            (maybeToPostgreSQL (script'comment s)) ++ ", " ++ 
+                            (maybeListToPostgreSQL (script'comment s)) ++ ", " ++ 
                             "'" ++ (script'added s) ++ "');\n" ++
                         (descrToPostgreSQL "script" (script'descr s) (script'subtag s))
 
@@ -53,7 +55,7 @@ toPostgreSQL (Reg r) = "INSERT INTO Regions (code, deprecated, comments, added)
                           "VALUES (" ++
                             "'" ++ (region'subtag r) ++ "', " ++
                             (maybeToPostgreSQL (region'deprecated r)) ++ ", " ++ 
-                            (maybeToPostgreSQL (region'comment r)) ++ ", " ++ 
+                            (maybeListToPostgreSQL (region'comment r)) ++ ", " ++ 
                             "'" ++ (region'added r) ++ "');\n" ++
                         (descrToPostgreSQL "region" (region'descr r) (region'subtag r))
 
@@ -61,7 +63,7 @@ toPostgreSQL (Var v) = "INSERT INTO Variants (code, deprecated, comments, added)
                           "VALUES (" ++
                             "'" ++ (variant'subtag v) ++ "', " ++
                             (maybeToPostgreSQL (variant'deprecated v)) ++ ", " ++ 
-                            (maybeToPostgreSQL (variant'comment v)) ++ ", " ++ 
+                            (maybeListToPostgreSQL (variant'comment v)) ++ ", " ++ 
                             "'" ++ (variant'added v) ++ "');\n" ++
                         (descrToPostgreSQL "variant" (variant'descr v) (variant'subtag v))
 

Registry/Utils/SQLite.hs

@@ -11,6 +11,8 @@ escape = concatMap fixChar
 
 maybeToSQLite Nothing = "NULL"
 maybeToSQLite (Just s) = "'" ++ (escape s) ++ "'"
+maybeListToSQLite Nothing = ""
+maybeListToSQLite (Just s) = "'" ++ (foldr (++) "" s) ++ "'"
 
 -- TODO: use "SELECT last_insert_rowid();" is probably cleaner than
 --       "SELECT max(oid)"
@@ -39,7 +41,7 @@ toSQLite (Lang l) = "INSERT INTO Languages (code, suppressscript, " ++
                             (maybeToSQLite (lang'script l)) ++ ", " ++
                             (maybeToSQLite (lang'preferredValue l)) ++ ", " ++
                             (maybeToSQLite (lang'deprecated l)) ++ ", " ++ 
-                            (maybeToSQLite (lang'comment l)) ++ ", " ++ 
+                            (maybeListToSQLite (lang'comment l)) ++ ", " ++ 
                             "'" ++ (lang'added l) ++ "');\n" ++
                          (descrToSQLite "language" (lang'descr l) (lang'subtag l))
 
@@ -47,7 +49,7 @@ toSQLite (Scr s) = "INSERT INTO Scripts (code, deprecated, comments, added) " ++
                           "VALUES (" ++
                             "'" ++ (script'subtag s) ++ "', " ++
                             (maybeToSQLite (script'deprecated s)) ++ ", " ++ 
-                            (maybeToSQLite (script'comment s)) ++ ", " ++ 
+                            (maybeListToSQLite (script'comment s)) ++ ", " ++ 
                             "'" ++ (script'added s) ++ "');\n" ++
                         (descrToSQLite "script" (script'descr s) (script'subtag s))
 
@@ -55,7 +57,7 @@ toSQLite (Reg r) = "INSERT INTO Regions (code, deprecated, comments, added) " ++
                           "VALUES (" ++
                             "'" ++ (region'subtag r) ++ "', " ++
                             (maybeToSQLite (region'deprecated r)) ++ ", " ++ 
-                            (maybeToSQLite (region'comment r)) ++ ", " ++ 
+                            (maybeListToSQLite (region'comment r)) ++ ", " ++ 
                             "'" ++ (region'added r) ++ "');\n" ++
                         (descrToSQLite "region" (region'descr r) (region'subtag r))
 
@@ -63,7 +65,7 @@ toSQLite (Var v) = "INSERT INTO Variants (code, deprecated, comments, added) " +
                           "VALUES (" ++
                             "'" ++ (variant'subtag v) ++ "', " ++
                             (maybeToSQLite (variant'deprecated v)) ++ ", " ++ 
-                            (maybeToSQLite (variant'comment v)) ++ ", " ++ 
+                            (maybeListToSQLite (variant'comment v)) ++ ", " ++ 
                             "'" ++ (variant'added v) ++ "');\n" ++
                         (descrToSQLite "variant" (variant'descr v) (variant'subtag v))