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

Compare commits

base: bortzmeyer:master
Branches Tags
bortzmeyer:master
nnmrts:master
..
compare: nnmrts:master
Branches Tags
nnmrts:master
bortzmeyer:master

No commits in common. "master" and "master" have entirely different histories.
master ... master

5 changed files with 22 additions and 40 deletions
Show Stats Expand all files Collapse all files

20
Registry/Grammar.hs
View File

@ -41,18 +41,6 @@ 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
@ -79,7 +67,7 @@ recordFactory r =
(lookup "Macrolanguage" r) (lookup "Macrolanguage" r)
(lookup "Deprecated" r) (lookup "Deprecated" r)
(lookup "Scope" r) (lookup "Scope" r)
(lookupsmaybe "Comments" r) (lookups "Comments" r)
)) ))
"extlang" -> Right (Extl (Extlang "extlang" -> Right (Extl (Extlang
(fromJust (lookup "Subtag" r)) (fromJust (lookup "Subtag" r))
@ -96,20 +84,20 @@ recordFactory r =
(lookups "Description" r) (lookups "Description" r)
(fromJust (lookup "Added" r)) (fromJust (lookup "Added" r))
(lookup "Deprecated" r) (lookup "Deprecated" r)
(lookupsmaybe "Comments" r))) (lookups "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)
(lookupsmaybe "Comments" r))) (lookups "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)
(lookupsmaybe "Comments" r))) (lookups "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,8 +100,6 @@ 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)
@ -109,21 +107,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" ++
(maybeListToString (lang'comment l)) ++ "\n" (maybeToString (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" ++
(maybeListToString (script'comment s)) ++ "\n" (maybeToString (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" ++
(maybeListToString (region'comment r)) ++ "\n" (maybeToString (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" ++
(maybeListToString (variant'comment v)) ++ "\n" (maybeToString (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"
@ -132,7 +130,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>" ++ (foldr (++) "" (map escapexml c)) ++ "</comments>" -- TODO Add whitespace if there are several comments before concatenation. commentToXML (Just c) = "<comments>" ++ (escapexml c) ++ "</comments>"
sscriptToXML Nothing = "" sscriptToXML Nothing = ""
sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>" sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>"
prefToXML Nothing = "" prefToXML Nothing = ""
@ -210,7 +208,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: " ++ (foldr (++) "" (map escapexml s)) commentToHTML (Just s) = " Comment: " ++ (escapexml s)
deprecatedToHTML Nothing = "" deprecatedToHTML Nothing = ""
deprecatedToHTML (Just s) = " Deprecated: " ++ s deprecatedToHTML (Just s) = " Deprecated: " ++ s

10
Registry/Utils/PostgreSQL.hs
View File

@ -11,8 +11,6 @@ escape = concatMap fixChar
maybeToPostgreSQL Nothing = "NULL" maybeToPostgreSQL Nothing = "NULL"
maybeToPostgreSQL (Just s) = "'" ++ (escape s) ++ "'" maybeToPostgreSQL (Just s) = "'" ++ (escape s) ++ "'"
maybeListToPostgreSQL Nothing = "NULL"
maybeListToPostgreSQL (Just s) = "'" ++ (foldr (++) "" (map escape 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" ++
@ -39,7 +37,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)) ++ ", " ++
(maybeListToPostgreSQL (lang'comment l)) ++ ", " ++ (maybeToPostgreSQL (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))
@ -47,7 +45,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)) ++ ", " ++
(maybeListToPostgreSQL (script'comment s)) ++ ", " ++ (maybeToPostgreSQL (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))
@ -55,7 +53,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)) ++ ", " ++
(maybeListToPostgreSQL (region'comment r)) ++ ", " ++ (maybeToPostgreSQL (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))
@ -63,7 +61,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)) ++ ", " ++
(maybeListToPostgreSQL (variant'comment v)) ++ ", " ++ (maybeToPostgreSQL (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,8 +11,6 @@ escape = concatMap fixChar
maybeToSQLite Nothing = "NULL" maybeToSQLite Nothing = "NULL"
maybeToSQLite (Just s) = "'" ++ (escape s) ++ "'" maybeToSQLite (Just s) = "'" ++ (escape s) ++ "'"
maybeListToSQLite Nothing = "NULL"
maybeListToSQLite (Just s) = "'" ++ (foldr (++) "" (map escape 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)"
@ -41,7 +39,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)) ++ ", " ++
(maybeListToSQLite (lang'comment l)) ++ ", " ++ (maybeToSQLite (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))
@ -49,7 +47,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)) ++ ", " ++
(maybeListToSQLite (script'comment s)) ++ ", " ++ (maybeToSQLite (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))
@ -57,7 +55,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)) ++ ", " ++
(maybeListToSQLite (region'comment r)) ++ ", " ++ (maybeToSQLite (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))
@ -65,7 +63,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)) ++ ", " ++
(maybeListToSQLite (variant'comment v)) ++ ", " ++ (maybeToSQLite (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))