iso639-0.1.0.1: generator/Generate.hs

module Generate where

-- needs: haskell-src, curl >= 1.3.8
import Language.Haskell.Syntax
import Language.Haskell.Pretty
import Data.Char (toUpper)

import Network.HTTP
import Data.Text (Text, pack, unpack, breakOn, splitOn)
import qualified Data.Text as T
import Data.Maybe
import Data.List

gen triples = prettyPrint $ 
    -- HsModule SrcLoc Module (Maybe [HsExportSpec]) [HsImportDecl] [HsDecl]
    HsModule (SrcLoc n 0 0) (Module n) Nothing 
        [HsImportDecl loc (Module "Prelude") False Nothing 
            (Just (True, [HsIThingAll (HsSymbol "Ordering") ]))
        ] 
        [iso639_1, iso639_1_show, iso639_1_read, iso639_1_name]
    where
        n = "Data.LanguageCodes"
        loc = SrcLoc n 0 0 
        iso639_1 = HsDataDecl loc [] (HsIdent "ISO639_1") [] 
                    (codes languages_1) (map (UnQual . HsIdent) ["Show", "Read", "Eq", "Enum", "Ord"])
        code (_,c) = HsConDecl loc (HsIdent (map toUpper c)) []
        codes lst = map code lst
        languages_1 = catMaybes $ map (\(l,_,c) -> fmap (\a -> (unpack l, unpack a)) c) triples
        iso639_1_read = HsFunBind 
            [ HsMatch loc (HsIdent "fromChars") 
                [HsPVar (HsSymbol "c1"), HsPVar (HsSymbol "c2")] 
                ( HsUnGuardedRhs 
                    (HsCase ( HsTuple [ HsVar $ UnQual $ HsSymbol "c1"
                                      , HsVar $ UnQual $ HsSymbol "c2"
                                      ]
                            ) ( map languageCodeAlt languages_1)
                                 )
                )
                []
            ]
        languageCodeAlt (_,c) = 
            HsAlt loc (HsPTuple [ HsPLit $ HsChar $ c !! 0
                                , HsPLit $ HsChar $ c !! 1
                                ]) 
                      (HsUnGuardedAlt $ HsCon $ UnQual $ HsSymbol $ map toUpper c)
                      []
        iso639_1_show = HsFunBind 
            [ HsMatch loc (HsIdent "toChars") 
                [HsPVar (HsSymbol "code")] 
                ( HsUnGuardedRhs (HsCase ( HsVar $ UnQual $ HsSymbol "code" )
                                       ( map languageAlt languages_1)
                                 )
                )
                []
            ]
        languageAlt (_,c) = 
                    HsAlt loc (HsPApp (UnQual $ HsSymbol $ map toUpper c) [])
                             (HsUnGuardedAlt $ 
                                HsTuple [ HsLit (HsChar $ c !! 0)
                                        , HsLit (HsChar $ c !! 1)
                                        ]) 
                             []
        iso639_1_name = HsFunBind 
            [ HsMatch loc (HsIdent "language") 
                [HsPVar (HsSymbol "code")] 
                ( HsUnGuardedRhs (HsCase ( HsVar $ UnQual $ HsSymbol "code" )
                                         ( map languageNameAlt languages_1 )
                                 )
                )
                []
            ]
        languageNameAlt (n,c) = 
                HsAlt loc (HsPApp (UnQual $ HsSymbol $ map toUpper c) [])
                                 (HsUnGuardedAlt $ HsLit $ HsString n) 
                                 []

-- fetch table from official site
fetchTable = do
    str <- simpleHTTP (getRequest url) >>= getResponseBody
    let site = pack str
    return site
    where
        url = "http://www.loc.gov/standards/iso639-2/php/English_list.php"

-- dirty table parsing
parseTable html = map (rowToTriple . T.lines) $ rows html 
    where 
        rows h = filter isValid $ map fixLine (tail $ T.splitOn (pack "</tr>") h)
        tagTxt = T.tail . T.takeWhile (/= '<') . T.dropWhile (/= '>')
        isValid t = T.take 3 t == T.pack "<tr"
        fixLine = T.replace (T.pack "><") (T.pack ">\n<") 
                . T.dropWhile (/= '<')
        rowToTriple l = (tagTxt (l !! 1), tagTxt (l !! 4)
                        , if tagTxt (l !! 5) == pack "&nbsp;" 
                            then Nothing
                            else Just (tagTxt (l !! 5))
                        )
        
doIt = do
    t <- fetchTable
    let uniqueLang f = nubBy (\(_,_,c1) (_,_,c2) -> c1 == c2) f
        sortedUnique = sortBy (\(_,_,c1) (_,_,c2) -> compare c1 c2) . uniqueLang
    writeFile "../Data/LanguageCodes.hs" $ gen (sortedUnique $ parseTable t)