Мыслеформы -
jdevelop — 06.07.2010 забавно, с тайпклассами весьма удобно делать совершенно дикие вещину например вместо того, чтобы передавать в функцию еще пачку функций-трансформаторов, делаешь себе чуток data/newtype, говоришь правильные типы явно в сигнатуре функции или в выражении - и оно самостоятельно работает
а код при этом уменьшается раза так в полтора-два
автоматический деривинг классов - вообще космическая вещь, никакой жабе в упор не снилось
получается такое себе квазиметапрограммирование - достаточно определить операции над типами, и компилятор сделает все остальное по месту пользования
например
newtype Result a = Result { getLJResult :: Either LJError a } deriving (Show) makeErrorStr :: String -> Result (Either LJError a) makeErrorStr = Result . Left . SimpleError makeError :: LJError -> Result a makeError = Result . Left makeResult :: a -> Result a makeResult = Result . Right class ResponseTransformer a b where transform :: ParseResult String a -> b applyResultP :: (ResponseTransformer a b) => Result (ParseResult String a) -> Result b applyResultP = applyResultP' . getLJResult where applyResultP' (Left err) = makeError err applyResultP' (Right s) = makeResult $ transform s runRequest :: (ResponseTransformer a b) => LJRequest -> CustomResponseParser String a -> IO ( Result b ) runRequest request responseParser = do curl <- CU.initialize applyResultP <$> parseResponse _customObjectFactory _customObjectDAO . extractResponse <$> CU.do_curl_ curl "http://www.livejournal.com/interface/flat" curlOptions where _customObjectFactory = customObjectFactory responseParser _customObjectDAO = customObjectDAO responseParser curlOptions = makeRequest request : CU.method_POST makeRequest = CurlPostFields . DL.map makeParamNV . params makeParamNV (RequestParam name value) = name ++ "=" ++ value newtype ChalString a = ChalString { getChStr :: a } instance ResponseTransformer ( ChalString String ) (Maybe String) where transform (simpleMap, _, _) = DMP.lookup "challenge" simpleMap prepareChallenge :: String -> IO (Maybe (String, String)) prepareChallenge password = do handleResponse <$> (runRequest request (CRP noFactory noUpdate) :: IO (Result (Maybe String))) where handleResponse src = handleResponse' $ getLJResult src handleResponse' (Left err) = Nothing handleResponse' (Right res) = makeChallengePair <$> res request = makeRequest [("mode","getchallenge")] noFactory :: String -> Maybe ( ChalString String ) noFactory = \_ -> Nothing noUpdate = \_ _ _ _ -> Nothing makeChallengePair chal = ( chal, hashcode chal ) md5Pass = MD5.md5sum $ BStr.pack password hashcode chal = MD5.md5sum . BStr.pack $ chal ++ md5Pass
по факту расширение формата парсинга делается через определение инстанса ResponseTransformer, навроде как
instance ResponseTransformer LoginResponseData LJLoginResponse where transform (simpleMap, enumMap, objectMap) = undefined -- TODO get parts of response from the map loginExt :: LJLoginRequest -> IO ( Result LJLoginResponse ) loginExt request = prepareChallenge ( password request ) >>= DM.maybe emptyResponse login' where emptyResponse = return ( makeError NoChallenge ) login' (chal, auth_response) = runRequest request' (CRP loginObjectFactory loginObjectUpdater) :: IO (Result LJLoginResponse) where params = DL.concat [ [ ("mode","login"), ("user",user request), ("auth_method","challenge"), ("auth_challenge",chal), ("auth_response",auth_response) ], DM.maybe [] ( makeTupleSArr "getmoods" . show ) ( moods request ), guard (menus request) >> makeTupleSArr "getmenus" "1", guard (pickws request) >> makeTupleSArr "getpickws" "1", guard (pickwurls request) >> makeTupleSArr "getpickwurls" "1" ] request' = makeRequest params makeTupleSArr = ( return . ) . (,)
в сухом остатке получаем, что основное действие выполняется внутри
runRequest request' (CRP loginObjectFactory loginObjectUpdater) :: IO (Result LJLoginResponse)
где указание IO (Result LJLoginResponse) включает в работу аццкую типодробилку и на выходе применяются правильные тайпклассы к правильным объектам