Commits

Yuri Bochkarev  committed db1aad9

[*] fix most of hlint warnings

  • Participants
  • Parent commits 02256b0

Comments (0)

Files changed (12)

File src/Configuration.hs

   
   ) where
 
+import qualified Data.Maybe as May
 import qualified Data.Map as Map
 import qualified Text.JSON as J
 import qualified Control.Exception as C
       join = intercalate "/"
       expandPair p = case lookup (fst p) env of
         Nothing -> ""
-        Just x -> if (null $ snd p)
+        Just x -> if null $ snd p
                   then x
                   else join [x, snd p]
       nonEmpty = filter (not . null)
-      vars = (nonEmpty $ map expandPair pathPairs) ++ xdgConfigDirs
+      vars = nonEmpty $ map expandPair pathPairs ++ xdgConfigDirs
       varPaths = map (\x -> join [x, "imp", base]) vars
   
   return varPaths
   
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
-        f id = lookRead as id
+        f = lookRead as
         m id = maybe (J.Ok Nothing) (liftM Just . J.readJSON) (lookup id as)
     in HttpProxy <$> f "url" <*> m "username" <*> m "password"
 
   
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
-        f id = lookRead as id
+        f = lookRead as
     in EngineAuth <$> f "engine" <*> f "username" <*> f "password"
   
   readJSON _ = return $ EngineAuth "" "" ""
         mMaybe              = mDefFun Just Nothing
         mDef def            = mDefFun id def
         mDefFun fun def idx = maybe (J.Ok def) (liftM fun . J.readJSON) (lookup idx as)
-    in do
-      Configuration
-        <$> mDefFun (1000 *) dummyNetworkTimeout "network_timeout"
-        <*> mMaybe         "http_proxy"
-        <*> mDef    []     "engine_auth"
-        <*> mDef    []     "engine_priority"
-        <*> mDef    []     "file_type_mapping"
-        <*> mDef    False  "try_next_engine_on_error"
+    in Configuration
+         <$> mDefFun (1000 *) dummyNetworkTimeout "network_timeout"
+         <*> mMaybe         "http_proxy"
+         <*> mDef    []     "engine_auth"
+         <*> mDef    []     "engine_priority"
+         <*> mDef    []     "file_type_mapping"
+         <*> mDef    False  "try_next_engine_on_error"
     
-  readJSON _ = return $ dummyConf
+  readJSON _ = return dummyConf
 
 dummyConf = Configuration {
   cfgNetworkTimeout       = dummyNetworkTimeout,
 processConfig Nothing = Nothing
 processConfig (Just "") = Just dummyConf
 processConfig (Just contents) =
-  case ((J.decode contents) :: J.Result Configuration) of
+  case (J.decode contents :: J.Result Configuration) of
     J.Ok conf -> Just conf
     J.Error string -> Nothing
 
 readConfigFiles :: [FilePath] -> IO Configuration
 readConfigFiles xs = do
   configContents <- mapM readConfigFile xs
-  return $ head $ catMaybes $ map processConfig configContents
+  return $ head $ May.mapMaybe processConfig configContents
 
 getEngineAuth :: Configuration -> String -> Maybe EngineAuth
 getEngineAuth config engineName = find (\auth -> eaEngine auth == engineName) $ cfgEngineAuths config

File src/Engine.hs

 import Network.Browser
 import System.IO.Error
 
+import Control.Monad (void)
+
+import qualified Data.Maybe as May
 import qualified Data.Map as Map
 import qualified Data.List as List
 import qualified Network.URI as URI
 } deriving (Monad,
             MonadIO,
             MonadReader Configuration.Configuration,
-            MonadState PasteContext )
+            MonadState PasteContext,
+            Functor)
 
 instance Show (PasteHandler a) where
   show _ = "PasteHandler"
   toString (TextField key value) UrlEncoded = encodeUrl key ++ "=" ++ encodeUrl value where
     encodeUrl = URI.normalizeEscape . URI.escapeURIString (\_ -> False)
   toString (EmptyFilenameField _) UrlEncoded = "<undefined>"
-  toString (BinaryFileField _ _ _) UrlEncoded = "<undefined>"
+  toString (BinaryFileField {}) UrlEncoded = "<undefined>"
 
   toString (EmptyFilenameField n) MultipartFormData =
     "Content-Disposition: form-data; name=\"file" ++ show n ++ "\"; filename=\"\"\r\n" ++
     where
       contentType name | name =~ "\\.[jJ][pP][gG]" = "Content-Type: image/jpeg\r\n"
       contentType name | name =~ "\\.[pP][nN][gG]" = "Content-Type: image/png\r\n"
-      contentType name | otherwise = "Content-Type: unknown\r\n"
+      contentType name = "Content-Type: unknown\r\n"
 
 -- | Encoding
 
 
 encodeInputFields :: [InputField] -> String -> EncodingType -> String
 encodeInputFields fields boundary MultipartFormData = concat t ++ h where
