diff --git a/Registry/Grammar.hs b/Registry/Grammar.hs
index 93bbbba..d3e4876 100644
--- a/Registry/Grammar.hs
+++ b/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)
- (lookups "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)
- (lookups "Comments" r)))
+ (lookupsmaybe "Comments" r)))
"region" -> Right (Reg (Region
(fromJust (lookup "Subtag" r))
(lookups "Description" r)
(fromJust (lookup "Added" r))
(lookup "Deprecated" r)
- (lookups "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)
- (lookups "Comments" r)))
+ (lookupsmaybe "Comments" r)))
"redundant" -> Right (Red (Redundant
(fromJust (lookup "Tag" r))
(lookups "Description" r)
diff --git a/Registry/Types.hs b/Registry/Types.hs
index ecfbf3f..2bbc724 100644
--- a/Registry/Types.hs
+++ b/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
diff --git a/Registry/Utils.hs b/Registry/Utils.hs
index dd98740..541abd9 100644
--- a/Registry/Utils.hs
+++ b/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 = "" ++ d ++ ""
deprecatedToXML Nothing = ""
deprecatedToXML (Just d) = "" ++ d ++ ""
commentToXML Nothing = ""
-commentToXML (Just c) = "" ++ (escapexml c) ++ ""
+commentToXML (Just c) = "" ++ (foldr (++) "" (map escapexml c)) ++ "" -- TODO Add whitespace if there are several comments before concatenation.
sscriptToXML Nothing = ""
sscriptToXML (Just s) = "" ++ s ++ ""
prefToXML Nothing = ""
@@ -208,7 +210,7 @@ descrToHTML a = concat (List.intersperse " / " (map onedescrToHTML a))
oneprefixToHTML s = " Possible prefix: " ++ s ++ "
"
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
diff --git a/Registry/Utils/PostgreSQL.hs b/Registry/Utils/PostgreSQL.hs
index 235df6d..7783bea 100644
--- a/Registry/Utils/PostgreSQL.hs
+++ b/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))
diff --git a/Registry/Utils/SQLite.hs b/Registry/Utils/SQLite.hs
index 0033f36..8c070c2 100644
--- a/Registry/Utils/SQLite.hs
+++ b/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))