GaBuZoMeu/display-tag.hs

import Grammar
import Types

import Registry.Registry (readRegistry, isValid)
import Registry.Types 
import Registry.Utils (onlyThisValue, onlyThisType, scriptFrom, languageFrom, 
   regionFrom, variantFrom)

import Data.List (intersperse)
import System.Environment (getArgs)

infile = "./language-subtag-registry"

langToString registry l = 
   "language \"" ++ concat (intersperse " / " 
                            (lang'descr (languageFrom (filter (onlyThisValue 
                                                                  "language" l) 
                                                (filter (onlyThisType "language") 
                                                        registry) !! 0)))) ++ "\""

scriptToString registry Nothing = ""
scriptToString registry (Just s) = 
     let theScript = (filter (onlyThisValue "script" s) 
                                                (filter (onlyThisType "script") 
                                                        registry)) !! 0 in
     ", " ++ s ++ ": script " ++ 
                " \"" ++ concat (intersperse " / " (script'descr 
                            (scriptFrom theScript))) ++ "\""

regionToString registry Nothing = ""
regionToString registry (Just r) = 
     let theRegion = (filter (onlyThisValue "region" r) 
                                                (filter (onlyThisType "region") 
                                                        registry)) !! 0 in
     ", " ++ r ++ ": region " ++ 
                " \"" ++ concat (intersperse " / " (region'descr 
                            (regionFrom theRegion))) ++ "\""

variantsToString registry [] = ""
variantsToString registry v = ", " ++ concat (intersperse ", " 
                              (map (variantToString registry) v))

variantToString registry v = 
     let theVariant = (filter (onlyThisValue "variant" v) 
                                                (filter (onlyThisType "variant") 
                                                        registry)) !! 0 in
     v ++ ": variant " ++ 
                " \"" ++ concat (intersperse " / " (variant'descr 
                            (variantFrom theVariant))) ++ "\""

toString :: Registry -> Tag -> String
toString registry (Tag l el s r v e) =
    -- Display extlangs. See issue #8
    -- Display extensions. See issue #7
    l ++ ": " ++ langToString registry l ++
           scriptToString registry s ++ regionToString registry r ++ 
           variantsToString registry v

toString registry (Types.GF tag) = tag
toString registry (Priv p) =
     (concat p) ++ " (private tag so no info available)"

analyze :: Registry -> String -> String
analyze reg input 
        = case (getTag input) of
            Left err -> err
            Right tag  -> let result = isValid reg tag in
                          if fst result then
                              input ++ ": (" ++ (toString reg tag) ++ ")"
                          else
                              (input ++ " is NOT valid: " ++ snd result ++ "\n")

main = do
  myargs <- getArgs
  theregistry <- readRegistry infile
  putStrLn (concat (intersperse "\n" (map (analyze theregistry) myargs)))