-  encoded = map (\x -> encodeInputField x boundary) fields
-  h = (head encoded) ++ "--"
+  encoded = map (`encodeInputField` boundary) fields
+  h = head encoded ++ "--"
   t = tail encoded
 
 encodeInputFields fields _ UrlEncoded = List.intercalate "&" $ map encodeField fields where
 encodeContentWithFile :: String -> String -> String -> InputFields -> FilePath -> String
 encodeContentWithFile boundary content fileFieldName fields filename =
   "--" ++ boundary ++ 
-  encodeInputFields ((BinaryFileField fileFieldName filename content):fields) boundary MultipartFormData ++
+  encodeInputFields (BinaryFileField fileFieldName filename content : fields) boundary MultipartFormData ++
   "\r\n"
 
 encodeContentWithoutFile :: String -> InputFields -> EncodingType -> String
   headers = retrieveHeaders HdrSetCookie response
 
 mergeCookies :: [Header] -> String -> Header
-mergeCookies cookies separator = mkHeader HdrCookie $ concat $ List.intersperse separator $ map hdrValue $ cookies
+mergeCookies cookies separator = mkHeader HdrCookie $ List.intercalate separator $ map hdrValue cookies
 
 addFields :: PasteContext -> InputFields -> PasteContext
 addFields context newFields = context { Engine.pcFields = newFields ++ Engine.pcFields context }
 
   (uri, rsp) <- browse $ do
     setAllowRedirects redirect -- handle HTTP redirects
-    setProxy $ proxy
+    setProxy proxy
     --setDebugLog Nothing
-    setOutHandler $ const (return ())
-    request $ req
+    setOutHandler $ const $ return ()
+    request req
   return rsp
 
 preparePostRequest :: Bool -> PasteContext -> Request String
     msgDebug "--- sendPost ---"
     let request = preparator context
     
-    msgDebug $ "request body len = " ++ (show (length (rqBody request)))
+    msgDebug $ "request body len = " ++ show (length (rqBody request))
     dumpString "request.body.dump.bin" $ rqBody request
 
     response <- fetch request $ pcAllowRedirect context
 type Grabber = PasteContext -> Response String -> [String]
 
 grabLocationHeader :: Grabber
-grabLocationHeader _ response = maybe [] (:[]) $ lookupHeader HdrLocation $ rspHeaders response
+grabLocationHeader _ response = May.maybeToList $ lookupHeader HdrLocation $ rspHeaders response
 
 grabExtractLinks :: String -> String -> LinkFilterType -> Grabber
-grabExtractLinks attr value flt context = \response ->
+grabExtractLinks attr value flt context response =
   Processing.extractLinks (rspBody response) attr value $ getFilter context flt
 
 -- Grabs links from page according to given field names and regexp
 saveFirstLinkExtended prefix postfix links = do
   context <- get
   case links of
-    (link:_) -> put context { Engine.pcResultLink = Just $ concat [prefix, link, postfix] } >> return ()
+    (link:_) -> void $ put context { Engine.pcResultLink = Just $ concat [prefix, link, postfix] }
     _        -> return ()

File src/EngineFastpic.hs

 getRefreshLink response = cut where
   refresh = HdrCustom "Refresh"
   headers = getHeaders response
-  cut = maybe Nothing (Just . drop 6) (lookupHeader refresh headers)
+  cut = fmap (drop 6) (lookupHeader refresh headers)

File src/EngineImgur.hs

 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 import Control.Applicative ((<$>), (<*>))
+import Control.Monad (void)
 
+import qualified Control.Arrow
 import qualified Data.Map as Map
 import qualified Data.List as List
 import qualified Text.JSON as J
   
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
-        f id = lookRead as id
-    in do
-      ImgurReply <$> f "upload"
+        f = lookRead as
+    in ImgurReply <$> f "upload"
     
-  readJSON _ = return $ dummyReply
+  readJSON _ = return dummyReply
 
 instance J.JSON ImgurUpload where
   showJSON _ = J.JSNull
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
         f id = lookRead as id
-    in do
-      ImgurUpload <$> f "image" <*> f "links"
+    in ImgurUpload <$> f "image" <*> f "links"
     
-  readJSON _ = return $ dummyUpload
+  readJSON _ = return dummyUpload
 
 instance J.JSON ImgurReplyImage where
   showJSON _ = J.JSNull
     let as = J.fromJSObject obj
         f id = lookRead as id
     in ImgurReplyImage
---           <$> f "name"
---           <*> f "title"
---           <*> f "caption"
            <$> f "hash"
            <*> f "deletehash"
            <*> f "datetime"
            <*> f "views"
            <*> f "bandwidth"
   
