import Text.XML.Light
import Control.Applicative
import Data.Maybe
import Debug.Trace
import Numeric
import Text.TeXMath.Types
import Data.List (intersperse)
import Data.Char
import qualified Data.Map as M

updates :: [M.Map (String, FormType) Operator -> M.Map (String, FormType) Operator]
updates = 
  [ M.insert ("\65079", FInfix) c65079
  , M.insert ("\65080", FInfix) c65080
  ]

c65079 =  Operator {oper = "\65079", description = "PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET" , form = FInfix, priority = 880, lspace = 0, rspace = 0, properties = ["stretchy", "accent"]}
c65080 = Operator {oper = "\65080", description = "PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET", form = FInfix, priority = 880, lspace = 0, rspace = 0, properties = ["stretchy", "accent"]}

applyChanges = foldr (.) id updates

mkMap :: [Operator] -> M.Map (String, FormType) Operator
mkMap operators = M.fromList (map (\o -> ((oper o, form o), o)) operators)

findAttrQ s = findAttr (QName s Nothing Nothing)

toChar :: Element -> Maybe String
toChar s = toHex <$> findAttrQ "unicode"  s

toHex :: String -> String
toHex s = foldr (:) [] ss 
  where
    s' = drop 1 s
    ss = map (chr . fst . head . readHex) (splitMany s' '-')

splitMany :: String -> Char -> [String]
splitMany [] _  = []
splitMany s sep =  case bs of
  [] -> [fs]
  _ -> fs : (splitMany (tail bs) sep)
  where
    (fs, bs) = span (/= sep) s


f :: Element -> Maybe Operator
f e = Operator <$> c <*> d <*> f <*> p <*> ls <*> rs <*> ps
  where
    c = toChar e
    d = findAttrQ "description" e 
    f = mapForm <$> findAttrQ "form" e
    p = read <$> findAttrQ "priority" e
    ls = read <$> findAttrQ "lspace" e
    rs = read <$> findAttrQ "rspace" e
    ps = return $ fromMaybe [] (words <$> findAttrQ "properties" e)

mapForm "prefix" = FPrefix
mapForm "postfix" = FPostfix
mapForm "infix" = FInfix
mapForm _ = FInfix

main :: IO ()
main = do 
  Just dict <- parseXMLDoc <$> readFile "dictionary.xml"
  let b =  map snd . M.toList . applyChanges . mkMap <$> mapM f (elChildren dict)
  writeFile "mmldict.hs" (
    "operators :: [Operator]\n" ++
    "operators =\n" ++
    "  [ " ++ concat (intersperse "\n  , " (map show $ fromJust b)) ++
    "]")