bortzmeyer/GaBuZoMeu
1
0
Fork 1
Code Issues 7 Pull Requests Projects Releases Wiki Activity

Handle the case with several comments. Closes #11.

Browse Source
This commit is contained in:
Stephane Bortzmeyer 2024-06-18 16:30:58 +02:00
parent cb8ef11d1f
commit ba65b8ac6a
5 changed files with 40 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Registry/Grammar.hs
View File

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

8
Registry/Types.hs
View File

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

14
Registry/Utils.hs
View File

@ -100,6 +100,8 @@ toSubtag (Red r) = (redundant'tag r)
maybeToString Nothing = "" maybeToString Nothing = ""
maybeToString (Just s) = s maybeToString (Just s) = s
maybeListToString Nothing = ""
maybeListToString (Just s) = (foldr (++) "" s)
dateToString d = d dateToString d = d
descrToString a = concat (List.intersperse " / " a) descrToString a = concat (List.intersperse " / " a)
prefixesToString 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" ++ descrToString (lang'descr l) ++ "\t" ++
(maybeToString (lang'script l)) ++ "\t" ++ (maybeToString (lang'script l)) ++ "\t" ++
(maybeToString (lang'deprecated 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 (GF t) = (gf'tag t) ++ "\n"
toString (Scr s) = (script'subtag s) ++ "\t" ++ dateToString (script'added s) ++ "\t" ++ toString (Scr s) = (script'subtag s) ++ "\t" ++ dateToString (script'added s) ++ "\t" ++
descrToString (script'descr s) ++ "\t" ++ descrToString (script'descr s) ++ "\t" ++
(maybeToString (script'deprecated 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" ++ toString (Reg r) = (region'subtag r) ++ "\t" ++ dateToString (region'added r) ++ "\t" ++
descrToString (region'descr r) ++ "\t" ++ descrToString (region'descr r) ++ "\t" ++
(maybeToString (region'deprecated 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" ++ toString (Var v) = (variant'subtag v) ++ "\t" ++ dateToString (variant'added v) ++ "\t" ++
descrToString (variant'descr v) ++ "\t" ++ descrToString (variant'descr v) ++ "\t" ++
prefixesToString (variant'prefix v) ++ "\t" ++ prefixesToString (variant'prefix v) ++ "\t" ++
(maybeToString (variant'deprecated 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" ++ toString (Red r) = (redundant'tag r) ++ "\t" ++ dateToString (redundant'added r) ++ "\t" ++
descrToString (redundant'descr r) ++ "\n" descrToString (redundant'descr r) ++ "\n"
@ -130,7 +132,7 @@ addedToXML d = "<added>" ++ d ++ "</added>"
deprecatedToXML Nothing = "" deprecatedToXML Nothing = ""
deprecatedToXML (Just d) = "<deprecated>" ++ d ++ "</deprecated>" deprecatedToXML (Just d) = "<deprecated>" ++ d ++ "</deprecated>"
commentToXML Nothing = "" 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 Nothing = ""
sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>" sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>"
prefToXML Nothing = "" 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>" oneprefixToHTML s = " Possible prefix: <code><a href=\"../language/" ++ s ++ ".html\">" ++ s ++ "</a></code>"
prefixesToHTML a = concat (map oneprefixToHTML a) prefixesToHTML a = concat (map oneprefixToHTML a)
commentToHTML Nothing = "" commentToHTML Nothing = ""
commentToHTML (Just s) = " Comment: " ++ (escapexml s) commentToHTML (Just s) = " Comment: " ++ (foldr (++) "" (map escapexml s))
deprecatedToHTML Nothing = "" deprecatedToHTML Nothing = ""
deprecatedToHTML (Just s) = " Deprecated: " ++ s deprecatedToHTML (Just s) = " Deprecated: " ++ s

10
Registry/Utils/PostgreSQL.hs
View File

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

10
Registry/Utils/SQLite.hs
View File

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