diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/ProjectTemplate.hs b/Text/ProjectTemplate.hs new file mode 100644 --- /dev/null +++ b/Text/ProjectTemplate.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.ProjectTemplate + ( -- * Create a template + createTemplate + -- * Unpack a template + , unpackTemplate + -- ** Receivers + , FileReceiver + , receiveMem + , receiveFS + -- * Exceptions + , ProjectTemplateException (..) + ) where + +import ClassyPrelude.Conduit +import Control.Monad.Writer (MonadWriter, tell) +import qualified Data.ByteString.Base64 as B64 +import Data.Functor.Identity (runIdentity) +import Data.Typeable (Typeable) +import Filesystem (createTree) +import Filesystem.Path.CurrentOS (directory, encode, fromText) + +-- | Create a template file from a stream of file/contents combinations. +-- +-- Since 0.1.0 +createTemplate + :: Monad m + => GInfConduit (FilePath, m ByteString) m ByteString +createTemplate = awaitForever $ \(fp, getBS) -> do + bs <- lift getBS + case runIdentity $ runExceptionT $ yield bs $$ decodeUtf8 =$ 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 + yield "\n" + +-- | Unpack a template to some destination. Destination is provided by the +-- first argument. +-- +-- The second argument allows you to modify the incoming stream, usually to +-- replace variables. For example, to replace PROJECTNAME with myproject, you +-- could use: +-- +-- > Data.Text.replace "PROJECTNAME" "myproject" +-- +-- Note that this will affect both file contents and file names. +-- +-- Since 0.1.0 +unpackTemplate + :: MonadThrow m + => (FilePath -> Sink ByteString m ()) -- ^ receive individual files + -> (Text -> Text) -- ^ fix each input line, good for variables + -> Sink ByteString m () +unpackTemplate perFile fixLine = + decodeUtf8 =$ lines =$ map fixLine =$ start + where + start = + await >>= maybe (return ()) go + where + go t = + case getFileName t of + Nothing -> lift $ monadThrow $ InvalidInput t + Just (fp', isBinary) -> do + let src + | isBinary = binaryLoop + | otherwise = textLoop True + src =$ perFile (fromText fp') + start + + binaryLoop = do + await >>= maybe (lift $ monadThrow BinaryLoopNeedsOneLine) go + where + go = yield . B64.decodeLenient . encodeUtf8 + textLoop isFirst = + await >>= maybe (return ()) go + where + go t = + case getFileName t of + Just{} -> leftover t + Nothing -> do + unless isFirst $ yield "\n" + yield $ encodeUtf8 t + textLoop False + + getFileName t = + case words t of + ["{-#", "START_FILE", fn, "#-}"] -> Just (fn, False) + ["{-#", "START_FILE", "BASE64", fn, "#-}"] -> Just (fn, True) + _ -> Nothing + +-- | The first argument to 'unpackTemplate', specifying how to receive a file. +-- +-- Since 0.1.0 +type FileReceiver m = FilePath -> Sink ByteString m () + +-- | Receive files to the given folder on the filesystem. +-- +-- > unpackTemplate (receiveFS "some-destination") (T.replace "PROJECTNAME" "foo") +-- +-- Since 0.1.0 +receiveFS :: MonadResource m + => FilePath -- ^ root + -> FileReceiver m +receiveFS root rel = do + liftIO $ createTree $ directory fp + writeFile fp + where + fp = root rel + +-- | Receive files to a @Writer@ monad in memory. +-- +-- > execWriter $ runExceptionT_ $ src $$ unpackTemplate receiveMem id +-- +-- Since 0.1.0 +receiveMem :: MonadWriter (Map FilePath LByteString) m + => FileReceiver m +receiveMem fp = do + bss <- consume + lift $ tell $ singleton fp $ fromChunks bss + +-- | Exceptions that can be thrown. +-- +-- Since 0.1.0 +data ProjectTemplateException = InvalidInput Text + | BinaryLoopNeedsOneLine + deriving (Show, Typeable) +instance Exception ProjectTemplateException diff --git a/project-template.cabal b/project-template.cabal new file mode 100644 --- /dev/null +++ b/project-template.cabal @@ -0,0 +1,43 @@ +name: project-template +version: 0.1.0.0 +synopsis: Specify Haskell project templates and generate files +description: See initial blog post for explanation: +homepage: https://github.com/fpco/haskell-ide +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@fpcomplete.com +category: Development +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Text.ProjectTemplate + build-depends: base >= 4 && < 5 + , classy-prelude-conduit >= 0.4 + , base64-bytestring + , system-filepath >= 0.4 + , system-fileio >= 0.3 + , text >= 0.11 + , bytestring >= 0.9 + , transformers >= 0.2 + , mtl >= 2.0 + , resourcet >= 0.4.1 + ghc-options: -Wall + +test-suite test + hs-source-dirs: test + main-is: Spec.hs + other-modules: Text.ProjectTemplateSpec + type: exitcode-stdio-1.0 + build-depends: base + , project-template + , classy-prelude-conduit + , hspec >= 1.3 + , transformers + , QuickCheck + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/fpco/haskell-ide.git diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Text/ProjectTemplateSpec.hs b/test/Text/ProjectTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/ProjectTemplateSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Text.ProjectTemplateSpec where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Text.ProjectTemplate +import ClassyPrelude.Conduit +import Control.Monad.Trans.Writer (execWriter) +import Test.QuickCheck.Arbitrary +import Data.Char (isAlphaNum) + +spec :: Spec +spec = do + describe "create/unpack" $ do + prop "is idempotent" $ \(Helper m) -> + let m' = + execWriter + $ runExceptionT_ + $ mapM_ (yield . second return) (unpack m) + $$ createTemplate + =$ unpackTemplate receiveMem id + m'' = pack $ map (second $ concat . toChunks) $ unpack m' + in if m == m'' then True else error (show m'') + +newtype Helper = Helper (Map FilePath ByteString) + deriving (Show, Eq) + +instance Arbitrary Helper where + arbitrary = + Helper . pack <$> mapM (const $ (pack . def "foo" . filter isAlphaNum *** pack . def (unpack $ asByteString "bar")) <$> arbitrary) [1..10 :: Int] + where + def x y + | null y = x + | otherwise = y