WURFL-0.1: src/Convert.hs
module Convert where
import Text.XML.HXT.Arrow hiding(Tree)
import Control.Arrow.ArrowList
import qualified Data.Map as M
import Data.Maybe
import Control.Monad.State
import WURFLParser
import CreateTree
import Data.List
import WURFLTypes
class HaskellCode a where
printVal :: a -> String
instance HaskellCode String where
printVal s = "\"" ++ s ++ "\""
instance HaskellCode a => HaskellCode (Maybe a) where
printVal Nothing = ""
printVal (Just v) = printVal v
instance HaskellCode [Maybe String] where
printVal l = "[" ++ (concat . intersperse "," . map printVal $ l) ++ "]"
instance HaskellCode MD where
printVal (MD a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) =
"(MD "
++ (show a1) ++ " "
++ (show a2) ++ " "
++ (show a3) ++ " "
++ (show a4) ++ " "
++ (show a5) ++ " "
++ (show a6) ++ " "
++ (show a7) ++ " "
++ (show a8) ++ " "
++ (show a9) ++ " "
++ (show a10) ++ " "
++ (show a11) ++ " "
++ (show a12) ++ " "
++ (show a13) ++ " "
++ (show a14) ++ " "
++ (show a15) ++ " "
++ (show a16) ++ " "
++ (show a17) ++ " "
++ ")"
setting :: String -> String -> IOSArrow XmlTree (Maybe String)
setting group capability = (getChildren
>>> (hasName "group" >>> hasAttrValue "id" ((==) group)
>>> getChildren >>> hasName "capability" >>> hasAttrValue "name" ((==) capability)
>>> getAttrValue "value" >>> arr Just))
`orElse` (arr (const Nothing))
deviceInfo :: IOSArrow XmlTree [Maybe String]
deviceInfo = listA . catA $
[ setting "bugs" "post_method_support"
, setting "display" "columns"
, setting "display" "rows"
, setting "display" "max_image_height"
, setting "display" "max_image_width"
, setting "image_format" "colors"
, setting "image_format" "gif"
, setting "image_format" "jpg"
, setting "image_format" "png"
, setting "j2me" "j2me_midp_2_0"
, setting "j2me" "j2me_heap_size"
, setting "j2me" "j2me_screen_height"
, setting "j2me" "j2me_screen_width"
, setting "markup" "preferred_markup"
, setting "product_info" "brand_name"
, setting "product_info" "is_wireless_device"
, setting "streaming" "streaming_3gpp"
]
getDevice :: IOSArrow XmlTree (String,String,String,[Maybe String])
getDevice = (getAttrValue "id" &&& getAttrValue "fall_back" &&& getAttrValue "user_agent" &&& deviceInfo) >>> arr flat
where
flat (a,(b,(c,d))) = (a,b,c,d)
process :: String -> IO [(String,String,String,[Maybe String])]
process s = runX $ (readDocument [(a_validate,"0"),(a_encoding,utf8)] s >>>
deep (hasName "device") >>> getDevice
)
instance Tropical a => Tropical [a] where
tempty = repeat tempty
a `tappend` b = zipWith tappend a b
getId (i,_,_,_) = i
getFallback (_,f,_,_) = f
getUserAgent (_,_,u,_) = u
type Mob a = (String,String,String,a)
getValue :: Mob a -> a
getValue (_,_,_,v) = v
hasUserAgent r = (getUserAgent r) /= ""
listDevices :: [Maybe String] -> Tree [Maybe String] -> [(String,MD)]
listDevices ov (Node s Nothing l) = concatMap (listDevices ov) l
listDevices ov (Node s (Just v) l) = (s,toMD v'):concatMap (listDevices v') l
where
isTrue a = if a == "true" then True else False
v' = (ov `tappend` v)
toMD :: [Maybe String] -> MD
toMD (a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:a16:a17:[]) =
MD (isTrue $ fromMaybe "true" a1) -- Post support
(read $ fromMaybe "11" a2) -- columns
(read $ fromMaybe "2" a3) -- row 2
(read $ fromMaybe "35" a4) -- height
(read $ fromMaybe "90" a5) -- width
(read $ fromMaybe "2" a6) -- colors
(isTrue $ fromMaybe "false" a7)
(isTrue $ fromMaybe "false" a8)
(isTrue $ fromMaybe "false" a9)
(isTrue $ fromMaybe "false" a10)
(read $ fromMaybe "0" a11) -- j2me heap
(read $ fromMaybe "0" a12) -- Jéme width and height
(read $ fromMaybe "0" a13)
(fromMaybe "wml_1_1" a14) -- prefered markup
(fromMaybe "Unknown" a15) -- brand
(isTrue $ fromMaybe "true" a16) -- is wireless
(isTrue $ fromMaybe "false" a17) -- streaming
createTree :: Tropical a => M.Map String (Mob a) -> M.Map String [Mob a] -> a -> String -> [Tree a]
createTree allDevices fallbacks rootvalue mob = let result = processChildren in
case result of
Nothing -> error mob
Just l -> l
where
processChildren = do
current <- M.lookup mob allDevices
let children = M.lookup mob fallbacks
cv = getValue current
agent = getUserAgent current
if hasUserAgent current
then do
case children of
Nothing -> return [Node agent (Just(rootvalue `tappend` cv)) []]
Just c -> do
let r = concatMap (createTree allDevices fallbacks tempty . getId) c
return $ [Node agent (Just (rootvalue `tappend` cv)) r]
else do
case children of
Nothing -> error ("No user agent and no children : " ++ mob)
Just c -> do
let r = concatMap (createTree allDevices fallbacks (rootvalue `tappend` cv) . getId) c
return r
printTrees :: Int -> [Tree MD] -> String
printTrees n l = let space = concat . replicate n $ " "
tls = map (printTree n) $ l in
concat . mapNotFirst (\x -> "\n" ++ space ++ "," ++ x) $ tls
where
mapNotFirst f [] = []
mapNotFirst f (a:[]) = [a]
mapNotFirst f (a:b) = a:map f b
printTree :: Int -> Tree MD -> String
printTree n (Node s Nothing l) = let r = "Node " ++ show s ++ " Nothing [" in
r ++ printTrees (n + length r) l ++ " " ++ "]"
printTree n (Node s (Just v) l) = let r = "Node " ++ show s ++ " (Just (" ++ printVal v ++ ")) [" in
r ++ printTrees (n + length r) l ++ " " ++ "]"
generateTree :: String -> IO String
generateTree s = do
mobiles <- process s
let allDevices = M.fromList . zip (map getId mobiles) $ mobiles
fallbacks = M.fromListWith (++) . zip (map getFallback mobiles) $ map (\x -> [x]) mobiles
t = createTree allDevices fallbacks tempty "generic"
--print mobiles
-- Now we have a tree useful to generate the phone settings
-- But we need to create another tree for the parsing of the user agent string
--print . concatMap (\x -> [x]) . analyze . concatMap (listDevices tempty) $ t
return $ "wurfldb=["
++ (printTrees 5 . concatMap simplifyTree . analyze . concatMap (listDevices tempty) $ t)
++ "\n ]"