diff --git a/elm-init.cabal b/elm-init.cabal --- a/elm-init.cabal +++ b/elm-init.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: elm-init -version: 0.1.1.1 +version: 0.1.2.0 synopsis: Set up basic structure for an elm project description: Initialize a new empty elm project with some basic scaffolding according to 'https://github.com/evancz/elm-architecture-tutorial'. @@ -41,6 +41,8 @@ containers >= 0.5 hs-source-dirs: src default-language: Haskell2010 + ghc-options: + -Wall source-repository head type: git diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -3,19 +3,22 @@ module Main (main) where + import Control.Applicative (pure, (<*>)) import qualified Control.Arrow as Arrow (first) import Control.Exception (IOException, catch) +import Control.Monad ((>=>)) import Data.Aeson as Aeson (ToJSON, Value, object, toJSON, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Bool (bool) -import qualified Data.ByteString as ByteString (ByteString, empty, - hPut, putStrLn) +import qualified Data.ByteString as ByteString (ByteString, hPut) import qualified Data.ByteString.Lazy as LBS (hPut) import Data.FileEmbed (embedFile) +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) import Data.Text as Text (Text, append, intercalate, - pack, splitOn, unpack, toLower) + pack, splitOn, unpack) import Data.Text.IO as TextIO (getLine, putStrLn) import Data.Traversable (sequenceA) import Prelude hiding (getLine, putStrLn) @@ -27,6 +30,43 @@ import System.IO (IOMode (WriteMode), withFile) +standardDirectories :: [FilePath] +standardDirectories = [ "elm-stuff" ] + +standardSourceFolders :: [FilePath] +standardSourceFolders = [ "src" ] + +standardFiles :: [(FilePath, Maybe ByteString.ByteString)] +standardFiles = [ ("README.md", Nothing) ] + +standardSourceFiles :: [(FilePath, Maybe ByteString.ByteString)] +standardSourceFiles = [ ("Main.elm", Just $(embedFile "resources/Main.elm")) ] + +standardLicenses :: [(Text, Maybe ByteString.ByteString)] +standardLicenses = + [ ("None" , Nothing ) + , ("BSD3" , Just $(embedFile "resources/licenses/BSD3" )) + , ("LGPL3" , Just $(embedFile "resources/licenses/LGPL3" )) + , ("LGPL2" , Just $(embedFile "resources/licenses/LGPL2" )) + , ("MIT" , Just $(embedFile "resources/licenses/MIT" )) + , ("Apache" , Just $(embedFile "resources/licenses/Apache" )) + , ("GPLv2" , Just $(embedFile "resources/licenses/GPLv2" )) + , ("GPLv3" , Just $(embedFile "resources/licenses/GPLv3" )) + ] + +defaultProjectVersion :: Version +defaultProjectVersion = Version 1 0 0 + +defaultElmVersion :: Text +defaultElmVersion = "0.15.0 <= v < 0.16.0" + +availableLicenses :: [Text] +availableLicenses = fst $ unzip standardLicenses + +elmConfigName :: FilePath +elmConfigName = "elm-package.json" + + type Result = Either Text () @@ -56,6 +96,7 @@ , pkgDependencies :: Aeson.Value , pkgExposedModules :: [Text] , pkgElmVersion :: Text + , pkgSourceDirs :: [Text] } @@ -68,95 +109,173 @@ , ("dependencies" .=) . pkgDependencies , ("exposed-modules" .=) . pkgExposedModules , ("elm-version" .=) . pkgElmVersion + , ("source-directories".=). pkgSourceDirs ] instance Show Version where - showsPrec p (Version ma mi fi) = + showsPrec _ (Version ma mi fi) = shows ma . showChar '.' . shows mi . showChar '.' . shows fi -standardDirectories = - [ "elm-stuff" ] +versionFromString :: Text -> Version +versionFromString s + | length sp /= 3 = error "Parse failed" -- I'm so sorry + | otherwise = Version ma mi fi + where + sp@[ma,mi,fi] = map (read.unpack) (splitOn "." s) :: [Int] -standardFiles = - [ ("README.md", Nothing) - , ("LICENSE", Nothing) - ] +emptyDecisions :: UserDecisions +emptyDecisions = + Default { summary = "" + , repository = "" + , version = Version 0 0 0 + , license = "" + , sourceFolder = "" + , projectName = "" + , elmVersion = "" + } -standardSourceFiles = - [ ("Main.elm", Just $(embedFile "resources/Main.elm")) ] +makePackage :: UserDecisions -> ElmPackage +makePackage = ElmPackage + <$> version + <*> summary + <*> repository + <*> license + <*> const (object []) + <*> const [] + <*> elmVersion + <*> (:[]) . pack . sourceFolder -standardLicenses = - [ ("None", ByteString.empty) - , ("BSD3", $(embedFile "resources/licenses/BSD3")) - , ("LGPL3", $(embedFile "resources/licenses/LGPL3")) - , ("LGPL2", $(embedFile "resources/licenses/LGPL2")) - , ("MIT", $(embedFile "resources/licenses/MIT")) - , ("Apache", $(embedFile "resources/licenses/Apache")) - , ("GPLv2", $(embedFile "resources/licenses/GPLv2")) - , ("GPLv3", $(embedFile "resources/licenses/GPLv3")) - ] :: [(Text, ByteString.ByteString)] +enumerate :: Int -> [a] -> [(Int,a)] +enumerate from l = zip [from..(length l)] l -defaultProjectVersion = Version 1 0 0 +getEither :: Read a => a -> IO a +getEither = + catch readLn . handler + where + handler :: a -> IOException -> IO a + handler = const . return -defaultElmVersion = "0.15.0 <= v < 0.16.0" +askChoices :: Text -> Int -> [Text] -> IO Text +askChoices = + ((fmap <$> (!!) <*>) .) . askChoices' -defaultLicenses = fst $ unzip standardLicenses +askChoices' :: Text -> Int -> [Text] -> IO Int +askChoices' message selected choices = + putStrLn message >> + ask out + where + (l1, selectedElem : l2tail) = splitAt selected choices + out = + intercalate + "\n" + (normFormat 1 l1 + ++ (selectedFormat selected selectedElem : normFormat (selected + 1) l2tail)) -sourceFolders = - [ "src" ] + enumF = flip append " ) " . pack . show + enumFn = append " " . enumF + enumFs = append " * " . enumF + normFormat = (map (uncurry append . Arrow.first enumFn) .) . enumerate + selectedFormat x y = (flip append y . enumFs) x + ask = + (>>) + <$> putStrLn + <*> (\a -> + getEither selected >>= + (bool + (putStrLn "invalid choice, please choose again" >> + ask a) + <$> return + <*> (<= length choices))) -elmConfigName = "elm-package.json" :: FilePath +askChoicesWithOther :: Text -> Int -> (Text -> Bool) -> [Text] -> IO Text +askChoicesWithOther m s verifier = + (>>=) + <$> askChoices' m s . (++ ["other (specify)"]) + <*> ((\a -> (<*>) (flip bool getAlternative + <$> return . a) + . (==) ) + <$> (!!) + <*> length) -makePackage :: UserDecisions -> ElmPackage -makePackage = pure ElmPackage - <*> version - <*> summary - <*> repository - <*> license - <*> const (object []) - <*> const [] - <*> elmVersion + where + getAlternative = + putStrLn "please enter an alternative" >> + getLine >>= + (bool + (putStrLn "Invalid input, plese enter again" >> + getAlternative) + <$> return + <*> verifier) +exists :: FilePath -> IO Bool +exists = + (>>=) + <$> doesFileExist + <*> (flip bool + (return True) + . doesDirectoryExist) -emptyDecisions :: UserDecisions -emptyDecisions = - Default { summary = "" - , repository = "" - , version = Version 1 0 0 - , license = "" - , sourceFolder = "src" - , projectName = "" - , elmVersion = defaultElmVersion - } +getCmdArgs :: IO CmdArgs +getCmdArgs = + fmap CmdArgs + (getArgs >>= + (\args -> + case args of + [] -> getCurrentDirectory + [x] -> makeAbsolute x + _ -> error "Too many arguments")) -- I'm so sorry + +verifyWD :: FilePath -> IO FilePath +verifyWD wd = + doesFileExist wd >>= + bool + (doesDirectoryExist wd >>= + bool + (putStrLn "the chosen directory does not exist yet, shall I create it? [y/n]" + >> getResp >>= + bool + (error "the chosen directory does not exist") -- I'm so sorry + makeDirs + >> return wd) + (return wd)) + (error "The chosen directory is a file") -- I'm so sorry + + where + getResp :: IO Bool + getResp = flip elem ["y", "yes"] <$> getLine + + makeDirs = createDirectoryIfMissing True wd + + getUserDecisions :: FilePath -> IO UserDecisions getUserDecisions wd = - pure Default - <*> askChoicesWithOther + Default + <$> askChoicesWithOther "project name?" 0 (const True) [pack $ takeBaseName wd] <*> fmap - ((wd ) . unpack) + (unpack) (askChoicesWithOther "choose a source folder name" 0 (isValid . unpack) -- filepath path verifier - (map pack sourceFolders)) + (map pack standardSourceFolders)) <*> fmap versionFromString (askChoicesWithOther @@ -170,7 +289,7 @@ "choose a license" 0 (const True) - defaultLicenses + availableLicenses <*> askChoicesWithOther "select the elm-version" 0 @@ -178,101 +297,6 @@ [defaultElmVersion] -enumerate :: Int -> [a] -> [(Int,a)] -enumerate from l = zip [from..(length l)] l - - -splitL :: Eq a => a -> [a] -> [[a]] -splitL _ [] = [] -splitL se l = reverse $ foldl (helper se) [[]] l - where - helper :: Eq a => a -> [[a]] -> a -> [[a]] - helper se [] e = helper se [[]] e - helper se acc@(x:xs) e - | se == e = []:acc - | otherwise = (e:x):xs - - -versionFromString :: Text -> Version -versionFromString s - | length sp /= 3 = error "Parse failed" -- I'm so sorry - | otherwise = Version ma mi fi - where - sp@[ma,mi,fi] = map (read.unpack) (splitOn "." s) :: [Int] - - - -askChoices :: Text -> Int -> [Text] -> IO Text -askChoices m s l = askChoices' m s l >>= (\i -> return $ l !! i) - - -getEither :: Read a => a -> IO a -getEither x = - Control.Exception.catch readLn (handler x) - where - handler :: a -> IOException -> IO a - handler = const . return - - -askChoices' :: Text -> Int -> [Text] -> IO Int -askChoices' message selected choices = do - putStrLn message - ask out - - where - (l1, selectedElem : l2tail) = splitAt selected choices - out = - intercalate - "\n" - (normFormat 1 l1 - ++ (selectedFormat selected selectedElem : normFormat (selected + 1) l2tail)) - - enumF x = append (pack $ show x) " ) " - enumFn = append " " . enumF - enumFs = append " * " . enumF - normFormat f = map (uncurry append . Arrow.first enumFn) . enumerate f - selectedFormat x y = (flip append y . enumFs) x - - ask out = do - putStrLn out - -- apparently using putStr here doe not print the full string but - -- omits the last line ... buffering? - i <- getEither selected - - if i <= length choices then - return i - else do - putStrLn "invalid choice, please choose again" - ask out - - -askChoicesWithOther :: Text -> Int -> (Text -> Bool) -> [Text] -> IO Text -askChoicesWithOther m s verifier l = do - i <- askChoices' m s (l ++ ["other (specify)"]) - if i == length l then - getAlternative - else - return $ l !! i - - where - getAlternative = do - putStrLn "please enter an alternative" - - s <- getLine - if verifier s then - return s - else - putStrLn "Invalid input, plese enter again" >> - getAlternative - - -exists :: FilePath -> IO Bool -exists f = do - isF <- doesFileExist f - isDir <- doesDirectoryExist f - return $ isF || isDir - - mkFiles :: [(FilePath, Maybe ByteString.ByteString)] -> IO [Result] mkFiles = mapM (uncurry mkFile) @@ -282,31 +306,32 @@ bool (withFile name - System.IO.WriteMode - (\h -> maybe (return ()) (ByteString.hPut h) defaultFile) + WriteMode + (flip (maybe (return ())) defaultFile . ByteString.hPut) >> return (Right ())) (return $ Left $ "file " `append` pack name `append` " already exists") mkSourceFiles :: FilePath -> IO [Result] -mkSourceFiles sourceFolder = - mkFiles $ map - (Arrow.first (sourceFolder )) - standardSourceFiles +mkSourceFiles = + mkFiles . flip map standardSourceFiles . Arrow.first . () mkDirs :: FilePath -> [FilePath] -> IO () -mkDirs wd = mapM_ (createDirectoryIfMissing True . (wd )) +mkDirs = mapM_ . (createDirectoryIfMissing True .) . () writeConf :: FilePath -> UserDecisions -> IO () -writeConf wd dec = +writeConf wd = withFile (wd elmConfigName) WriteMode - (flip LBS.hPut $ encodePretty $ makePackage dec) + . flip LBS.hPut . encodePretty . makePackage +flattenMaybe :: Maybe (Maybe a) -> Maybe a +flattenMaybe = fromMaybe Nothing + putLicense :: FilePath -> Text -> IO Result putLicense wd = maybe @@ -317,42 +342,7 @@ (wd "LICENSE") WriteMode . flip ByteString.hPut) - . flip lookup standardLicenses - - -getCmdArgs :: IO CmdArgs -getCmdArgs = - fmap CmdArgs - (getArgs >>= - (\args -> - case args of - [] -> getCurrentDirectory - [x] -> makeAbsolute x - _ -> error "Too many arguments")) -- I'm so sorry - - - -verifyWD :: FilePath -> IO FilePath -verifyWD wd = - doesFileExist wd >>= - bool - (doesDirectoryExist wd >>= - bool - (putStrLn "the chosen directory does not exist yet, shall I create it? [y/n]" - >> getResp >>= - (bool - (error "the chosen directory does not exist") -- I'm so sorry - makeDirs) - >> return wd) - (return wd)) - (error "The chosen directory is a file") -- I'm so sorry - - where - getResp :: IO Bool - getResp = fmap (`elem` ["y", "yes"]) getLine - - makeDirs = createDirectoryIfMissing True wd - + . flattenMaybe . flip lookup standardLicenses main :: IO () @@ -377,7 +367,7 @@ writeConf wd decisions -- write the choosen license - putLicense wd (license decisions) + _ <- putLicense wd (license decisions) -- report all errors mapM_ (either putStrLn return) (resStatic ++ resSource)