diff --git a/bin/HsfilesFromDirectory.hs b/bin/HsfilesFromDirectory.hs new file mode 100644 --- /dev/null +++ b/bin/HsfilesFromDirectory.hs @@ -0,0 +1,14 @@ +import qualified Data.Text.IO as Text +import Hscaffold +import System.Environment + +main :: IO () +main = do + as <- getArgs + case as of + (fp:_) -> go fp + [] -> error "Usage: hsfiles-from-directory " + where + go fp = do + ws <- hscaffoldFromDirectory fp + Text.putStr $ toHsfiles (tell ws) diff --git a/hscaffold.cabal b/hscaffold.cabal --- a/hscaffold.cabal +++ b/hscaffold.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: hscaffold -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Very simple file/directory structure scaffolding writer monad EDSL description: See our README on GitHub at homepage: https://github.com/yamadapc/hscaffold#readme @@ -33,14 +33,37 @@ , directory , filepath , unix + , regex-compat exposed-modules: Hscaffold - other-modules: - Paths_hscaffold + Hscaffold.EDSL + Hscaffold.Generator.Directory + Hscaffold.Generator.Hsfiles + Hscaffold.Interpreter.Common + Hscaffold.Interpreter.Haskell + Hscaffold.Interpreter.Hsfiles + Hscaffold.Interpreter.IO + Hscaffold.Types hs-source-dirs: src default-language: Haskell2010 +executable hsfiles-from-directory + main-is: HsfilesFromDirectory.hs + hs-source-dirs: + bin + build-depends: + base >=4.8 && <4.9 + , text + , mtl + , transformers + , directory + , filepath + , unix + , regex-compat + , hscaffold + default-language: Haskell2010 + test-suite hspec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -54,9 +77,11 @@ , directory , filepath , unix + , regex-compat , hspec , hscaffold , QuickCheck + , temporary other-modules: HscaffoldSpec SanitySpec diff --git a/src/Hscaffold.hs b/src/Hscaffold.hs --- a/src/Hscaffold.hs +++ b/src/Hscaffold.hs @@ -1,15 +1,28 @@ -- module: Hscaffold -- author: Pedro Tacla Yamada -- synopsis: Very simple file/directory structure scaffolding writer monad EDSL -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} module Hscaffold ( -- * Running Hscaffold runHscaffold + -- * Convert Hscaffold to HSFILES (@stack templates@) + , toHsfiles + , writeToHsfiles + -- * Convert HSFILES to Hscaffold + , fromHsfiles + , fromHsfilesW + , readHsfiles + + -- * Convert a directory to Hscaffold + , hscaffoldFromDirectory + -- * Compile Hscaffold to Haskell code + , hscaffoldToHaskell + + -- ** Finer grained runners , runAction , runWriter , runWriterT @@ -30,12 +43,19 @@ , Permissions(..) -- * Types + , ScaffoldMonadT + , ScaffoldMonadIO , ScaffoldActionType(..) , ScaffoldAction , ScaffoldActionV + , ScaffoldMonadET + -- * Helpers + , runHscaffoldIO + , mkActionPath + -- * Re-exports - , module Data.Text + , Text , module Control.Monad.IO.Class , module Control.Monad.Writer , module System.Directory @@ -43,162 +63,18 @@ ) where -import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Writer -import Data.Text (Text) -import qualified Data.Text -import qualified Data.Text.IO as Text +import Data.Text (Text) import System.Directory -- TODO - Disable this on Windows import System.FilePath -import System.Posix.Files - --- | Run the scaffolding writer on the IO monad with no extensions --- --- @ --- runHscaffold "." $ do --- file "./.gitignore" (Text.unlines [ ".stack-work" --- , "stuff" --- , "here" --- ]) --- directory "./src" $ do --- file "./Main.hs" "main = putStrLn \\"Hello World\\"" --- file "./Other.hs" "other = putStrLn \\"Hello You\\"" --- @ -runHscaffold :: FilePath -> WriterT ScaffoldActionV IO a -> IO a -runHscaffold root w = do - (o, ws) <- runWriterT w - mapM_ (runAction root) ws - return o - --- | Run a single scaffolding action on the IO monad with no extensions -runAction :: FilePath -> ScaffoldActionType () -> IO () -runAction root (SetPermissions perms fp) = - setPermissions fp perms -runAction root (Link fp1 fp2) = - createSymbolicLink fp1 fp2 -runAction root (File fp txt) = - Text.writeFile (root fp) txt -runAction root (Directory fp nested) = do - createDirectoryIfMissing True (root fp) - mapM_ (runAction (root fp)) nested -runAction root (Copy fp1 fp2) = do - let fp1' = makeAbsolute fp1 - fp2' = makeAbsolute fp2 - copyFile fp1' fp2' - where - makeAbsolute fp = if isAbsolute fp then fp else root fp - --- | Accumulator for actions -type ScaffoldAction e = [ScaffoldActionType e] - --- | Accumulator for actions set with void extension -type ScaffoldActionV = ScaffoldAction () - --- | Type of actions scaffolding can make, 'ScaffoldActionTypeExtension' is open --- for extension through other data-types -data ScaffoldActionType e - = File FilePath Text - | Link FilePath FilePath - | Directory FilePath (ScaffoldAction e) - | SetPermissions Permissions FilePath - | Copy FilePath FilePath - | ScaffoldActionTypeExtension e - deriving(Show, Eq, Ord) - --- | Create a directory with the nested contents -directory - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> WriterT (ScaffoldAction e) m b - -> m b -directory fp nested = do - (x, nested') <- runWriterT nested - tell [Directory fp nested'] - return x - --- | Create a directory with the nested contents and permissions -directoryWith - :: MonadWriter (ScaffoldAction e) m - => Permissions - -> FilePath - -> WriterT (ScaffoldAction e) m b - -> m b -directoryWith perms fp nested = do - x <- directory fp nested - tell [SetPermissions perms fp] - return x - --- | Create a file with the given contents -file - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> Text - -> m () -file fp txt = tell [File fp txt] - --- | Create a file with the given contents and permissions -fileWith - :: MonadWriter (ScaffoldAction e) m - => Permissions - -> FilePath - -> Text - -> m () -fileWith perms fp txt = do - file fp txt - tell [SetPermissions perms fp] - --- | Set permissions on a filepath -permissions - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> Permissions - -> m () -permissions fp perms = tell [SetPermissions perms fp] - --- | Create a symbolic link between two filepaths -link - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> FilePath - -> m () -link fp1 fp2 = tell [Link fp1 fp2] - --- | Write the empty string to a file -touch - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> m () -touch fp = file fp "" - --- | Write the empty string to a file with given permissions -touchWith - :: MonadWriter (ScaffoldAction e) m - => Permissions - -> FilePath - -> m () -touchWith perms fp = fileWith perms fp "" - --- | Copy a file from A to B --- --- Non-absolute paths are treated relative to the *current* root, nested blocks --- change the root -copy - :: MonadWriter (ScaffoldAction e) m - => FilePath - -> FilePath - -> m () -copy fp1 fp2 = tell [Copy fp1 fp2] - --- | Copy a file from A to B and set permissions on B, see 'copy' -copyWith - :: MonadWriter (ScaffoldAction e) m - => Permissions - -> FilePath - -> FilePath - -> m () -copyWith perms fp1 fp2 = do - copy fp1 fp2 - permissions fp2 perms +import Hscaffold.EDSL +import Hscaffold.Generator.Directory +import Hscaffold.Generator.Hsfiles +import Hscaffold.Interpreter.Common +import Hscaffold.Interpreter.Haskell +import Hscaffold.Interpreter.Hsfiles +import Hscaffold.Interpreter.IO +import Hscaffold.Types diff --git a/src/Hscaffold/EDSL.hs b/src/Hscaffold/EDSL.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/EDSL.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Hscaffold.EDSL + where + +import Control.Monad.Writer +import Data.Text (Text) +import System.Directory + +import Hscaffold.Types + +-- | Create a directory with the nested contents +directory + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> WriterT (ScaffoldAction e) m b + -> m b +directory fp nested = do + (x, nested') <- runWriterT nested + tell [Directory fp nested'] + return x + +-- | Create a directory with the nested contents and permissions +directoryWith + :: MonadWriter (ScaffoldAction e) m + => Permissions + -> FilePath + -> WriterT (ScaffoldAction e) m b + -> m b +directoryWith perms fp nested = do + x <- directory fp nested + tell [SetPermissions perms fp] + return x + +-- | Create a file with the given contents +file + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> Text + -> m () +file fp txt = tell [File fp txt] + +-- | Create a file with the given contents and permissions +fileWith + :: MonadWriter (ScaffoldAction e) m + => Permissions + -> FilePath + -> Text + -> m () +fileWith perms fp txt = do + file fp txt + tell [SetPermissions perms fp] + +-- | Set permissions on a filepath +permissions + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> Permissions + -> m () +permissions fp perms = tell [SetPermissions perms fp] + +-- | Create a symbolic link between two filepaths +link + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> FilePath + -> m () +link fp1 fp2 = tell [Link fp1 fp2] + +-- | Write the empty string to a file +touch + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> m () +touch fp = file fp "" + +-- | Write the empty string to a file with given permissions +touchWith + :: MonadWriter (ScaffoldAction e) m + => Permissions + -> FilePath + -> m () +touchWith perms fp = fileWith perms fp "" + +-- | Copy a file from A to B +-- +-- Non-absolute paths are treated relative to the *current* root, nested blocks +-- change the root +copy + :: MonadWriter (ScaffoldAction e) m + => FilePath + -> FilePath + -> m () +copy fp1 fp2 = tell [Copy fp1 fp2] + +-- | Copy a file from A to B and set permissions on B, see 'copy' +copyWith + :: MonadWriter (ScaffoldAction e) m + => Permissions + -> FilePath + -> FilePath + -> m () +copyWith perms fp1 fp2 = do + copy fp1 fp2 + permissions fp2 perms diff --git a/src/Hscaffold/Generator/Directory.hs b/src/Hscaffold/Generator/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Generator/Directory.hs @@ -0,0 +1,45 @@ +module Hscaffold.Generator.Directory + where + +import Data.List +import qualified Data.Text.IO as Text +import System.Directory +import System.FilePath + +import Hscaffold.Types + +-- | Converts a directory to scaffold actions +hscaffoldFromDirectory :: FilePath -> IO (ScaffoldAction e) +hscaffoldFromDirectory = + hscaffoldFromDirectoryWith (filter (not . ("." `isPrefixOf`))) + +-- | Converts a directory to scaffold actions with a custom filter function. By +-- default we ignore directories starting with @.@ +hscaffoldFromDirectoryWith + :: ([FilePath] -> [FilePath]) -> FilePath -> IO (ScaffoldAction e) +hscaffoldFromDirectoryWith = hscaffoldFromDirectoryWith' False + +hscaffoldFromDirectoryWith' + :: Traversable t => + Bool + -> ([FilePath] -> t FilePath) + -> FilePath + -> IO [ScaffoldActionType e] +hscaffoldFromDirectoryWith' isRecur p root = do + ls <- p <$> getDirectoryContents root + concat <$> mapM classify ls + where + fromFile fp' fp = do + txt <- Text.readFile fp' + return [ File (normalise fp) txt ] + fromDir = + hscaffoldFromDirectoryWith' True p + classify fp = do + let fp' = root fp + isfl <- doesFileExist fp' + isdir <- doesDirectoryExist fp' + if isfl + then fromFile fp' (if isRecur then fp' else fp) + else if isdir + then fromDir fp' + else return [] diff --git a/src/Hscaffold/Generator/Hsfiles.hs b/src/Hscaffold/Generator/Hsfiles.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Generator/Hsfiles.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Hscaffold.Generator.Hsfiles + where + +import Control.Arrow +import Control.Monad.Writer +import qualified Data.Text as Text +-- TODO - Disable this on Windows +import System.FilePath +import Text.Regex + +import Hscaffold.Types + +-- | Converts hsfiles to hscaffold actions +fromHsfiles :: String -> ScaffoldAction e +fromHsfiles h = + let (_, r) = foldr helper ("", []) matches + in r + where + helper (Just (fp:_), _) (lacc, current) = + ( "" + , File (normalise fp) lacc:current + ) + helper (_, l) (lacc, current) = + ( Text.stripEnd (l <> "\n" <> lacc) + , current + ) + re = mkRegex "^{-# START_FILE (.+) #-}( +)?$" + matches = map (matchRegex re &&& Text.pack) (lines h) + +-- | Converts hsfiles to a hscaffold monad +fromHsfilesW :: MonadWriter (ScaffoldAction e) m => String -> m () +fromHsfilesW h = tell (fromHsfiles h) + +readHsfiles :: FilePath -> IO (ScaffoldAction e) +readHsfiles fp = fromHsfiles <$> readFile fp diff --git a/src/Hscaffold/Interpreter/Common.hs b/src/Hscaffold/Interpreter/Common.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Interpreter/Common.hs @@ -0,0 +1,14 @@ +module Hscaffold.Interpreter.Common + where + +import System.FilePath + +-- | Very simple helper, if the second argument is absolute, returns it, +-- otherwise, return it relative to the first argument +mkActionPath + :: FilePath + -- ^ The root + -> FilePath + -- ^ A filepath + -> FilePath +mkActionPath root fp = if isAbsolute fp then fp else root fp diff --git a/src/Hscaffold/Interpreter/Haskell.hs b/src/Hscaffold/Interpreter/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Interpreter/Haskell.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hscaffold.Interpreter.Haskell + where + +import Control.Monad.Writer +import Data.Text (Text) +import qualified Data.Text as Text + +import Hscaffold.Types + +-- | Generates Haskell code from scaffold actions +hscaffoldToHaskell :: Foldable t => t (ScaffoldActionType e) -> Text +hscaffoldToHaskell hs = Text.stripEnd $ + Text.unlines $ + concatMap hscaffoldActionToHaskell hs + +hscaffoldActionToHaskell :: ScaffoldActionType e -> [Text] +hscaffoldActionToHaskell h = case h of + (File fp txt) -> + [ "file " <> Text.pack (show fp <> " " <> show txt) ] + (Directory fp nested) -> + let nestedCode = concatMap hscaffoldActionToHaskell nested + inestedCode = map (" " <>) nestedCode + in [ "directory " <> Text.pack (show fp) <> " $ do" + ] <> inestedCode + (Link fp1 fp2) -> + [ "link " <> Text.pack (show fp1) <> " " + <> Text.pack (show fp2) + ] + (SetPermissions p fp) -> + [ "permissions " <> Text.pack (show fp) + <> " (" <> Text.pack (show p) <> ")" + ] + (Copy fp1 fp2) -> + [ "copy " <> Text.pack (show fp1) + <> " " <> Text.pack (show fp2) + ] + _ -> [] diff --git a/src/Hscaffold/Interpreter/Hsfiles.hs b/src/Hscaffold/Interpreter/Hsfiles.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Interpreter/Hsfiles.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hscaffold.Interpreter.Hsfiles + where + +import Control.Monad.Writer +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import Hscaffold.Types + +import Hscaffold.Interpreter.Common + +-- | Run the scaffolding writer and return an @.hsfiles@ 'Text' to use with +-- @stack-templates@ +toHsfiles :: Writer ScaffoldActionV a -> Text +toHsfiles w = + let (_, ws) = runWriter w + in Text.stripEnd $ Text.unlines $ + concatMap (actionToHsfile ".") ws + +-- | Convert a single scaffolding action to hsfiles +-- +-- Ignores everything but the 'file' directives +actionToHsfile :: FilePath -> ScaffoldActionType e -> [Text] +actionToHsfile root a = case a of + (File fp txt) -> + [ "{-# START_FILE " <> Text.pack (mkActionPath root fp) <> " #-}" ] <> + Text.lines txt + (Directory fp nested) -> concatMap (actionToHsfile (mkActionPath root fp)) nested + _ -> [] + +-- | Shortcut for +-- +-- @ +-- writeToHsfiles = do h <- toHsfiles w; liftIO $ Text.writeFile fp h +-- @ +writeToHsfiles :: MonadIO m => FilePath -> Writer ScaffoldActionV a -> m () +writeToHsfiles fp w = do + let h = toHsfiles w + liftIO $ Text.writeFile fp h diff --git a/src/Hscaffold/Interpreter/IO.hs b/src/Hscaffold/Interpreter/IO.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Interpreter/IO.hs @@ -0,0 +1,52 @@ +module Hscaffold.Interpreter.IO + where + +import Control.Monad.IO.Class +import Control.Monad.Writer +import qualified Data.Text.IO as Text +import System.Directory +-- TODO - Disable this on Windows +import System.Posix.Files + +import Hscaffold.Types + +import Hscaffold.Interpreter.Common + +-- | Run the scaffolding writer on the IO monad with no extensions +-- +-- @ +-- runHscaffold "." $ do +-- file "./.gitignore" (Text.unlines [ ".stack-work" +-- , "stuff" +-- , "here" +-- ]) +-- directory "./src" $ do +-- file "./Main.hs" "main = putStrLn \\"Hello World\\"" +-- file "./Other.hs" "other = putStrLn \\"Hello You\\"" +-- @ +runHscaffold :: MonadIO m => FilePath -> WriterT ScaffoldActionV m a -> m a +runHscaffold root w = do + (o, ws) <- runWriterT w + liftIO $ mapM_ (runAction root) ws + return o + +runHscaffoldIO :: FilePath -> ScaffoldMonadIO a -> IO a +runHscaffoldIO = runHscaffold + +-- | Run a single scaffolding action on the IO monad with no extensions +runAction :: FilePath -> ScaffoldActionType e -> IO () +runAction _ (ScaffoldActionTypeExtension _) = return () +runAction root (SetPermissions perms fp) = + setPermissions (mkActionPath root fp) perms +runAction root (Link fp1 fp2) = + createSymbolicLink (mkActionPath root fp1) (mkActionPath root fp2) +runAction root (File fp txt) = + Text.writeFile (mkActionPath root fp) txt +runAction root (Directory fp nested) = do + createDirectoryIfMissing True (mkActionPath root fp) + mapM_ (runAction (mkActionPath root fp)) nested +runAction root (Copy fp1 fp2) = do + let fp1' = mkActionPath root fp1 + fp2' = mkActionPath root fp2 + copyFile fp1' fp2' + diff --git a/src/Hscaffold/Types.hs b/src/Hscaffold/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hscaffold/Types.hs @@ -0,0 +1,32 @@ +module Hscaffold.Types + where + +import Control.Monad.Writer +import Data.Text (Text) +import System.Directory + +-- | The writer monad transformer for scaffold actions +type ScaffoldMonadT m a = WriterT ScaffoldActionV m a + +-- | The writer monad for scaffold actions, running in IO +type ScaffoldMonadIO a = WriterT ScaffoldActionV IO a + +-- | The writer monad transformer for scaffold actions with an extension +type ScaffoldMonadET e m a = WriterT (ScaffoldAction e) m a + +-- | Accumulator for actions +type ScaffoldAction e = [ScaffoldActionType e] + +-- | Accumulator for actions set with void extension +type ScaffoldActionV = ScaffoldAction () + +-- | Type of actions scaffolding can make, 'ScaffoldActionTypeExtension' is open +-- for extension through other data-types +data ScaffoldActionType e + = File FilePath Text + | Link FilePath FilePath + | Directory FilePath (ScaffoldAction e) + | SetPermissions Permissions FilePath + | Copy FilePath FilePath + | ScaffoldActionTypeExtension e + deriving(Show, Eq, Ord) diff --git a/test/HscaffoldSpec.hs b/test/HscaffoldSpec.hs --- a/test/HscaffoldSpec.hs +++ b/test/HscaffoldSpec.hs @@ -4,50 +4,160 @@ import Control.Exception import Control.Monad +import Data.Maybe +import qualified Data.Text as Text import Hscaffold -import System.Directory +import System.IO.Temp import Test.Hspec +directoryShouldExist dir = do + e <- doesDirectoryExist dir + e `shouldBe` True + +fileShouldExist fp = do + e <- doesFileExist fp + e `shouldBe` True + +fileShouldHaveContents fp txt = do + e <- readFile fp + e `shouldBe` txt + +spec :: Spec spec = do - describe "the writers" $ do + describe "the writers" $ it "create proper instructions for our results" $ do let (_, ws) = runWriter $ do - file "stuff-bang.hs" "" - directory "./something" $ do - file "stuff-here.hs" "" - file "stuff-there.hs" "" + file "stuff-bang.hs" "" + directory "./something" $ do + file "stuff-here.hs" "" + file "stuff-there.hs" "" (ws :: ScaffoldAction ()) `shouldBe` [ File "stuff-bang.hs" "" - , Directory "./something" [ File "stuff-here.hs" "" - , File "stuff-there.hs" "" - ] + , Directory "./something" + [ File "stuff-here.hs" "" + , File "stuff-there.hs" "" + ] ] - describe "the runner" $ do + describe "runHscaffold" $ + it "works without surprises" $ do + withSystemTempDirectory "hscaffold" $ + \tmp -> do + runHscaffold tmp $ do + file "stuff-bang.hs" "" + directory "./something" $ do + file "stuff-here.hs" "" + file "stuff-there.hs" "" + directoryShouldExist (tmp "something") + fileShouldExist (tmp "stuff-bang.hs") + fileShouldExist (tmp "something" "stuff-here.hs") + fileShouldExist (tmp "something" "stuff-there.hs") + + describe "toHsfiles" $ do + it "works without surprises" $ + let h = toHsfiles $ do + file "stuff-bang.hs" "stuff here" + file "other/stuff-bang.hs" "stuff here" + directory "other" $ do + file "other-stuff-bang.hs" "even more stuff here" + in h `shouldBe` Text.stripEnd + (Text.unlines [ "{-# START_FILE ./stuff-bang.hs #-}" + , "stuff here" + , "{-# START_FILE ./other/stuff-bang.hs #-}" + , "stuff here" + , "{-# START_FILE ./other/other-stuff-bang.hs #-}" + , "even more stuff here" + ]) + + describe "fromHsfiles" $ do + it "works without surprises" $ + let h = (init + (unlines + [ "{-# START_FILE ./stuff-bang.hs #-}" + , "stuff here" + , "{-# START_FILE ./other/stuff-bang.hs #-}" + , "stuff here" + , "{-# START_FILE ./other/other-stuff-bang.hs #-}" + , "even more stuff here" + ])) + in (fromHsfiles h :: ScaffoldActionV) `shouldBe` + [ File "stuff-bang.hs" "stuff here" + , File "other/stuff-bang.hs" "stuff here" + , File "other/other-stuff-bang.hs" "even more stuff here" + ] + + it "works without surprises" $ + let h = (init + (unlines + [ "{-# START_FILE ./stuff-bang.hs #-}" + , "stuff here" + , "multiline" + , " ya" + , "{-# START_FILE ./other/stuff-bang.hs #-}" + , "stuff here" + , "" + , "{-# START_FILE ./other/other-stuff-bang.hs #-} " + , "even more stuff here" + , " here too" + ])) + in (fromHsfiles h :: ScaffoldActionV) `shouldBe` + [ File "stuff-bang.hs" "stuff here\nmultiline\n ya" + , File "other/stuff-bang.hs" "stuff here" + , File "other/other-stuff-bang.hs" "even more stuff here\n here too" + ] + + describe "hscaffoldToHaskell" $ do + it "works without surprises" $ + let h = hscaffoldToHaskell $ execWriter $ do + file "stuff-bang.hs" "stuff here" + file "other/stuff-bang.hs" "stuff here" + directory "other" $ do + file "other-stuff-bang.hs" "even more stuff here" + in h `shouldBe` Text.stripEnd + (Text.unlines [ "file \"stuff-bang.hs\" \"stuff here\"" + , "file \"other/stuff-bang.hs\" \"stuff here\"" + , "directory \"other\" $ do" + , " file \"other-stuff-bang.hs\" \"even more stuff here\"" + ]) + + describe "hscaffoldFromDirectory" $ do + it "works without surprises" $ do + h <- hscaffoldFromDirectory "./src" :: IO (ScaffoldActionV) + let ms = mapMaybe (\x -> case x of File fp _ -> Just fp; _ -> Nothing) h + ms `shouldContain` ["Hscaffold.hs"] + + it "ignores git" $ do + h <- hscaffoldFromDirectory "." :: IO (ScaffoldActionV) + let ms = mapMaybe (\x -> case x of File fp _ -> Just fp; _ -> Nothing) h + ms `shouldNotContain` [".git/index"] + ms `shouldContain` ["README.md"] + ms `shouldContain` ["test/Spec.hs"] + + describe "the runner" $ describe "runAction" $ do it "creates files" $ do - void $ (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) - void $ (try $ removeFile "./tmp" :: IO (Either SomeException ())) + void (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) + void (try $ removeFile "./tmp" :: IO (Either SomeException ())) runAction "." (File "./tmp" "stuff") ecnts <- try $ readFile "./tmp" :: IO (Either SomeException String) - void $ (try $ removeFile "./tmp" :: IO (Either SomeException ())) + void (try $ removeFile "./tmp" :: IO (Either SomeException ())) let Right cnts = ecnts cnts `shouldBe` "stuff" it "creates directories" $ do - void $ (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) - void $ (try $ removeFile "./tmp" :: IO (Either SomeException ())) + void (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) + void (try $ removeFile "./tmp" :: IO (Either SomeException ())) runAction "." (Directory "./tmp/" []) t <- doesDirectoryExist "./tmp" - void $ (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) + void (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) t `shouldBe` True it "creates directory contents" $ do - void $ (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) - void $ (try $ removeFile "./tmp" :: IO (Either SomeException ())) - runAction "." (Directory "./tmp/" [File "stuff" "here"]) + void (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) + void (try $ removeFile "./tmp" :: IO (Either SomeException ())) + runAction "." (Directory "./tmp/" [ File "stuff" "here" ]) ecnts <- try $ readFile "./tmp/stuff" :: IO (Either SomeException String) - void $ (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) + void (try $ removeDirectoryRecursive "./tmp" :: IO (Either SomeException ())) let Right cnts = ecnts cnts `shouldBe` "here"