git.iko.soy/typeable/country-codes
on master help sign in
typeable/country-codes/exe/Main.hs
144 lines 7.2 kB history raw
1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2-- | generate the ISO31661.hs file from the wikipedia html file
3module Main where
5import Text.HTML.TagSoup
7import Data.Function (on)
8import Data.List (foldl',sortBy)
9import Data.Maybe (mapMaybe)
10import Data.Monoid ((<>))
12import qualified Data.Text as T
13import qualified Data.Text.IO as T
14import Data.Tuple (swap)
16-- | entry point
17main :: IO()
18main = do
19 -- read from a local version
20 txt <- T.readFile "data/ISO 3166-1 alpha-2 - Wikipedia, the free encyclopedia.html"
21 -- extract data
22 let assocs = extract txt
23 -- generate Haskell code
24 let haskell=generate assocs
25 -- write file
26 T.writeFile "src/Data/CountryCodes/ISO31661.hs" haskell
27 return ()
29-- | extract tuples (code,name) from wikipedia file
30extract :: T.Text -> [(T.Text,T.Text)]
31extract txt =
32 let tts=parseTags txt
33 ps1=partitions (~== TagOpen ("span"::T.Text) [("id","Officially_assigned_code_elements")]) tts
34 in case ps1 of
35 [] -> error "No span with id 'Officially_assigned_code_elements' found"
36 (p1 : _) ->
37 let ps2=partitions (~== TagOpen ("table"::T.Text) [("class","wikitable sortable")]) p1
38 in case ps2 of
39 [] -> error "No wikitable found"
40 (p2 : _) ->
41 let rows= partitions (~== TagOpen ("tr" :: T.Text) []) p2
42 in mapMaybe (\r ->
43 let tds=partitions (~== TagOpen ("td"::T.Text) []) r
44 in if null tds || null (head tds)
45 then Nothing
46 else
47 let cid = fromAttrib "id" $ head $ head tds
48 name = fromAttrib "title" $ head $ head $ partitions (~== TagOpen ("a" :: T.Text) []) r
49 in Just (cid,name)
50 ) rows
52-- | generate haskell code
53generate :: [(T.Text,T.Text)] -> T.Text
54generate assocs =
55 let
56 header = "{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, NoImplicitPrelude, PatternGuards, FlexibleInstances, MultiParamTypeClasses #-}" <> nl <>
57 "-- | This file is generated from the Wikipedia page" <> nl <>
58 "-- <http://en.wikipedia.org/wiki/ISO_3166-1_alpha-2>" <> nl <>
59 "module Data.CountryCodes.ISO31661 (" <> nl <>
60 " CountryCode(..)" <> nl <>
61 " , countryList" <> nl <>
62 " , fromMText" <> nl <>
63 " , fromText" <> nl <>
64 " , fromMName" <> nl <>
65 " , fromName" <> nl <>
66 " , toText" <> nl <>
67 " , toName" <> nl <>
68 ") where" <> nl <>
69 nl <>
70 "import Control.Applicative (pure)" <> nl <>
71 "import Data.Aeson" <> nl <>
72 "import Data.Typeable" <> nl <>
73 "import qualified Data.Text as T" <> nl <>
74 "import Prelude (Show,Read,Eq,Ord,Bounded,Enum,error,($),(++),Maybe(..),(.),fail)" <> nl <>
75 "import Text.Shakespeare.I18N" <> nl <>
76 nl
77 cons = snd (foldl' constructor (True, header) assocs) <> nl <>
78 " deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable)"
79 fromMTexts = foldl' fromText (cons <> nl <> nl <>
80 "-- | Maybe get the CountryCode from the text code." <> nl <>
81 "fromMText :: T.Text -> Maybe CountryCode") assocs <> nl <>
82 "fromMText _ = Nothing"
83 fromTexts = fromMTexts <> nl <> nl <>
84 "-- | Get the CountryCode from the text code. Errors if the code is unknown" <> nl <>
85 "fromText :: T.Text -> CountryCode" <> nl <>
86 "fromText c = case fromMText c of" <> nl <>
87 " Just cc -> cc" <> nl <>
88 " _ -> error $ \"fromText: Unknown country code:\" ++ T.unpack c"
89 toTexts = foldl' toText (fromTexts <> nl <> nl <>
90 "-- | Get the code as text." <> nl <>
91 "toText :: CountryCode -> T.Text") assocs
92 fromMNames = foldl' fromName (toTexts <> nl <> nl <>
93 "-- | Maybe get the code from the user readable name." <> nl <>
94 "fromMName :: T.Text -> Maybe CountryCode") assocs <> nl <>
95 "fromMName _ = Nothing"
96 fromNames = fromMNames <> nl <> nl <>
97 "-- | Get the CountryCode from the user readable name. Errors if the name is unknown" <> nl <>
98 "fromName:: T.Text -> CountryCode" <> nl <>
99 "fromName c = case fromMName c of" <> nl <>
100 " Just cc -> cc" <> nl <>
101 " _ -> error $ \"fromName: Unknown country code:\" ++ T.unpack c"
102 toNames = foldl' toName (fromNames <> nl <> nl <>
103 "-- | Get the user readable name." <> nl <>
104 "toName :: CountryCode -> T.Text") assocs
105 countryList = snd (foldl' toList ("", toNames <> nl <> nl <>
106 "-- | list of names sorted by alphabetical order, with country code" <> nl <>
107 "-- this is ready to be used in a yesod selectField, for example" <> nl <>
108 "countryList :: [(T.Text,CountryCode)]" <> nl <>
109 "countryList = [")
110 $ sortBy (compare `on` fst) $ map swap assocs) <> " ]"
111 json = countryList <> nl <> nl <>
112 "-- | to json: as a simple string" <> nl <>
113 "instance ToJSON CountryCode where" <> nl <>
114 " toJSON =toJSON . toText" <> nl <>
115 nl <>
116 "-- | from json: as a simple string" <> nl <>
117 "instance FromJSON CountryCode where" <> nl <>
118 " parseJSON (String s)" <> nl <>
119 " | Just a <- fromMText s=pure a" <> nl <>
120 " parseJSON _ =fail \"CountryCode\"" <> nl <> nl
121 sp = json <>
122 "-- | show user readable name, in English (ignoring locale for now)" <> nl <>
123 "instance RenderMessage master CountryCode where" <> nl <>
124 " renderMessage _ _ = toName" <> nl <> nl
125 in sp
127 where
128 constructor :: (Bool,T.Text) -> (T.Text,T.Text) -> (Bool,T.Text)
129 constructor (True,acc) (i,_) = (False,acc <> "data CountryCode = " <> nl <> " " <> i)
130 constructor (False,acc) (i,_) = (False,acc <> nl <> " | " <> i)
131 fromText :: T.Text -> (T.Text,T.Text) -> T.Text
132 fromText acc (i,_) = acc <> nl <> "fromMText \"" <> i <> "\" = Just " <> i
133 toText :: T.Text -> (T.Text,T.Text) -> T.Text
134 toText acc (i,_) = acc <> nl <> "toText " <> i <> " = \"" <> i <> "\""
135 fromName :: T.Text -> (T.Text,T.Text) -> T.Text
136 fromName acc (i,n) = acc <> nl <> "fromMName \"" <> n <> "\" = Just " <> i
137 toName :: T.Text -> (T.Text,T.Text) -> T.Text
138 toName acc (i,n) = acc <> nl <> "toName " <> i <> " = \"" <> n <> "\""
139 toList :: (T.Text,T.Text) -> (T.Text,T.Text) -> (T.Text,T.Text)
140 toList (sep,acc) (n,i) = (nl <> " ,",acc <> sep <> "(\"" <> n <> "\"," <> i <> ")")
142-- | new line
143nl :: T.Text
144nl = "\n"