-- ------------------------------------------------------------

{- |
   Module     : GenCharProps
   Copyright  : Copyright (C) 2010 - Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Generator for Unicode Character Properties

-}

-- ------------------------------------------------------------

module Main
where

import qualified Data.List as L
import qualified Data.Map  as M

main :: IO()
main
    = do
      c <- readFile "UnicodeData.txt"
      putStr $ genCharProps c

genCharProps    :: String -> String
genCharProps
    = unlines
      . processCharProps
      . concatMap parseCharDescr
      . lines
    where
    parseCharDescr      :: String -> [(String, Char)]
    parseCharDescr l
        | length cols < 3
            = []
        | otherwise
            =  [(nn,c),(n,c)]
        where
        cols = columns (== ';') l
        c    :: Char
        c    = read ("'\\x" ++ head  cols ++ "'")
        nn   = cols !! 2
        n    = take 1 nn
    processCharProps l
        = ( header1
            ++
            [ genExp . map fst $ l1 ]
            ++
            header2
            ++
            map (uncurry genPred) l1
          )
        where
        l1 = mkRng . M.toAscList . mkCharMap $ l

header1, header2 :: [String]
header1
    =  [ cmt
       , ""
       , "{- |"
       , "   Module     : Data.Char.Properties.UnicodeCharProps"
       , "   Copyright  : Copyright (C) 2010 - Uwe Schmidt"
       , ""
       , "   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)"
       , "   Stability  : stable"
       , "   Portability: portable"
       , ""
       , "   Unicode character properties"
       , ""
       , "   don't edit this module"
       , "   it's generated from 'http:\\/\\/www.unicode.org\\/Public\\/UNIDATA\\/UnicodeData.txt'"
       , ""
       , "-}"
       , ""
       , cmt
       , ""
       , "module Data.Char.Properties.UnicodeCharProps"
       ]

header2
    = [ "where"
      , ""
      , "import Data.Set.CharSet"
      , ""
      , cmt
      , ""
      ]

cmt :: String
cmt = "-- " ++ replicate 60 '-'

columns :: (Char -> Bool) -> String -> [String]
columns _ [] = []
columns p xs
    = c : columns p (drop 1 r)
    where
    (c, r) = break p xs

type CharMap    = M.Map String [Char]

mkCharMap       :: [(String, Char)] -> CharMap
mkCharMap
    = foldl ins M.empty
    where
    ins :: CharMap -> (String, Char) -> CharMap
    ins m (k, v)
        = M.insertWith (++) k [v] m

mkRng   :: [(String,[Char])] -> [(String,[(Char, Char)])]
mkRng l
    = zip (map fst l) (map (charRngs . L.sort . snd) l)

charRngs        :: [Char] -> [(Char, Char)]
charRngs []     = []
charRngs (x:xs) = charRng x xs
                  where
                  charRng y []          = (x,y) : []
                  charRng y xs'@(x1:xs1)
                      | x1 == succ y    = charRng x1 xs1
                      | otherwise       = (x,y) : charRngs xs'

genPred :: String -> [(Char, Char)] -> String
genPred n rngs
    = unlines $
      [ "isUnicode" ++ n ++ " :: Char -> Bool"
      , "isUnicode" ++ n ++ " c"
      , "  = elemCS c charPropUnicode" ++ n
      , ""
      , "charPropUnicode" ++ n ++ " :: CharSet"
      , "charPropUnicode" ++ n
      , "  = [ " ++ (joinStr "\n    , " . map show) rngs
      , "    ]"
      , ""
      , cmt
      ]

joinStr    :: String -> [String] -> String
joinStr js
    = foldr1 (\ x y -> x ++ js ++ y)

genExp  :: [String] -> String
genExp ns
    = "  ( " ++ joinStr "\n  , " (map ("isUnicode" ++) ns ++ map ("charPropUnicode" ++) ns) ++ "\n  )"