From ba65b8ac6aead9ec3723671de4443b7545381a8d Mon Sep 17 00:00:00 2001 From: Stephane Bortzmeyer Date: Tue, 18 Jun 2024 16:30:58 +0200 Subject: [PATCH] Handle the case with several comments. Closes #11. --- Registry/Grammar.hs | 20 ++++++++++++++++---- Registry/Types.hs | 8 ++++---- Registry/Utils.hs | 14 ++++++++------ Registry/Utils/PostgreSQL.hs | 10 ++++++---- Registry/Utils/SQLite.hs | 10 ++++++---- 5 files changed, 40 insertions(+), 22 deletions(-) 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))