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 '<' = "<" fixChar '>' = ">" fixChar '&' = "&" 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 = "" ++ d ++ "" addedToXML d = "" ++ d ++ "" deprecatedToXML Nothing = "" deprecatedToXML (Just d) = "" ++ d ++ "" commentToXML Nothing = "" commentToXML (Just c) = "" ++ (escapexml c) ++ "" sscriptToXML Nothing = "" sscriptToXML (Just s) = "" ++ s ++ "" prefToXML Nothing = "" prefToXML (Just s) = "" ++ s ++ "" macrolToXML Nothing = "" macrolToXML (Just l) = "" ++ l ++ "" scopeToXML Nothing = "" scopeToXML (Just s) = "" ++ s ++ "" onedescrToXML s = "" ++ (escapexml s) ++ "" descrToXML a = concat (map onedescrToXML a) oneprefixToXML s = "" ++ s ++ "" prefixesToXML a = concat (map oneprefixToXML a) toXML (Date d) = dateToXML d toXML (Lang l) = "" ++ (lang'subtag l) ++ "" ++ 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) ++ "\n" toXML (Extl l) = "" ++ (extlang'subtag l) ++ "" ++ addedToXML (extlang'added l) ++ descrToXML (extlang'descr l) ++ (sscriptToXML (extlang'script l)) ++ macrolToXML (extlang'macroLanguage l) ++ scopeToXML (extlang'scope l) ++ "\n" toXML (GF t) = "" ++ (gf'tag t) ++ "" ++ addedToXML (gf'added t) ++ descrToXML (gf'descr t) ++ "\n" toXML (Scr s) = "\n" toXML (Reg r) = "" ++ (region'subtag r) ++ "" ++ deprecatedToXML (region'deprecated r) ++ commentToXML (region'comment r) ++ addedToXML (region'added r) ++ descrToXML (region'descr r) ++ "\n" toXML (Var v) = "" ++ (variant'subtag v) ++ "" ++ deprecatedToXML (variant'deprecated v) ++ commentToXML (variant'comment v) ++ addedToXML (variant'added v) ++ descrToXML (variant'descr v) ++ prefixesToXML (variant'prefix v) ++ "\n" toXML (Red r) = "" ++ (redundant'tag r) ++ "" ++ addedToXML (redundant'added r) ++ descrToXML (redundant'descr r) ++ "\n" toXML (Ext e) = error "No support for extensions" html_head s = "\n\n\n" ++ (escapexml s) ++ "

" ++ (escapexml s) ++ "

" html_tail = "

langtag.net Home

" linkLanguage langcode = if (length langcode) == 3 then "See the SIL entry (if present)." else if (length langcode) == 2 then "See the LOC entry (if present)." else "" dateToHTML d = "Date: " ++ d addedToHTML d = "Added on " ++ d sscriptToHTML Nothing = "" sscriptToHTML (Just s) = " Suppress the script: " ++ s ++ "" 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: " ++ s ++ "" prefixesToHTML a = concat (map oneprefixToHTML a) commentToHTML Nothing = "" commentToHTML (Just s) = " Comment: " ++ (escapexml s) deprecatedToHTML Nothing = "" deprecatedToHTML (Just s) = " Deprecated: " ++ s toHTML (Date d) = "

Date: " ++ dateToHTML d ++ "

" toHTML (Lang l) = (html_head ((lang'descr l) !! 0)) ++ "

Code " ++ (lang'subtag l) ++ ". " ++ 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) ++ "

" ++ html_tail ++ "\n" toHTML (GF t) = "

Code " ++ (gf'tag t) ++ ". " ++ addedToHTML (gf'added t) ++ ". " ++ descrToHTML (gf'descr t) ++ "

\n" toHTML (Scr s) = (html_head ((script'descr s) !! 0)) ++ "

Code " ++ (script'subtag s) ++ ". " ++ addedToHTML (script'added s) ++ ". Description: " ++ descrToHTML (script'descr s) ++ deprecatedToHTML (script'deprecated s) ++ commentToHTML (script'comment s) ++ "

" ++ html_tail ++ "\n" toHTML (Reg r) = (html_head ((region'descr r) !! 0)) ++ "

Code " ++ (region'subtag r) ++ ". " ++ addedToHTML (region'added r) ++ ". Description: " ++ descrToHTML (region'descr r) ++ deprecatedToHTML (region'deprecated r) ++ commentToHTML (region'comment r) ++ "

" ++ html_tail ++ "\n" toHTML (Var v) = (html_head ((variant'descr v) !! 0)) ++ "

Code " ++ (variant'subtag v) ++ ". " ++ addedToHTML (variant'added v) ++ ". Description: " ++ descrToHTML (variant'descr v) ++ ". " ++ prefixesToHTML (variant'prefix v) ++ deprecatedToHTML (variant'deprecated v) ++ commentToHTML (variant'comment v) ++ "

" ++ html_tail ++ "\n" toHTML (Red r) = (html_head ((redundant'descr r) !! 0)) ++ "

Code " ++ (redundant'tag r) ++ ". " ++ addedToHTML (redundant'added r) ++ ". " ++ descrToHTML (redundant'descr r) ++ "

" ++ html_tail ++ "\n"