224 lines
10 KiB
Haskell
224 lines
10 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"
|
|
|
|
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
|
|
-- TODO: extensions
|
|
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)) ++ "\n"
|
|
toString (GF t) = (gf'tag t) ++ "\n"
|
|
toString (Scr s) = (script'subtag s) ++ "\t" ++ dateToString (script'added s) ++ "\t" ++
|
|
descrToString (script'descr s) ++ "\n"
|
|
toString (Reg r) = (region'subtag r) ++ "\t" ++ dateToString (region'added r) ++ "\t" ++
|
|
descrToString (region'descr r) ++ "\n"
|
|
toString (Var v) = (variant'subtag v) ++ "\t" ++ dateToString (variant'added v) ++ "\t" ++
|
|
descrToString (variant'descr v) ++ "\t" ++
|
|
prefixesToString (variant'prefix v) ++ "\n"
|
|
toString (Red r) = (redundant'tag r) ++ "\t" ++ dateToString (redundant'added r) ++ "\t" ++
|
|
descrToString (redundant'descr r) ++ "\n"
|
|
|
|
-- TODO: escape non-XML chars
|
|
dateToXML d = "<date>" ++ d ++ "</date>"
|
|
addedToXML d = "<added>" ++ d ++ "</added>"
|
|
deprecatedToXML Nothing = ""
|
|
deprecatedToXML (Just d) = "<deprecated>" ++ d ++ "</deprecated>"
|
|
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>" ++ 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) ++
|
|
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>" ++
|
|
addedToXML (script'added s) ++
|
|
descrToXML (script'descr s) ++ "</script>\n"
|
|
toXML (Reg r) = "<region><subtag>" ++ (region'subtag r) ++ "</subtag>" ++
|
|
addedToXML (region'added r) ++
|
|
descrToXML (region'descr r) ++ "</region>\n"
|
|
toXML (Var v) = "<variant><subtag>" ++ (variant'subtag v) ++ "</subtag>" ++
|
|
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"
|
|
|
|
-- TODO: escape non-HTML chars
|
|
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>" ++ s ++ "</title></head><body><h1>" ++
|
|
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 = s
|
|
descrToHTML a = concat (List.intersperse " / " (map onedescrToHTML a))
|
|
-- TODO: a prefix is not always a simple language, it can be composed of several subtags
|
|
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: " ++ 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)) ++
|
|
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) ++
|
|
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) ++
|
|
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) ++
|
|
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"
|