Clean up hakyll-init a little

Closes #325

1 files changed, 39 insertions, 30 deletions

diff --git a/src/Hakyll/Init.hs b/src/Hakyll/Init.hs
index 51ba14b..98b44ec 100644
--- a/src/Hakyll/Init.hs
+++ b/src/Hakyll/Init.hs
@@ -8,12 +8,13 @@ module Main
 import           Control.Arrow         (first)
 import           Control.Monad         (forM_)
 import           Data.Char             (isAlphaNum, isNumber)
+import           Data.List             (foldl')
 import           Data.List             (intercalate)
-import           Data.Version          (Version(..))
-import           System.Directory      (copyFile, canonicalizePath)
+import           Data.Version          (Version (..))
+import           System.Directory      (canonicalizePath, copyFile)
 import           System.Environment    (getArgs, getProgName)
 import           System.Exit           (exitFailure)
-import           System.FilePath       ((</>), splitDirectories)
+import           System.FilePath       (splitDirectories, (</>))
 
 
 --------------------------------------------------------------------------------
@@ -37,38 +38,25 @@ main = do
                 putStrLn $ "Creating " ++ dst
                 makeDirectories dst
                 copyFile src dst
-            -- canonicalizePath is safe because the destination
-            -- directory should exist at this point
-            canonicalizePath dstDir >>= createCabal
+
+            name <- makeName dstDir
+            let cabalPath = dstDir </> name ++ ".cabal"
+            putStrLn $ "Creating " ++ cabalPath
+            createCabal cabalPath name
         _ -> do
             putStrLn $ "Usage: " ++ progName ++ " <directory>"
             exitFailure
 
-
-createCabal :: FilePath -> IO ()
-createCabal dstDir = do
-        putStrLn $ "Creating " ++ name ++ ".cabal"
-        writeFile (dstDir </> name ++ ".cabal") $ unlines [
-            "name:               " ++ name
-          , "version:            0.1.0.0"
-          , "build-type:         Simple"
-          , "cabal-version:      >= 1.10"
-          , ""
-          , "executable site"
-          , "  main-is:          site.hs"
-          , "  build-depends:    base == 4.*"
-          , "                  , hakyll == " ++ version' ++ ".*"
-          , "  ghc-options:      -threaded"
-          , "  default-language: Haskell2010"
-          ]
+-- | Figure out a good cabal package name from the given (existing) directory
+-- name
+makeName :: FilePath -> IO String
+makeName dstDir = do
+    canonical <- canonicalizePath dstDir
+    return $ case safeLast (splitDirectories canonical) of
+        Nothing  -> fallbackName
+        Just "/" -> fallbackName
+        Just x   -> repair (fallbackName ++) id x
   where
-    -- Major hakyll version
-    version' = intercalate "." . take 2 . map show $ versionBranch version
-    -- last is safe here as the path is canonicalised and "/" is just
-    -- a very rare but possible corner case
-    name = case last (splitDirectories  dstDir) of
-        "/" -> fallbackName
-        x   -> repair (fallbackName ++) id x
     -- Package name repair code comes from
     -- cabal-install.Distribution.Client.Init.Heuristics
     repair invalid valid x = case dropWhile (not . isAlphaNum) x of
@@ -79,3 +67,24 @@ createCabal dstDir = do
                               | otherwise = valid c
     repairRest = repair id ('-' :)
     fallbackName = "site"
+
+    safeLast = foldl' (\_ x -> Just x) Nothing
+
+createCabal :: FilePath -> String -> IO ()
+createCabal path name = do
+    writeFile (path ++ ".cabal") $ unlines [
+        "name:               " ++ name
+      , "version:            0.1.0.0"
+      , "build-type:         Simple"
+      , "cabal-version:      >= 1.10"
+      , ""
+      , "executable site"
+      , "  main-is:          site.hs"
+      , "  build-depends:    base == 4.*"
+      , "                  , hakyll == " ++ version' ++ ".*"
+      , "  ghc-options:      -threaded"
+      , "  default-language: Haskell2010"
+      ]
+  where
+    -- Major hakyll version
+    version' = intercalate "." . take 2 . map show $ versionBranch version