peephole refactoring

src/Snap/Snaplet/Redson.hs

@@ -106,7 +106,9 @@ withAuth :: (MonadState (Redson b1) (m b1 v), MonadSnaplet m) =>
             m b1 (AuthManager b1) b -> m b1 v b
 withAuth action = do
   am <- gets auth
-  return =<< withTop am action
+  withTop am action
+-- Pointfree is more concise but less readable
+-- withAuth = (gets auth >>=) . flip withTop
 
 
 ------------------------------------------------------------------------------
@@ -173,7 +175,7 @@ deletionMessage = modelMessage "delete"
 ------------------------------------------------------------------------------
 -- | Encode Redis HGETALL reply to B.ByteString with JSON.
 commitToJson :: Commit -> LB.ByteString
-commitToJson r = A.encode r
+commitToJson = A.encode
 
 
 ------------------------------------------------------------------------------
@@ -186,16 +188,9 @@ commitToJson r = A.encode r
 -- fail.
 jsonToCommit :: LB.ByteString -> Maybe Commit
 jsonToCommit s =
-    let
-        j = A.decode s
-    in
-      case j of
-        Nothing -> Nothing
-        Just m ->
-             -- Omit fields with null values and "id" key
-            Just (M.filterWithKey 
-                       (\k _ -> k /= "id")
-                       m)
+    -- Omit fields with null values and "id" key
+    M.filterWithKey (const (/= "id"))
+    <$> A.decode s
 
 
 ------------------------------------------------------------------------------
@@ -225,10 +220,9 @@ post = ifTop $ do
         -- the response SHOULD be 201 (Created) and contain an entity which
         -- describes the status of the request and refers to the new
         -- resource
-        modifyResponse $ (setContentType "application/json" . setResponseCode 201)
+        modifyResponse $ setContentType "application/json" . setResponseCode 201
         -- Tell client new instance id in response JSON.
         writeLBS $ A.encode $ M.insert "id" newId commit
-        return ()
 
 
 ------------------------------------------------------------------------------
@@ -245,8 +239,7 @@ read' = ifTop $ do
          handleError notFound
 
     modifyResponse $ setContentType "application/json"
-    writeLBS $ commitToJson $ (filterUnreadable au mdl (M.fromList r))
-    return ()
+    writeLBS $ commitToJson $ filterUnreadable au mdl (M.fromList r)
 
 
 ------------------------------------------------------------------------------
@@ -270,7 +263,6 @@ put = ifTop $ do
         Right _ <- runRedisDB database $ 
            CRUD.update mname id j (maybe [] indices mdl)
         modifyResponse $ setResponseCode 204
-        return ()
 
 
 ------------------------------------------------------------------------------
@@ -368,8 +360,8 @@ listModels = ifTop $ do
         Nothing -> handleError unauthorized >> return []
         -- Leave only readable models.
         Just user ->
-            gets (filter (\(_, m) -> elem GET $
-                                     getModelPermissions (Right user) m)
+            gets (filter (elem GET
+                          . getModelPermissions (Right user) . snd)
                   . M.toList . models)
   modifyResponse $ setContentType "application/json"
   writeLBS (A.encode $ 
@@ -409,15 +401,15 @@ search =
               -- TODO: Mark these field names as reserved
               mType <- getParam "_matchType"
               sType <- getParam "_searchType"
-              outFields <- (\p -> maybe [] (B.split comma) p) <$>
+              outFields <- maybe [] (B.split comma) <$>
                            getParam "_fields"
 
-              patFunction <- return $ case mType of
+              let patFunction = case mType of
                                Just "p"  -> prefixMatch
                                Just "s"  -> substringMatch
                                _         -> prefixMatch
 
-              searchType  <- return $ case sType of
+              let searchType  = case sType of
                                Just "and" -> intersectAll
                                Just "or"  -> unionAll
                                _          -> intersectAll
@@ -448,7 +440,7 @@ search =
                       case outFields of
                         [] -> writeLBS $ A.encode instances
                         _ -> writeLBS $ A.encode $
-                             map (flip CRUD.onlyFields outFields) instances
+                             map (`CRUD.onlyFields` outFields) instances
 
 
 mapSnd :: (b -> c) -> (a, b) -> (a, c)

src/Snap/Snaplet/Redson/Search.hs

@@ -74,5 +74,4 @@ redisSearch model searchTerms patFunction =
               return ids
      in
        -- Try to get search results for every index field
-       mapM (\s -> getTermIds (patFunction mname s))
-            searchTerms
+       mapM (getTermIds . (patFunction mname)) searchTerms

src/Snap/Snaplet/Redson/Snapless/Metamodel.hs

@@ -203,21 +203,14 @@ groupFieldName parent field = B.concat [parent, "_", field]
 spliceGroups :: Groups -> Model -> Model
 spliceGroups groups model =
     let
-        origFields = fields model
+        updateNames f = fromMaybe [f] $ do
+            n <- groupName f
+            grp <- M.lookup n groups
+            return $ map (\gf -> gf{ groupName = Just n
+                                   , name = groupFieldName (name f) (name gf)
+                                   }) grp
     in
-      model{fields = concat $
-            map (\f -> 
-                 case groupName f of
-                   Just n -> 
-                       case (M.lookup n groups) of
-                         Just grp -> 
-                             map (\gf -> gf{ groupName = Just n
-                                           , name = groupFieldName (name f) (name gf)
-                                           }) grp
-                         Nothing -> [f]
-                   _ -> [f]
-                ) origFields}
-
+        model{fields = concatMap updateNames $ fields model}
 
 -- | Perform all applications in model.
 doApplications :: Model -> Model

src/Snap/Snaplet/Redson/Snapless/Metamodel/Loader.hs

@@ -47,15 +47,11 @@ loadModel :: FilePath
           -> Groups 
           -- ^ Group definitions
           -> IO (Maybe Model)
-loadModel modelFile groups =
-    do
-      mres <- parseFile modelFile
-      return $ case mres of
-                 Just model -> Just $ 
-                               cacheIndices $
-                               doApplications $
-                               spliceGroups groups model
-                 Nothing -> Nothing
+loadModel modelFile groups
+    =  (fmap $ cacheIndices
+             . doApplications
+             . spliceGroups groups)
+    <$> parseFile modelFile
 
 
 -- | Build metamodel name from its file path.
@@ -75,7 +71,7 @@ loadModels directory groupsFile =
         dirEntries <- getDirectoryContents directory
         -- Leave out non-files
         mdlFiles <- filterM doesFileExist
-                 (map (\f -> directory ++ "/" ++ f) dirEntries)
+                 (map (directory </>) dirEntries)
         gs <- loadGroups groupsFile
         case gs of
           Just groups -> do

src/Snap/Snaplet/Redson/Util.hs

@@ -13,7 +13,7 @@ import Control.Applicative
 import Data.Char (isDigit)
 
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.UTF8 as BU (toString)
+import qualified Data.ByteString.Char8 as B8 (readInt)
 
 import Data.Maybe
 
@@ -30,12 +30,8 @@ fromParam p = fromMaybe "" <$> getParam p
 fromIntParam :: MonadSnap m => ByteString -> Int -> m Int
 fromIntParam p def = do
   i <- getParam p
-  return $ case i of
-      Just b -> let
-          s = BU.toString b
-          in
-            if (all isDigit s) then (read s)
-            else def
+  return $ case i >>= B8.readInt of
+      Just (j, "") -> j
       _ -> def