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 ]"