Switch to project-template

This commit is contained in:
Michael Snoyman 2012-11-07 10:59:18 +02:00
parent a486a2f71d
commit c3c0d0eaed
3 changed files with 5 additions and 98 deletions

View File

@ -1,93 +0,0 @@
-- FIXME: Depend on the not-yet-released project-template library.
{-# LANGUAGE OverloadedStrings #-}
module MultiFile where
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (runExceptionT)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64 as B64
import Data.Conduit (Conduit, MonadResource, Sink,
await, awaitForever, leftover,
yield, ($$), (=$))
import Data.Conduit.Binary (sinkFile)
import Data.Conduit.List (sinkNull)
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import Data.Functor.Identity (runIdentity)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Filesystem (createTree)
import Filesystem.Path.CurrentOS (FilePath, directory, encode,
encodeString, fromText, (</>))
import Prelude hiding (FilePath)
unpackMultiFile
:: MonadResource m
=> FilePath -- ^ output folder
-> (Text -> Text) -- ^ fix each input line, good for variables
-> Sink S.ByteString m ()
unpackMultiFile root fixLine =
CT.decode CT.utf8 =$ CT.lines =$ CL.map fixLine =$ start
where
start =
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Nothing -> error $ "Invalid input: " ++ show t
Just (fp', isBinary) -> do
let fp = root </> fromText fp'
liftIO $ createTree $ directory fp
let src
| isBinary = binaryLoop
| otherwise = textLoop
src =$ sinkFile (encodeString fp)
start
binaryLoop = do
await >>= maybe (error "binaryLoop needs 1 line") go
where
go = yield . B64.decodeLenient . encodeUtf8
textLoop =
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Just{} -> leftover t
Nothing -> do
yield $ encodeUtf8 t
yield "\n"
textLoop
getFileName t =
case T.words t of
["{-#", "START_FILE", fn, "#-}"] -> Just (fn, False)
["{-#", "START_FILE", "BASE64", fn, "#-}"] -> Just (fn, True)
_ -> Nothing
createMultiFile
:: MonadIO m
=> FilePath -- ^ folder containing the files
-> Conduit FilePath m S.ByteString -- ^ FilePath is relative to containing folder
createMultiFile root = do
awaitForever handleFile
where
handleFile fp' = do
bs <- liftIO $ S.readFile $ encodeString fp
case runIdentity $ runExceptionT $ yield bs $$ CT.decode CT.utf8 =$ sinkNull of
Left{} -> do
yield "{-# START_FILE BASE64 "
yield $ encode fp'
yield " #-}\n"
yield $ B64.encode bs
yield "\n"
Right{} -> do
yield "{-# START_FILE "
yield $ encode fp'
yield " #-}\n"
yield bs
unless ("\n" `S.isSuffixOf` bs) $ yield "\n"
where
fp = root </> fp'

View File

@ -10,7 +10,7 @@ import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as TLIO
import MultiFile (unpackMultiFile)
import Text.ProjectTemplate (unpackTemplate, receiveFS)
import System.IO
import Text.Shakespeare.Text (renderTextUrl, textFile)
@ -74,8 +74,8 @@ scaffold = do
putStrLn "That's it! I'm creating your files now..."
let sink = unpackMultiFile
(fromString project)
let sink = unpackTemplate
(receiveFS $ fromString project)
(T.replace "PROJECTNAME" (T.pack project))
runResourceT $ yield (backendBS backend) $$ sink

View File

@ -106,11 +106,11 @@ executable yesod
, http-reverse-proxy >= 0.1.0.4
, network
, http-conduit
, project-template >= 0.1
ghc-options: -Wall -threaded
main-is: main.hs
other-modules: MultiFile
Scaffolding.Scaffolder
other-modules: Scaffolding.Scaffolder
Devel
Build
GhcBuild