Listing files into a hsfiles file is now simpler
This commit is contained in:
parent
5a53777615
commit
ec8edc92f1
24
yesod-bin/HsFile.hs
Normal file
24
yesod-bin/HsFile.hs
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
{-# LANGUAGE TupleSections, OverloadedStrings #-}
|
||||||
|
module HsFile (mkHsFile) where
|
||||||
|
import Text.ProjectTemplate (createTemplate)
|
||||||
|
import Data.Conduit
|
||||||
|
( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield )
|
||||||
|
import Data.Conduit.Filesystem (traverse, sourceFile)
|
||||||
|
import Prelude hiding (FilePath)
|
||||||
|
import Filesystem.Path ( FilePath )
|
||||||
|
import Filesystem.Path.CurrentOS ( encodeString )
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
|
mkHsFile :: IO ()
|
||||||
|
mkHsFile = runResourceT $ traverse False "."
|
||||||
|
$$ readIt
|
||||||
|
=$ createTemplate
|
||||||
|
=$ awaitForever (liftIO . BS.putStr)
|
||||||
|
|
||||||
|
-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
|
||||||
|
readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) ()
|
||||||
|
readIt = awaitForever $ \i -> do bs <- liftIO $ BS.readFile (encodeString i)
|
||||||
|
yield (i, return bs)
|
||||||
|
|
||||||
|
|
||||||
@ -22,6 +22,7 @@ import Options.Applicative.Types (ReadM (ReadM))
|
|||||||
|
|
||||||
#ifndef WINDOWS
|
#ifndef WINDOWS
|
||||||
import Build (touch)
|
import Build (touch)
|
||||||
|
import HsFile (mkHsFile)
|
||||||
|
|
||||||
touch' :: IO ()
|
touch' :: IO ()
|
||||||
touch' = touch
|
touch' = touch
|
||||||
@ -45,7 +46,7 @@ data Options = Options
|
|||||||
}
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data Command = Init { _initBare :: Bool }
|
data Command = Init { _initBare, _initHsFiles :: Bool }
|
||||||
| Configure
|
| Configure
|
||||||
| Build { buildExtraArgs :: [String] }
|
| Build { buildExtraArgs :: [String] }
|
||||||
| Touch
|
| Touch
|
||||||
@ -92,7 +93,7 @@ main = do
|
|||||||
] optParser'
|
] optParser'
|
||||||
let cabal xs = rawSystem' (cabalCommand o) xs
|
let cabal xs = rawSystem' (cabalCommand o) xs
|
||||||
case optCommand o of
|
case optCommand o of
|
||||||
Init bare -> scaffold bare
|
Init bare hsfiles -> if hsfiles then mkHsFile else scaffold bare
|
||||||
Configure -> cabal ["configure"]
|
Configure -> cabal ["configure"]
|
||||||
Build es -> touch' >> cabal ("build":es)
|
Build es -> touch' >> cabal ("build":es)
|
||||||
Touch -> touch'
|
Touch -> touch'
|
||||||
@ -113,7 +114,8 @@ optParser = Options
|
|||||||
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
|
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
|
||||||
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
|
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
|
||||||
<*> subparser ( command "init"
|
<*> subparser ( command "init"
|
||||||
(info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
|
(info (Init <$> (switch (long "bare" <> help "Create files in current folder"))
|
||||||
|
<*> (switch (long "hsfiles" <> help "Create a hsfiles file for the current folder")))
|
||||||
(progDesc "Scaffold a new site"))
|
(progDesc "Scaffold a new site"))
|
||||||
<> command "configure" (info (pure Configure)
|
<> command "configure" (info (pure Configure)
|
||||||
(progDesc "Configure a project for building"))
|
(progDesc "Configure a project for building"))
|
||||||
|
|||||||
@ -87,6 +87,7 @@ executable yesod
|
|||||||
, transformers
|
, transformers
|
||||||
, warp >= 1.3.7.5
|
, warp >= 1.3.7.5
|
||||||
, wai >= 1.4
|
, wai >= 1.4
|
||||||
|
, filesystem-conduit >= 1.0 && < 2.0
|
||||||
|
|
||||||
ghc-options: -Wall -threaded
|
ghc-options: -Wall -threaded
|
||||||
main-is: main.hs
|
main-is: main.hs
|
||||||
@ -98,6 +99,7 @@ executable yesod
|
|||||||
AddHandler
|
AddHandler
|
||||||
Paths_yesod_bin
|
Paths_yesod_bin
|
||||||
Options
|
Options
|
||||||
|
HsFile
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user