GaBuZoMeu/Registry/Utils.hs
2023-10-01 12:32:03 +02:00

253 lines
12 KiB
Haskell

module Registry.Utils where
import Registry.Grammar
import Registry.Types
import qualified Data.List as List
import Data.Char (toUpper)
toUpperS :: String -> String
toUpperS = map toUpper
onlyDate (Date d) = True
onlyDate _ = False
onlyRecord (Date d) = False
onlyRecord _ = True
onlyGF (GF r) = True
onlyGF _ = False
onlyLang (Lang r) = True
onlyLang _ = False
onlyExtlang (Extl r) = True
onlyExtlang _ = False
onlyScript (Scr r) = True
onlyScript _ = False
onlyRegion (Reg r) = True
onlyRegion _ = False
onlyVariant (Var r) = True
onlyVariant _ = False
onlyRedundant (Red r) = True
onlyRedundant _ = False
onlyExtension (Red r) = True
onlyExtension _ = False
languageFrom (Lang r) = r
languageFrom x = error "Not a language"
extlangFrom (Extl r) = r
extlangFrom x = error "Not an extlang (extended language)"
scriptFrom (Scr r) = r
scriptFrom _ = error "Not a script"
regionFrom (Reg r) = r
regionFrom _ = error "Not a region"
variantFrom (Var v) = v
variantFrom _ = error "Not a variant"
redundantFrom (Red r) = r
redundantFrom _ = error "Not a redundant"
gfFrom (GF r) = r
gfFrom _ = error "Not a grandfathered"
escapexml :: String -> String
escapexml = concatMap fixChar
where
fixChar '<' = "&lt;"
fixChar '>' = "&gt;"
fixChar '&' = "&amp;"
fixChar c = [c]
onlyThisType :: String -> Record -> Bool
onlyThisType "language" = onlyLang
onlyThisType "extlang" = onlyExtlang
onlyThisType "grandfathered" = onlyGF
onlyThisType "script" = onlyScript
onlyThisType "region" = onlyRegion
onlyThisType "variant" = onlyVariant
onlyThisType "redundant" = onlyRedundant
onlyThisType "extension" = onlyExtension
onlyThisType t = error ("Unknown type in the registry: " ++ t)
onlyThisValue :: String -> String -> Record -> Bool
-- Remember that language tags are case-insensitive
onlyThisValue "language" v = (\r -> toUpperS (lang'subtag r) == toUpperS (v)).languageFrom
onlyThisValue "extlang" v = (\r -> toUpperS (extlang'subtag r) == toUpperS (v)).extlangFrom
onlyThisValue "grandfathered" v = (\r -> toUpperS (gf'tag r) == toUpperS (v)).gfFrom
onlyThisValue "script" v = (\r -> toUpperS (script'subtag r) == toUpperS (v)).scriptFrom
onlyThisValue "region" v = (\r -> toUpperS (region'subtag r) == toUpperS (v)).regionFrom
onlyThisValue "variant" v = (\r -> toUpperS (variant'subtag r) == toUpperS (v)).variantFrom
onlyThisValue "redundant" v = (\r -> toUpperS (redundant'tag r) == toUpperS (v)).redundantFrom
-- Extensions not managed? See issue #7.
onlyThisValue t _ = error ("Unknown type of this value in the registry: " ++ t)
toSubtag (Lang l) = (lang'subtag l)
toSubtag (Scr s) = (script'subtag s)
toSubtag (GF t) = (gf'tag t)
toSubtag (Reg r) = (region'subtag r)
toSubtag (Var v) = (variant'subtag v)
toSubtag (Red r) = (redundant'tag r)
maybeToString Nothing = ""
maybeToString (Just s) = s
dateToString d = d
descrToString a = concat (List.intersperse " / " a)
prefixesToString a = concat (List.intersperse " / " a)
toString (Lang l) = (lang'subtag l) ++ "\t" ++ dateToString (lang'added l) ++ "\t" ++
descrToString (lang'descr l) ++ "\t" ++
(maybeToString (lang'script l)) ++ "\t" ++
(maybeToString (lang'deprecated l)) ++ "\t" ++
(maybeToString (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"
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"
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"
toString (Red r) = (redundant'tag r) ++ "\t" ++ dateToString (redundant'added r) ++ "\t" ++
descrToString (redundant'descr r) ++ "\n"
dateToXML d = "<date>" ++ d ++ "</date>"
addedToXML d = "<added>" ++ d ++ "</added>"
deprecatedToXML Nothing = ""
deprecatedToXML (Just d) = "<deprecated>" ++ d ++ "</deprecated>"
commentToXML Nothing = ""
commentToXML (Just c) = "<comments>" ++ (escapexml c) ++ "</comments>"
sscriptToXML Nothing = ""
sscriptToXML (Just s) = "<suppress-script>" ++ s ++ "</suppress-script>"
prefToXML Nothing = ""
prefToXML (Just s) = "<preferred-value>" ++ s ++ "</preferred-value>"
macrolToXML Nothing = ""
macrolToXML (Just l) = "<macrolanguage>" ++ l ++ "</macrolanguage>"
scopeToXML Nothing = ""
scopeToXML (Just s) = "<scope>" ++ s ++ "</scope>"
onedescrToXML s = "<description>" ++ (escapexml s) ++ "</description>"
descrToXML a = concat (map onedescrToXML a)
oneprefixToXML s = "<prefix>" ++ s ++ "</prefix>"
prefixesToXML a = concat (map oneprefixToXML a)
toXML (Date d) = dateToXML d
toXML (Lang l) = "<language><subtag>" ++ (lang'subtag l) ++ "</subtag>" ++
addedToXML (lang'added l) ++
descrToXML (lang'descr l) ++
(sscriptToXML (lang'script l)) ++
deprecatedToXML (lang'deprecated l) ++
commentToXML (lang'comment l) ++
prefToXML (lang'preferredValue l) ++
macrolToXML (lang'macroLanguage l) ++
scopeToXML (lang'scope l) ++
"</language>\n"
toXML (Extl l) = "<extlang><subtag>" ++ (extlang'subtag l) ++ "</subtag>" ++
addedToXML (extlang'added l) ++
descrToXML (extlang'descr l) ++
(sscriptToXML (extlang'script l)) ++
macrolToXML (extlang'macroLanguage l) ++
scopeToXML (extlang'scope l) ++
"</extlang>\n"
toXML (GF t) = "<grandfathered><tag>" ++ (gf'tag t) ++ "</tag>" ++
addedToXML (gf'added t) ++
descrToXML (gf'descr t) ++ "</grandfathered>\n"
toXML (Scr s) = "<script><subtag>" ++ (script'subtag s) ++ "</subtag>" ++
deprecatedToXML (script'deprecated s) ++
commentToXML (script'comment s) ++
addedToXML (script'added s) ++
descrToXML (script'descr s) ++ "</script>\n"
toXML (Reg r) = "<region><subtag>" ++ (region'subtag r) ++ "</subtag>" ++
deprecatedToXML (region'deprecated r) ++
commentToXML (region'comment r) ++
addedToXML (region'added r) ++
descrToXML (region'descr r) ++ "</region>\n"
toXML (Var v) = "<variant><subtag>" ++ (variant'subtag v) ++ "</subtag>" ++
deprecatedToXML (variant'deprecated v) ++
commentToXML (variant'comment v) ++
addedToXML (variant'added v) ++
descrToXML (variant'descr v) ++
prefixesToXML (variant'prefix v) ++ "</variant>\n"
toXML (Red r) = "<redundant><tag>" ++ (redundant'tag r) ++ "</tag>" ++
addedToXML (redundant'added r) ++
descrToXML (redundant'descr r) ++ "</redundant>\n"
toXML (Ext e) = error "No support for extensions"
html_head s = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">\n<head><link rel=\"stylesheet\" type=\"text/css\" href=\"/ltru.css\" /><title>" ++ (escapexml s) ++ "</title></head><body><h1>" ++
(escapexml s) ++ "</h1>"
html_tail = "<hr/><p><a href=\"/\">langtag.net Home</a></p></body></html>"
linkLanguage langcode =
if (length langcode) == 3 then
"<a href=\"https://iso639-3.sil.org/code/" ++
langcode ++ "\">See the SIL entry</a> (if present)."
else if (length langcode) == 2 then
"<a href=\"http://www.loc.gov/standards/iso639-2/php/langcodes_name.php?iso_639_1=" ++
langcode ++ "\">See the LOC entry</a> (if present)."
else
""
dateToHTML d = "Date: " ++ d
addedToHTML d = "Added on " ++ d
sscriptToHTML Nothing = ""
sscriptToHTML (Just s) = " Suppress the script: <code><a href=\"../script/" ++ s ++
".html\">" ++ s ++ "</a></code>"
onedescrToHTML s = (escapexml s)
descrToHTML a = concat (List.intersperse " / " (map onedescrToHTML a))
-- But a prefix is not always a simple language, it can be composed of several subtags. See issue #3
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)
deprecatedToHTML Nothing = ""
deprecatedToHTML (Just s) = " Deprecated: " ++ s
toHTML (Date d) = "<p>Date: " ++ dateToHTML d ++ "</p>"
toHTML (Lang l) = (html_head ((lang'descr l) !! 0)) ++ "<p>Code <code>" ++
(lang'subtag l) ++ "</code>. " ++
addedToHTML (lang'added l) ++ ". Description: " ++
descrToHTML (lang'descr l) ++ ". " ++
linkLanguage (lang'subtag l) ++
(sscriptToHTML (lang'script l)) ++
deprecatedToHTML (lang'deprecated l) ++
commentToHTML (lang'comment l) ++ "</p>" ++ html_tail ++ "\n"
toHTML (GF t) = "<p>Code <code>" ++ (gf'tag t) ++ "</code>. " ++
addedToHTML (gf'added t) ++ ". " ++
descrToHTML (gf'descr t) ++ "</p>\n"
toHTML (Scr s) = (html_head ((script'descr s) !! 0)) ++ "<p>Code <code>" ++
(script'subtag s) ++ "</code>. " ++
addedToHTML (script'added s) ++ ". Description: " ++
descrToHTML (script'descr s) ++
deprecatedToHTML (script'deprecated s) ++
commentToHTML (script'comment s) ++ "</p>" ++ html_tail ++ "\n"
toHTML (Reg r) = (html_head ((region'descr r) !! 0)) ++ "<p>Code <code>" ++
(region'subtag r) ++ "</code>. " ++
addedToHTML (region'added r) ++
". Description: " ++
descrToHTML (region'descr r) ++
deprecatedToHTML (region'deprecated r) ++
commentToHTML (region'comment r) ++ "</p>" ++
html_tail ++ "\n"
toHTML (Var v) = (html_head ((variant'descr v) !! 0)) ++ "<p>Code <code>" ++
(variant'subtag v) ++ "</code>. " ++
addedToHTML (variant'added v) ++ ". Description: " ++
descrToHTML (variant'descr v) ++ ". " ++
prefixesToHTML (variant'prefix v) ++
deprecatedToHTML (variant'deprecated v) ++
commentToHTML (variant'comment v) ++ "</p>" ++ html_tail ++ "\n"
toHTML (Red r) = (html_head ((redundant'descr r) !! 0)) ++
"<p>Code <code>" ++ (redundant'tag r) ++ "</code>. " ++
addedToHTML (redundant'added r) ++ ". " ++
descrToHTML (redundant'descr r) ++ "</p>" ++
html_tail ++ "\n"