-  readJSON _ = return $ dummyImage
+  readJSON _ = return dummyImage
 
 instance J.JSON ImgurReplyLinks where
   showJSON _ = J.JSNull
   
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
-        f id = lookRead as id
+        f = lookRead as
     in ImgurReplyLinks
            <$> f "original"
            <*> f "imgur_page"
            <*> f "small_square"
            <*> f "large_thumbnail"
   
-  readJSON _ = return $ dummyLinks
+  readJSON _ = return dummyLinks
 
 imgurUploadUrl = "http://api.imgur.com/2/upload.json"
 imgurSigninUrl = "http://api.imgur.com/2/signin"
 
   let loginContext = signinConfig { Engine.pcFields = Engine.pcFields context ++ completeLoginFields }
       auth = Configuration.getEngineAuth config "imgur"
-      (name, password) = maybe ("", "") (\a -> (Configuration.eaName a, Configuration.eaPassword a)) auth
+      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
       completeLoginFields = [Engine.TextField "username" name,
                              Engine.TextField "password" password]
 
   response <- liftIO $ Engine.sendPostWithFile context
 
   let link reply = irlOriginal $ iuLinks $ irUpload reply
-      parseResult (J.Ok reply) = do
-        put context { Engine.pcResultLink = Just $ link reply }
-        return ()
-      parseResult _ = do
-        return ()
+      parseResult (J.Ok reply) = void $ put context { Engine.pcResultLink = Just $ link reply }
+      parseResult _            = return ()
 
   parseResult ((J.decode $ rspBody response) :: J.Result ImgurReply)

File src/EngineImm.hs

   
   readJSON (J.JSObject obj) =
     let as = J.fromJSObject obj
-        f id = lookRead as id
+        f = lookRead as
         m id = maybe (J.Ok Nothing) (liftM Just . J.readJSON) (lookup id as)
         mList id = maybe (J.Ok []) J.readJSON (lookup id as)
         mBool id def = maybe (J.Ok def) J.readJSON (lookup id as)
-    in do
-      ImmReply <$> f "success" <*> m "payload"
+    in ImmReply <$> f "success" <*> m "payload"
     
-  readJSON _ = return $ dummyReply
+  readJSON _ = return dummyReply
 
 dummyReplyPayload = ImmReplyPayload "" "" "" "" "" "" 0 0 ""
 
            <*> f "height"
            <*> f "size"
   
-  readJSON _ = return $ dummyReplyPayload
+  readJSON _ = return dummyReplyPayload
 
 immUploadUrl = "http://imm.io/store/"
 

File src/EngineRadikal.hs

 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 
+import qualified Control.Arrow
 import qualified Data.Map as Map
 import qualified Data.List as List
 
   -- add cookies (UID, SID) to authConfig from the context
   let 
       auth = Configuration.getEngineAuth config "radikal"
-      (name, password) = maybe ("", "") (\a -> (Configuration.eaName a, Configuration.eaPassword a)) auth
-      withFields = Engine.addFields authConfig [(Engine.TextField "username" name),
-                                                (Engine.TextField "upassword" password)]
+      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
+      withFields = Engine.addFields authConfig [Engine.TextField "username" name,
+                                                Engine.TextField "upassword" password]
       withCookies = Engine.addCustomHeaders withFields $ Engine.pcCustomHeaders context
   
   liftIO $ msgDebug "Sending post without file"

File src/EngineRghost.hs

 
 import Text.JSON
 
+import qualified Control.Arrow
 import qualified Data.Map as Map
 import qualified Data.List as List
 
   respStartPage <- liftIO $ Engine.fetch (getRequest "http://rghost.net/multiple/upload_host") True
   
   let text = rspBody respStartPage
-      result = ((decode text) :: Result RghostPair)
+      result = decode text :: Result RghostPair
       pair = (\(Ok x) -> x) result
   
   let cookie = case lookupHeader HdrSetCookie $ rspHeaders respStartPage of
       
   context <- get
 
-  liftIO $ msgDebug $ "filename = " ++ (show $ Engine.pcFileName context)
+  liftIO $ msgDebug $ "filename = " ++ show (Engine.pcFileName context)
 
