diff --git a/src/HolyProject.hs b/src/HolyProject.hs index 120cff1..1196b44 100644 --- a/src/HolyProject.hs +++ b/src/HolyProject.hs @@ -31,6 +31,9 @@ import Control.Concurrent -- Get external file of package import Paths_holy_project +import Data.Maybe (fromMaybe) +import Control.Monad (void) + -- | Record containing all information to initialize a project data Project = Project { projectName :: String @@ -73,9 +76,8 @@ holyStarter = do (name,email) <- getNameAndMailFromGitConfig earlyhint <- newEmptyMVar maybe (putMVar earlyhint Nothing) -- if no email found put Nothing - (\hintmail -> do -- in the other case ask the github API - forkIO (putMVar earlyhint =<< searchGHUser hintmail) - >> return ()) + (\hintmail -> -- in the other case ask the github API + void (forkIO (putMVar earlyhint =<< searchGHUser hintmail))) email project <- ask "project name" Nothing ioassert (checkProjectName project) @@ -84,7 +86,7 @@ holyStarter = do modulename = capitalize project in_author <- ask "name" name in_email <- ask "email" email - ghUserHint <- if (maybe "" id email) /= in_email + ghUserHint <- if fromMaybe "" email /= in_email then searchGHUser in_email else takeMVar earlyhint in_ghaccount <- ask "github account" ghUserHint @@ -97,7 +99,8 @@ holyStarter = do -- | Simply return the current year as String getCurrentYear :: IO String getCurrentYear = do - (current_year,_,_) <- getCurrentTime >>= return . toGregorian . utctDay + -- (current_year,_,_) <- getCurrentTime >>= return . toGregorian . utctDay + (current_year,_,_) <- fmap (toGregorian . utctDay) getCurrentTime return (show current_year) -- | Show an introduction test @@ -142,7 +145,7 @@ createProject p = do let context = mkGenericContext p -- Check if the directory doesn't already exists dirExists <- doesDirectoryExist (projectName p) - ioassert (not dirExists) ((projectName p) ++ " directory already exists") + ioassert (not dirExists) (projectName p ++ " directory already exists") -- Create the directory and go into it createDirectory (projectName p) setCurrentDirectory (projectName p) @@ -164,25 +167,25 @@ createProject p = do , "interact" ) , ( "project.cabal" - , (projectName p) ++ ".cabal" + , projectName p ++ ".cabal" ) , ( "src/Main.hs" , "src" "Main.hs" ) , ( "src/ModuleName.hs" - , "src" ((moduleName p)++".hs") + , "src" (moduleName p++".hs") ) , ( "src/ModuleName/Coconut.hs" - , "src" (moduleName p) "Coconut.hs" + , "src" moduleName p "Coconut.hs" ) , ( "src/ModuleName/Swallow.hs" - , "src" (moduleName p) "Swallow.hs" + , "src" moduleName p "Swallow.hs" ) , ( "test/ModuleName/Coconut/Test.hs" - , "test" (moduleName p) "Coconut" "Test.hs" + , "test" moduleName p "Coconut" "Test.hs" ) , ( "test/ModuleName/Swallow/Test.hs" - , "test" (moduleName p) "Swallow" "Test.hs" + , "test" moduleName p "Swallow" "Test.hs" ) , ( "test/Test.hs" , "test" "Test.hs" @@ -195,5 +198,5 @@ createProject p = do _ <- system "cabal sandbox init" _ <- system "cabal install" _ <- system "cabal test" - _ <- system $ "./.cabal-sandbox/bin/test-" ++ (projectName p) + _ <- system $ "./.cabal-sandbox/bin/test-" ++ projectName p return () diff --git a/src/HolyProject/GitConfig.hs b/src/HolyProject/GitConfig.hs index fda0574..3ea0147 100644 --- a/src/HolyProject/GitConfig.hs +++ b/src/HolyProject/GitConfig.hs @@ -23,7 +23,7 @@ safeReadGitConfig = do (do home <- getEnv "HOME" LZ.readFile $ home ++ "/.gitconfig" ) - return $ either (const (LZ.empty)) id e + return $ either (const LZ.empty) id e -- | Returns the name and email from the content of a .gitconfig file -- almost equivalent to the two zsh lines: @@ -58,7 +58,7 @@ firstJust l = case dropWhile (==Nothing) l of getValueForKey :: String -- key -> [LZ.ByteString] -- line of words -> Maybe String -- the value if found -getValueForKey el (n:e:xs) = if (n == (LZ.pack el)) && (e == (LZ.pack "=")) +getValueForKey el (n:e:xs) = if (n == LZ.pack el) && (e == LZ.pack "=") then Just (LZ.unpack (LZ.unwords xs)) else Nothing getValueForKey _ _ = Nothing diff --git a/src/HolyProject/GithubAPI.hs b/src/HolyProject/GithubAPI.hs index 89ab15a..b2f557d 100644 --- a/src/HolyProject/GithubAPI.hs +++ b/src/HolyProject/GithubAPI.hs @@ -11,16 +11,14 @@ import Control.Lens.Aeson import Data.Aeson.Encode (fromValue) import qualified Data.Text.Lazy as TLZ import qualified Data.Text.Lazy.Builder as TLB +import Control.Monad ((<=<)) -- | make a simple http request but add a user agent to the HTTP header simpleHTTPWithUserAgent :: String -> IO LZ.ByteString simpleHTTPWithUserAgent url = do r <- parseUrl url let request = r { requestHeaders = [ ("User-Agent","HTTP-Conduit") ] } - body <- withManager $ \manager -> do - response <- httpLbs request manager - return $ responseBody response - return body + withManager $ (return.responseBody) <=< httpLbs request -- | Ask the github API -- A strange behaviour you HAVE TO add a User-Agent in your header. @@ -30,7 +28,7 @@ searchGHUser "" = return Nothing searchGHUser email = do let url = "https://api.github.com/search/users?q=" ++ email body <- simpleHTTPWithUserAgent url - login <- return $ body ^? key "items" . nth 0 . key "login" + let login = body ^? key "items" . nth 0 . key "login" return $ fmap jsonValueToString login where jsonValueToString = TLZ.unpack . TLB.toLazyText . fromValue diff --git a/src/HolyProject/MontyPython.hs b/src/HolyProject/MontyPython.hs index e5fd05e..518e7df 100644 --- a/src/HolyProject/MontyPython.hs +++ b/src/HolyProject/MontyPython.hs @@ -7,7 +7,7 @@ where -- Console read write with colors import System.Console.ANSI import System.IO (hFlush, stdout) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust,isJust) -- | bridgekeeper speak bk :: String -> IO () @@ -31,12 +31,12 @@ ask :: String -- ^ What? "name" for example -> IO String ask info hint = do bk $ "What is your " ++ info ++ "?" ++ - (maybe "" (\h -> " ("++h++")") hint) + maybe "" (\h -> " ("++h++")") hint putStr "> " hFlush stdout answer <- getLine putStrLn "" - return $ if (answer == "") && (hint /= Nothing) + return $ if (answer == "") && isJust hint then fromJust hint else answer diff --git a/src/HolyProject/StringUtils.hs b/src/HolyProject/StringUtils.hs index a865d40..4bbbb82 100644 --- a/src/HolyProject/StringUtils.hs +++ b/src/HolyProject/StringUtils.hs @@ -6,23 +6,23 @@ module HolyProject.StringUtils -- Project name manipulation import Data.Char (toUpper,toLower,isLetter,isNumber) -import Data.List (intersperse) +import Data.List (intercalate) import Data.List.Split (splitOneOf) -- | transform a chain like "Holy project" in "holy-project" projectNameFromString :: String -> String -projectNameFromString str = concat $ intersperse "-" (splitOneOf " -" (map toLower str)) +projectNameFromString str = intercalate "-" (splitOneOf " -" (map toLower str)) -- | transform a chain like "Holy project" in "HolyProject" capitalize :: String -> String -capitalize str = concat (map capitalizeWord (splitOneOf " -" str)) +capitalize str = concatMap capitalizeWord (splitOneOf " -" str) where capitalizeWord :: String -> String - capitalizeWord (x:xs) = (toUpper x):map toLower xs + capitalizeWord (x:xs) = toUpper x:map toLower xs capitalizeWord _ = [] -- | verify if a project name is conform checkProjectName :: String -> Bool checkProjectName [] = False -checkProjectName str = all (\c -> (isLetter c)||(isNumber c)||(c=='-')||(c==' ')) str +checkProjectName str = all (\c -> isLetter c || isNumber c || c=='-' || c==' ' ) str diff --git a/test/HolyProject/StringUtils/Test.hs b/test/HolyProject/StringUtils/Test.hs index 2d96b3a..1635723 100644 --- a/test/HolyProject/StringUtils/Test.hs +++ b/test/HolyProject/StringUtils/Test.hs @@ -1,7 +1,7 @@ module HolyProject.StringUtils.Test ( stringUtilsSuite ) where -import Data.Char (isControl,isSymbol) +import Data.Char (isPrint,isSymbol) import Test.Tasty (testGroup, TestTree) import Test.Tasty.HUnit import Test.Tasty.SmallCheck (forAll) @@ -10,6 +10,7 @@ import qualified Test.Tasty.QuickCheck as QC import Test.SmallCheck.Series (Serial) import HolyProject.StringUtils +-- | Test with QuickCheck and SmallCheck tp name prop = testGroup name [ QC.testProperty "QC" prop , SC.testProperty "SC" prop @@ -22,15 +23,15 @@ stringUtilsSuite = testGroup "StringUtils" , SC.testProperty "capitalize idempotent" $ deeperIdempotent capitalize , tp "no space in project name" $ - \s -> dropWhile (/=' ') (projectNameFromString s) == [] + \s -> ' ' `notElem` projectNameFromString s , tp "no space in capitalized name" $ - \s -> dropWhile (/=' ') (capitalize s) == [] + \s -> ' ' `notElem` capitalize s , tp "no dash in capitalized name" $ - \s -> dropWhile (/='-') (capitalize s) == [] + \s -> '-' `notElem` capitalize s , tp "no control char" $ - \s -> if (s /= "") && (checkProjectName s == True) then (all (not . isControl) s) else True + \s -> not (checkProjectName s) || all isPrint s , tp "no symbol char" $ - \s -> if (s /= "") && (checkProjectName s == True) then (all (not . isSymbol) s) else True + \s -> not (checkProjectName s) || all (not . isSymbol) s , testCase "doesn't accept empty project name" $ checkProjectName "" @=? False ]