GaBuZoMeu/Registry/Utils.hs

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
maybeListToString Nothing = ""
maybeListToString (Just s) = (foldr (++) "" 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" ++ 
                     (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" ++ 
                     (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" ++ 
                     (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" ++ 
                     (maybeListToString (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>" ++ (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 = ""
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: " ++ (foldr (++) "" (map 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"