-  let newContext = context { Engine.pcFields = (Engine.TextField "authenticity_token" (rpAuth pair)) : fields,
+  let newContext = context { Engine.pcFields = Engine.TextField "authenticity_token" (rpAuth pair) : fields,
                              Engine.pcCustomHeaders = customHeaders ++ headers,
-                             Engine.pcUploadLink = "http://" ++ (rpUrl pair) ++ "/files"
+                             Engine.pcUploadLink = "http://" ++ rpUrl pair ++ "/files"
                            }
       customHeaders = [Header HdrCookie cookie, Header HdrHost (rpUrl pair)]
       fields = Engine.pcFields context
   config <- ask
   context <- get
   let loginContext = loginConfig { Engine.pcFields = Engine.pcFields context ++ completeLoginFields,
-                                   Engine.pcCustomHeaders = [prevCookie] ++ mainHost
+                                   Engine.pcCustomHeaders = prevCookie : mainHost
                                  }
       auth = Configuration.getEngineAuth config "rghost"
-      (name, password) = maybe ("", "") (\a -> (Configuration.eaName a, Configuration.eaPassword a)) auth
+      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
       completeLoginFields = [Engine.TextField "email" name,
                              Engine.TextField "password" password]
       -- save original host - it might me muon or phonon

File src/EngineScrin.hs

 
   let postkey = fromMaybe "" mPostkey
       fields = Engine.pcFields context
-      newContext = context { Engine.pcFields = (Engine.TextField "postkey" postkey ) : fields }
+      newContext = context { Engine.pcFields = Engine.TextField "postkey" postkey : fields }
 
   put newContext
 

File src/EngineScrnsht.hs

 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 
+import qualified Control.Arrow
 import qualified Data.Map as Map
 import qualified Data.List as List
 import qualified Text.HTML.TagSoup as TS
   config <- ask
 
   let auth = Configuration.getEngineAuth config "scrnsht"
-      (name, password) = maybe ("", "") (\a -> (Configuration.eaName a, Configuration.eaPassword a)) auth
+      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
       credentials = [Engine.TextField "username" name,
                      Engine.TextField "userPasswordMD5" password]
 
   let text = rspBody response
       tags = TS.parseTags text :: [TS.Tag String]
       info = tagsToInfo tags
-      link = maybe Nothing (\x -> Just $ srOriginal x) info
+      link = fmap srOriginal info
 
   put context { Engine.pcResultLink = link }
 

File src/Runner.hs

 -- | Check the config for inappropriate values and fill them with valid ones
 fillConfig :: Configuration.Configuration -> Configuration.Configuration
 fillConfig oldConfig = oldConfig { Configuration.cfgEnginePriority = priority } where
-  priority = if (Configuration.cfgEnginePriority oldConfig == [])
+  priority = if Configuration.cfgEnginePriority oldConfig == []
              then Map.keys engineConfigs
              else Configuration.cfgEnginePriority oldConfig
 
 runEngine :: FilePath -> Configuration.Configuration -> String -> IO (Maybe String)
 runEngine filename config name = do
   msgDebug $ "Trying engine: " ++ show name
-  let (state, handler) = (engineConfigs Map.! name)
+  let (state, handler) = engineConfigs Map.! name
       runner           = Engine.runPasteHandler filename config state handler
       timeoutMus       = Configuration.cfgNetworkTimeout config
       timeoutMs        = timeoutMus `div` 1000
 -- | Mixes given engine names from priorities and file type mapping.
 -- Names from the mapping are pushed to the head of the resulting list
 buildPriority :: String -> [String] -> [Configuration.FileTypeMapping] -> [String]
-buildPriority filename priorities mappings = foldl addPriority priorities mappings where
-  addPriority prs mapping =
+buildPriority filename = foldl addPriority where
+  addPriority priorities mapping =
     let engine = Configuration.ftmEngine mapping
         types  = Configuration.ftmTypes mapping
-    in if any (flip List.isSuffixOf $ filename) types
-       then engine:(List.delete engine prs)
-       else prs
+    in if any (`List.isSuffixOf` filename) types
+       then engine : List.delete engine priorities
+       else priorities
 
 runArgs :: [String] -> Configuration.Configuration -> IO (Maybe String)
 
 -- | Run all available engines in an order affected by
 -- engine_priority and file_type_mapping properties
 runArgs (filename:[]) config = runEngines priorities (Configuration.cfgTryNextEngineOnError config) where
-  configPlusDefaultPriorities = List.nub $ (Configuration.cfgEnginePriority config) ++ defaultPriority
+  configPlusDefaultPriorities = List.nub $ Configuration.cfgEnginePriority config ++ defaultPriority
 
   priorities :: [String]
   priorities = buildPriority filename configPlusDefaultPriorities (Configuration.cfgFileTypeMapping config)

File src/Tools.hs

 import System.IO
 
 fileName :: String -> String
-fileName = reverse . (takeWhile (/= '/')) . reverse
+fileName = reverse . takeWhile (/= '/') . reverse
 
 fileExtension :: String -> String
-fileExtension = reverse . (takeWhile (/= '.')) . reverse . fileName
+fileExtension = reverse . takeWhile (/= '.') . reverse . fileName
 
 splitOn :: Char -> String -> [String]
 splitOn delim s = case dropWhile (== delim) s of

File src/Version.hs

-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE CPP #-}
 module Version (fullVersion) where
 
 #ifdef CABAL