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
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)

8
Registry/Types.hs
View File

@ -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

14
Registry/Utils.hs
View File

@ -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

10
Registry/Utils/PostgreSQL.hs
View File

@ -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))

10
Registry/Utils/SQLite.hs
View File

@ -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))