1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
--------------------------------------------------------------------------------
module Main
( main
) where
--------------------------------------------------------------------------------
import Control.Arrow (first)
import Control.Monad (forM, forM_)
import Data.Char (isAlphaNum, isNumber)
import Data.List (foldl', intercalate, isPrefixOf)
import Data.Version (Version (..))
import System.Directory (canonicalizePath, copyFile,
doesFileExist,
setPermissions, getPermissions, writable)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath (splitDirectories, (</>))
--------------------------------------------------------------------------------
import Hakyll.Core.Util.File
import Paths_hakyll
--------------------------------------------------------------------------------
import Prelude
--------------------------------------------------------------------------------
main :: IO ()
main = do
progName <- getProgName
args <- getArgs
srcDir <- getDataFileName "example"
files <- getRecursiveContents (const $ return False) srcDir
case args of
-- When the argument begins with hyphens, it's more likely that the user
-- intends to attempt some arguments like ("--help", "-h", "--version", etc.)
-- rather than create directory with that name.
-- If dstDir begins with hyphens, the guard will prevent it from creating
-- directory with that name so we can fall to the second alternative
-- which prints a usage info for user.
[dstDir] | not ("-" `isPrefixOf` dstDir) ->
createFiles False srcDir files dstDir
["-f", dstDir] ->
createFiles True srcDir files dstDir
_ -> do
putStrLn $ "Usage: " ++ progName ++ " [-f] <directory>"
exitFailure
where
createFiles force srcDir files dstDir = do
name <- makeName dstDir
let cabalPath = dstDir </> name ++ ".cabal"
diff <- if force then return []
else existingFiles dstDir (cabalPath : files)
case diff of
[] -> do
forM_ files $ \file -> do
let dst = dstDir </> file
src = srcDir </> file
putStrLn $ "Creating " ++ dst
makeDirectories dst
copyFile src dst
-- On some systems, the source folder may be readonly,
-- and copyFile will therefore create a readonly project...
p <- getPermissions dst
setPermissions dst (p {writable = True})
putStrLn $ "Creating " ++ cabalPath
createCabal cabalPath name
fs -> do
putStrLn $ "The following files will be overwritten:"
mapM_ putStrLn fs
putStrLn $ "Use -f to overwrite them"
exitFailure
existingFiles :: FilePath -> [FilePath] -> IO [FilePath]
existingFiles dstDir files = fmap concat $ forM files $ \file -> do
let dst = dstDir </> file
exists <- doesFileExist dst
return $ if exists then [dst] else []
-- | 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
-- Package name repair code comes from
-- cabal-install.Distribution.Client.Init.Heuristics
repair invalid valid x = case dropWhile (not . isAlphaNum) x of
"" -> repairComponent ""
x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'
in c ++ repairRest r
where repairComponent c | all isNumber c = invalid c
| otherwise = valid c
repairRest = repair id ('-' :)
fallbackName = "site"
safeLast = foldl' (\_ x -> Just x) Nothing
createCabal :: FilePath -> String -> IO ()
createCabal path name =
writeFile path $ 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 -rtsopts -with-rtsopts=-N"
, " default-language: Haskell2010"
]
where
-- Major hakyll version
version' = intercalate "." . take 2 . map show $ versionBranch version
|
