hlint pass
This commit is contained in:
parent
d021b69ffc
commit
aaebeecce1
6 changed files with 36 additions and 34 deletions
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue