Commit c2ce5adcf8abae57fc596ab054e7e3f2068e960c - collage

+6

-0

bricoleur/Main.hs less more

	1	module Main where
	2
	3	import qualified Bricoleur
	4
	5	main :: IO ()
	6	main = Bricoleur.getOpts >>= Bricoleur.main

+46

-0

bricoleur.cabal less more

	1	cabal-version: 2.2
	2	name: bricoleur
	3	version: 0.1.0.0
	4	synopsis: A tool for assembling documents out of working, testable code
	5	description:
	6	Bricoleur is a tool for writing documents that include snippets of code
	7	in such a way that the code can be build and examined independently
	8	of the source document.
	9	license: BSD-3-Clause
	10	author: Getty Ritter <gettylefou@gmail.com>
	11	maintainer: Getty Ritter <gettylefou@gmail.com>
	12	copyright: @2018 Getty Ritter
	13	category: Text
	14	build-type: Simple
	15
	16
	17	library
	18	exposed-modules: Bricoleur
	19	, Bricoleur.Config
	20	, Bricoleur.Opts
	21	, Bricoleur.Commands.Test
	22	, Bricoleur.Commands.Splice
	23	, Bricoleur.Utils
	24	build-depends: base >=4.7 && <5
	25	, adnot
	26	, bytestring
	27	, containers
	28	, directory
	29	, filepath
	30	, formatting
	31	, optparse-applicative
	32	, process
	33	, text
	34	, unix
	35	, vector
	36	hs-source-dirs: src
	37	ghc-options: -Wall
	38	default-language: Haskell2010
	39
	40	executable bricoleur
	41	hs-source-dirs: bricoleur
	42	main-is: Main.hs
	43	default-language: Haskell2010
	44	ghc-options: -Wall
	45	build-depends: base >=4.7 && <5
	46	, bricoleur

+0

-6

~~collage/Main.hs~~ less more

1		module Main where
2
3		import qualified Collage
4
5		main :: IO ()
6		main = Collage.getOpts >>= Collage.main

+0

-46

~~collage.cabal~~ less more

1		cabal-version: 2.2
2		name: collage
3		version: 0.1.0.0
4		synopsis: A tool for assembling documents out of working, testable code
5		description:
6		Collage is a tool for writing documents that include snippets of code
7		in such a way that the code can be build and examined independently
8		of the source document.
9		license: BSD-3-Clause
10		author: Getty Ritter <gettylefou@gmail.com>
11		maintainer: Getty Ritter <gettylefou@gmail.com>
12		copyright: @2018 Getty Ritter
13		category: Text
14		build-type: Simple
15
16
17		library
18		exposed-modules: Collage
19		, Collage.Config
20		, Collage.Opts
21		, Collage.Commands.Test
22		, Collage.Commands.Splice
23		, Collage.Utils
24		build-depends: base >=4.7 && <5
25		, adnot
26		, bytestring
27		, containers
28		, directory
29		, filepath
30		, formatting
31		, optparse-applicative
32		, process
33		, text
34		, unix
35		, vector
36		hs-source-dirs: src
37		ghc-options: -Wall
38		default-language: Haskell2010
39
40		executable collage
41		hs-source-dirs: collage
42		main-is: Main.hs
43		default-language: Haskell2010
44		ghc-options: -Wall
45		build-depends: base >=4.7 && <5
46		, collage

+97

-0

src/Bricoleur/Commands/Splice.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Bricoleur.Commands.Splice(runSplice) where
	4
	5	import Control.Monad (foldM)
	6	import qualified Data.Map as M
	7	import qualified Data.Text as T
	8	import qualified Data.Text.Lazy as TL
	9	import qualified Data.Text.Lazy.IO as TL
	10	import System.FilePath ((</>))
	11	import qualified System.FilePath as Sys
	12
	13	import Bricoleur.Config
	14	import Bricoleur.Opts
	15	import Bricoleur.Utils
	16
	17	findFragmentIdentifiers :: TL.Text -> [T.Text]
	18	findFragmentIdentifiers t
	19	\| (_, rs) <- TL.break (== '«') t
	20	, (f, rs') <- TL.break (== '»') (TL.drop 1 rs)
	21	, not (TL.null f) = TL.toStrict f : findFragmentIdentifiers rs'
	22	\| otherwise = []
	23
	24	newtype Fragment = Fragment [T.Text] deriving (Eq, Show)
	25
	26	toIdent :: T.Text -> TL.Text
	27	toIdent = TL.fromStrict . T.cons '«' . flip T.snoc '»'
	28
	29	findFragments :: FilePath -> T.Text -> [Source] -> Either TL.Text (IO TL.Text)
	30	findFragments root s sources = case (T.splitOn "/" s) of
	31	[] -> throw "Invalid empty fragment name!"
	32	(x:rs) -> case [ src
	33	\| src@Source { sourceName = n } <- sources
	34	, n == x
	35	] of
	36	[src] -> go src rs (sourceExpose src)
	37	[] -> throw ("Unable to find source named " % stext) x
	38	_ -> throw ("Ambiguous source name: " % stext) x
	39	where
	40
	41	go q [] (ExposeFile path) =
	42	return (cOpenFile "file source" (root </> sourceDir q </> path))
	43	go _ [] ExposeSections{} =
	44	throw ("Splice identifier «" % stext %
	45	"» matches a file with sections") s
	46	go _ [] NamedMap{} =
	47	throw ("Splice identifier «" % stext %
	48	"» matches a map, but does not specify a key!") s
	49
	50	go q [section] (ExposeSections path) =
	51	return (readSection (root </> sourceDir q </> path) section)
	52
	53	go _ (_:_) (ExposeSections path) =
	54	throw ("Splice identifier «" % stext %
	55	"» indexes too far into the path " % string % "!")
	56	s path
	57
	58	go _ (_:_) (ExposeFile path) =
	59	throw ("Splice identifier «" % stext %
	60	"» indexes too far into the file " % string % "!")
	61	s path
	62
	63	go q (k:rs) (NamedMap m)
	64	\| Just e <- M.lookup k m = go q rs e
	65	\| otherwise = throw
	66	("Splice identifier «" % stext %
	67	"» references a key " % stext %
	68	" which cannot be found.") s k
	69
	70	doReplacements :: FilePath -> [Source] -> TL.Text -> IO TL.Text
	71	doReplacements root e original =
	72	foldM doReplace original (findFragmentIdentifiers original)
	73	where
	74	doReplace file frag = do
	75	new <- case findFragments root frag e of
	76	Left err -> cError ("Fragment error: " % text) err
	77	Right x -> x
	78	return (TL.replace (toIdent frag) new file)
	79
	80	readSection :: FilePath -> T.Text -> IO TL.Text
	81	readSection path f = do
	82	contents <- cOpenFile "section source" path
	83	case TL.breakOn (toIdent f) contents of
	84	(_, "") -> cError ("Unable to find section " % shown %
	85	" in file " % string) f path
	86	(_, rs) ->
	87	let (_, skipLine) = TL.breakOn "\n" rs
	88	(section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)
	89	(skipLine', _) = TL.breakOnEnd "\n" section
	90	in return (TL.init skipLine')
	91
	92	runSplice :: Config -> Options -> IO ()
	93	runSplice conf opts = do
	94	let root = Sys.takeDirectory (optFile opts)
	95	f <- cOpenFile "document" (root </> confDocument conf)
	96	rs <- doReplacements root (confSources conf) f
	97	TL.putStrLn rs

+29

-0

src/Bricoleur/Commands/Test.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Bricoleur.Commands.Test (runTest) where
	4
	5	import Control.Monad (forM_)
	6	import System.FilePath ((</>))
	7	import qualified System.FilePath as Sys
	8	import qualified System.Process as Sys
	9
	10	import Bricoleur.Opts
	11	import Bricoleur.Config
	12	import Bricoleur.Utils
	13
	14	runTest :: Config -> Options -> IO ()
	15	runTest conf opts = do
	16	let root = Sys.takeDirectory (optFile opts)
	17	cDebug ("running tests for " % shown) (confDocument conf)
	18	forM_ (confSources conf) $ \ samp -> do
	19	cDebug ("- running test for " % stext) (sourceName samp)
	20	runCommand root samp
	21
	22	runCommand :: FilePath -> Source -> IO ()
	23	runCommand root src = do
	24	forM_ (sourceCommands src) $ \ln -> do
	25	let dir = root </> sourceDir src
	26	cDebug (" - $ " % shown % " in " % string) ln dir
	27	let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src) }
	28	(_, _, _, h) <- Sys.createProcess process
	29	Sys.waitForProcess h

+98

-0

src/Bricoleur/Config.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Bricoleur.Config
	4	( Config(..)
	5	, Source(..)
	6	, Expose(..)
	7	, getConfig
	8	, example
	9	) where
	10
	11	import Control.Applicative ((<\|>))
	12	import qualified Data.Adnot as A
	13	import qualified Data.ByteString as B
	14	import qualified Data.Map.Strict as M
	15	import qualified Data.Text as T
	16	import qualified Data.Vector as V
	17
	18	data Config = Config
	19	{ confDocument :: FilePath
	20	, confSources :: [Source]
	21	} deriving (Eq, Show)
	22
	23	instance A.FromAdnot Config where
	24	parseAdnot = A.withSumNamed "config file" "document" go
	25	where
	26	go payload
	27	\| Just file <- payload V.!? 0
	28	= Config <$> A.parseAdnot file
	29	<*> mapM A.parseAdnot (V.toList (V.tail payload))
	30	\| otherwise = Left "expected source file in config"
	31
	32
	33	data Source = Source
	34	{ sourceName :: T.Text
	35	, sourceDir :: FilePath
	36	, sourceCommands :: [String]
	37	, sourceExpose :: Expose
	38	} deriving (Eq, Show)
	39
	40	instance A.FromAdnot Source where
	41	parseAdnot = A.withProduct "source" $ \p -> do
	42	name <- p A..: "name"
	43	dir <- p A..: "dir"
	44	cmds <- p A..: "cmd"
	45	expose <- p A..: "expose"
	46	return (Source name dir cmds expose)
	47
	48
	49	data Expose
	50	= ExposeFile FilePath
	51	\| ExposeSections FilePath
	52	\| NamedMap (M.Map T.Text Expose)
	53	deriving (Eq, Show)
	54
	55	instance A.FromAdnot Expose where
	56	parseAdnot v = file v <\|> sections v <\|> namedMap v
	57	where
	58	file = A.withSumNamed "exposed fragments" "file" $ \ ps ->
	59	case V.toList ps of
	60	[] -> Left "Expected name for file"
	61	[f] -> ExposeFile <$> A.parseAdnot f
	62	_ -> Left "Too many arguments to file"
	63
	64	sections = A.withSumNamed "exposed fragments" "sections" $ \ ps ->
	65	case V.toList ps of
	66	[] -> Left "Expected name for sections"
	67	[f] -> ExposeSections <$> A.parseAdnot f
	68	_ -> Left "Too many arguments to sections"
	69
	70	namedMap = A.withProduct "exposed fragments" $ \ p ->
	71	NamedMap <$> mapM A.parseAdnot p
	72
	73	parseConfig :: B.ByteString -> Either String Config
	74	parseConfig = A.decode
	75
	76	getConfig :: FilePath -> IO (Either String Config)
	77	getConfig loc = do
	78	conf <- B.readFile loc
	79	return (parseConfig conf)
	80
	81	example :: Config
	82	example = Config
	83	{ confDocument = "main.md"
	84	, confSources =
	85	[ Source
	86	{ sourceName = "rust-sample"
	87	, sourceDir = "s1"
	88	, sourceCommands = ["cargo clean", "cargo build"]
	89	, sourceExpose = ExposeFile "src/main.rs"
	90	}
	91	, Source
	92	{ sourceName = "haskell-sample"
	93	, sourceDir = "s2"
	94	, sourceCommands = ["cabal new-build"]
	95	, sourceExpose = ExposeSections "Main.hs"
	96	}
	97	]
	98	}

+61

-0

src/Bricoleur/Opts.hs less more

	1	module Bricoleur.Opts
	2	( Command(..)
	3	, Options(..)
	4	, getOpts
	5	) where
	6
	7	import Control.Applicative ((<\|>))
	8	import qualified Options.Applicative as Opt
	9	import qualified System.Directory as Sys
	10	import qualified System.FilePath as Sys
	11
	12	data Command
	13	= Test
	14	\| Splice
	15	deriving (Eq, Show)
	16
	17	data Options = Options
	18	{ optFile :: FilePath
	19	, optVerbose :: Bool
	20	, optCommand :: Command
	21	} deriving (Eq, Show)
	22
	23	desc :: String
	24	desc = "FINISH ME"
	25
	26	opts :: Opt.ParserInfo Options
	27	opts = Opt.info (p Opt.<**> Opt.helper)
	28	(Opt.progDesc desc <>
	29	Opt.fullDesc <>
	30	Opt.header "arglbargl")
	31	where
	32	p = Options <$> (path <\|> pure "")
	33	<*> verbose
	34	<*> Opt.subparser (test <> splice)
	35
	36	path = Opt.strOption
	37	(Opt.short 'f' <>
	38	Opt.long "file" <>
	39	Opt.metavar "PATH" <>
	40	Opt.help "The path to the project file")
	41
	42	verbose = Opt.switch
	43	(Opt.short 'v' <>
	44	Opt.long "verbose" <>
	45	Opt.help "Show debug messages")
	46
	47	test = Opt.command "test" $ Opt.info
	48	(pure Test Opt.<**> Opt.helper)
	49	(Opt.progDesc "test the provided sources")
	50
	51	splice = Opt.command "splice" $ Opt.info
	52	(pure Splice Opt.<**> Opt.helper)
	53	(Opt.progDesc "splice sources into a final draft")
	54
	55	getOpts :: IO Options
	56	getOpts = do
	57	cwd <- Sys.getCurrentDirectory
	58	options <- Opt.execParser opts
	59	return $ if null (optFile options)
	60	then options { optFile = cwd Sys.</> "collage" }
	61	else options

+79

-0

src/Bricoleur/Utils.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Bricoleur.Utils
	4	( cOutput
	5	, cDebug
	6	, cWarn
	7	, cError
	8
	9	, cOpenFile
	10
	11	, throw
	12
	13	, F.format
	14	, (F.%)
	15	, F.stext
	16	, F.text
	17	, F.string
	18	, F.shown
	19	) where
	20
	21	import qualified Formatting as F
	22	import qualified Data.Text.Lazy as TL
	23	import qualified Data.Text.Lazy.Builder as TL
	24	import qualified Data.Text.Lazy.IO as TL
	25	import qualified System.Directory as Sys
	26	import qualified System.Exit as Sys
	27	import qualified System.IO as Sys
	28	import qualified System.Posix.IO as Posix
	29	import qualified System.Posix.Terminal as Posix
	30
	31	import Prelude (FilePath, IO, Either(Left), ($))
	32
	33	throw :: F.Format (Either TL.Text r) a -> a
	34	throw f =
	35	F.runFormat f (\ b -> Left (TL.toLazyText b))
	36
	37	stderr :: TL.Text -> IO ()
	38	stderr = TL.hPutStr Sys.stderr
	39
	40	-- \| Write output to stdout
	41	cOutput :: TL.Text -> IO ()
	42	cOutput = TL.putStrLn
	43
	44	-- \| Write a debug message to stderr.
	45	cDebug :: F.Format (IO ()) a -> a
	46	cDebug msg = F.runFormat msg $ \ b ->
	47	TL.hPutStrLn Sys.stderr (TL.toLazyText b)
	48
	49	-- \| Write a warning message to stderr. If we are connected to a TTY,
	50	-- then this will write in an orange color.
	51	cWarn :: F.Format (IO ()) a -> a
	52	cWarn msg = F.runFormat msg $ \b -> do
	53	isTTY <- Posix.queryTerminal Posix.stdOutput
	54	if isTTY
	55	then do stderr "\x1b[93m"
	56	stderr (TL.toLazyText b)
	57	stderr "\x1b[39m\n"
	58	else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
	59
	60	-- \| Write an error message to stderr and exit. If we are connected to
	61	-- a TTY, this message will be in red.
	62	cError :: F.Format (IO r) a -> a
	63	cError msg = F.runFormat msg $ \b -> do
	64	isTTY <- Posix.queryTerminal Posix.stdOutput
	65	if isTTY
	66	then do stderr "\x1b[91m"
	67	stderr (TL.toLazyText b)
	68	stderr "\x1b[39m\n"
	69	else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
	70	Sys.exitFailure
	71
	72
	73	cOpenFile :: TL.Text -> FilePath -> IO TL.Text
	74	cOpenFile purpose path = do
	75	exists <- Sys.doesFileExist path
	76	if exists
	77	then TL.readFile path
	78	else cError ("Unable to open " F.% F.text F.%
	79	" file at " F.% F.string) purpose path

+25

-0

src/Bricoleur.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Bricoleur
	4	( main
	5	, Opt.getOpts
	6	) where
	7
	8	import qualified System.Exit as Sys
	9
	10	import qualified Bricoleur.Config as Conf
	11	import qualified Bricoleur.Opts as Opt
	12
	13	import qualified Bricoleur.Commands.Splice as Cmd
	14	import qualified Bricoleur.Commands.Test as Cmd
	15
	16	-- \| Run the main @collage@ function with the provided options.
	17	main :: Opt.Options -> IO ()
	18	main opts = do
	19	configMb <- Conf.getConfig (Opt.optFile opts)
	20	config <- case configMb of
	21	Left err -> Sys.die err
	22	Right x -> return x
	23	case Opt.optCommand opts of
	24	Opt.Test -> Cmd.runTest config opts
	25	Opt.Splice -> Cmd.runSplice config opts

+0

-97

~~src/Collage/Commands/Splice.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Collage.Commands.Splice(runSplice) where
4
5		import Control.Monad (foldM)
6		import qualified Data.Map as M
7		import qualified Data.Text as T
8		import qualified Data.Text.Lazy as TL
9		import qualified Data.Text.Lazy.IO as TL
10		import System.FilePath ((</>))
11		import qualified System.FilePath as Sys
12
13		import Collage.Config
14		import Collage.Opts
15		import Collage.Utils
16
17		findFragmentIdentifiers :: TL.Text -> [T.Text]
18		findFragmentIdentifiers t
19		\| (_, rs) <- TL.break (== '«') t
20		, (f, rs') <- TL.break (== '»') (TL.drop 1 rs)
21		, not (TL.null f) = TL.toStrict f : findFragmentIdentifiers rs'
22		\| otherwise = []
23
24		newtype Fragment = Fragment [T.Text] deriving (Eq, Show)
25
26		toIdent :: T.Text -> TL.Text
27		toIdent = TL.fromStrict . T.cons '«' . flip T.snoc '»'
28
29		findFragments :: FilePath -> T.Text -> [Source] -> Either TL.Text (IO TL.Text)
30		findFragments root s sources = case (T.splitOn "/" s) of
31		[] -> throw "Invalid empty fragment name!"
32		(x:rs) -> case [ src
33		\| src@Source { sourceName = n } <- sources
34		, n == x
35		] of
36		[src] -> go src rs (sourceExpose src)
37		[] -> throw ("Unable to find source named " % stext) x
38		_ -> throw ("Ambiguous source name: " % stext) x
39		where
40
41		go q [] (ExposeFile path) =
42		return (cOpenFile "file source" (root </> sourceDir q </> path))
43		go _ [] ExposeSections{} =
44		throw ("Splice identifier «" % stext %
45		"» matches a file with sections") s
46		go _ [] NamedMap{} =
47		throw ("Splice identifier «" % stext %
48		"» matches a map, but does not specify a key!") s
49
50		go q [section] (ExposeSections path) =
51		return (readSection (root </> sourceDir q </> path) section)
52
53		go _ (_:_) (ExposeSections path) =
54		throw ("Splice identifier «" % stext %
55		"» indexes too far into the path " % string % "!")
56		s path
57
58		go _ (_:_) (ExposeFile path) =
59		throw ("Splice identifier «" % stext %
60		"» indexes too far into the file " % string % "!")
61		s path
62
63		go q (k:rs) (NamedMap m)
64		\| Just e <- M.lookup k m = go q rs e
65		\| otherwise = throw
66		("Splice identifier «" % stext %
67		"» references a key " % stext %
68		" which cannot be found.") s k
69
70		doReplacements :: FilePath -> [Source] -> TL.Text -> IO TL.Text
71		doReplacements root e original =
72		foldM doReplace original (findFragmentIdentifiers original)
73		where
74		doReplace file frag = do
75		new <- case findFragments root frag e of
76		Left err -> cError ("Fragment error: " % text) err
77		Right x -> x
78		return (TL.replace (toIdent frag) new file)
79
80		readSection :: FilePath -> T.Text -> IO TL.Text
81		readSection path f = do
82		contents <- cOpenFile "section source" path
83		case TL.breakOn (toIdent f) contents of
84		(_, "") -> cError ("Unable to find section " % shown %
85		" in file " % string) f path
86		(_, rs) ->
87		let (_, skipLine) = TL.breakOn "\n" rs
88		(section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)
89		(skipLine', _) = TL.breakOnEnd "\n" section
90		in return (TL.init skipLine')
91
92		runSplice :: Config -> Options -> IO ()
93		runSplice conf opts = do
94		let root = Sys.takeDirectory (optFile opts)
95		f <- cOpenFile "document" (root </> confDocument conf)
96		rs <- doReplacements root (confSources conf) f
97		TL.putStrLn rs

+0

-29

~~src/Collage/Commands/Test.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Collage.Commands.Test (runTest) where
4
5		import Control.Monad (forM_)
6		import System.FilePath ((</>))
7		import qualified System.FilePath as Sys
8		import qualified System.Process as Sys
9
10		import Collage.Opts
11		import Collage.Config
12		import Collage.Utils
13
14		runTest :: Config -> Options -> IO ()
15		runTest conf opts = do
16		let root = Sys.takeDirectory (optFile opts)
17		cDebug ("running tests for " % shown) (confDocument conf)
18		forM_ (confSources conf) $ \ samp -> do
19		cDebug ("- running test for " % stext) (sourceName samp)
20		runCommand root samp
21
22		runCommand :: FilePath -> Source -> IO ()
23		runCommand root src = do
24		forM_ (sourceCommands src) $ \ln -> do
25		let dir = root </> sourceDir src
26		cDebug (" - $ " % shown % " in " % string) ln dir
27		let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src) }
28		(_, _, _, h) <- Sys.createProcess process
29		Sys.waitForProcess h

+0

-98

~~src/Collage/Config.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Collage.Config
4		( Config(..)
5		, Source(..)
6		, Expose(..)
7		, getConfig
8		, example
9		) where
10
11		import Control.Applicative ((<\|>))
12		import qualified Data.Adnot as A
13		import qualified Data.ByteString as B
14		import qualified Data.Map.Strict as M
15		import qualified Data.Text as T
16		import qualified Data.Vector as V
17
18		data Config = Config
19		{ confDocument :: FilePath
20		, confSources :: [Source]
21		} deriving (Eq, Show)
22
23		instance A.FromAdnot Config where
24		parseAdnot = A.withSumNamed "config file" "document" go
25		where
26		go payload
27		\| Just file <- payload V.!? 0
28		= Config <$> A.parseAdnot file
29		<*> mapM A.parseAdnot (V.toList (V.tail payload))
30		\| otherwise = Left "expected source file in config"
31
32
33		data Source = Source
34		{ sourceName :: T.Text
35		, sourceDir :: FilePath
36		, sourceCommands :: [String]
37		, sourceExpose :: Expose
38		} deriving (Eq, Show)
39
40		instance A.FromAdnot Source where
41		parseAdnot = A.withProduct "source" $ \p -> do
42		name <- p A..: "name"
43		dir <- p A..: "dir"
44		cmds <- p A..: "cmd"
45		expose <- p A..: "expose"
46		return (Source name dir cmds expose)
47
48
49		data Expose
50		= ExposeFile FilePath
51		\| ExposeSections FilePath
52		\| NamedMap (M.Map T.Text Expose)
53		deriving (Eq, Show)
54
55		instance A.FromAdnot Expose where
56		parseAdnot v = file v <\|> sections v <\|> namedMap v
57		where
58		file = A.withSumNamed "exposed fragments" "file" $ \ ps ->
59		case V.toList ps of
60		[] -> Left "Expected name for file"
61		[f] -> ExposeFile <$> A.parseAdnot f
62		_ -> Left "Too many arguments to file"
63
64		sections = A.withSumNamed "exposed fragments" "sections" $ \ ps ->
65		case V.toList ps of
66		[] -> Left "Expected name for sections"
67		[f] -> ExposeSections <$> A.parseAdnot f
68		_ -> Left "Too many arguments to sections"
69
70		namedMap = A.withProduct "exposed fragments" $ \ p ->
71		NamedMap <$> mapM A.parseAdnot p
72
73		parseConfig :: B.ByteString -> Either String Config
74		parseConfig = A.decode
75
76		getConfig :: FilePath -> IO (Either String Config)
77		getConfig loc = do
78		conf <- B.readFile loc
79		return (parseConfig conf)
80
81		example :: Config
82		example = Config
83		{ confDocument = "main.md"
84		, confSources =
85		[ Source
86		{ sourceName = "rust-sample"
87		, sourceDir = "s1"
88		, sourceCommands = ["cargo clean", "cargo build"]
89		, sourceExpose = ExposeFile "src/main.rs"
90		}
91		, Source
92		{ sourceName = "haskell-sample"
93		, sourceDir = "s2"
94		, sourceCommands = ["cabal new-build"]
95		, sourceExpose = ExposeSections "Main.hs"
96		}
97		]
98		}

+0

-61

~~src/Collage/Opts.hs~~ less more

1		module Collage.Opts
2		( Command(..)
3		, Options(..)
4		, getOpts
5		) where
6
7		import Control.Applicative ((<\|>))
8		import qualified Options.Applicative as Opt
9		import qualified System.Directory as Sys
10		import qualified System.FilePath as Sys
11
12		data Command
13		= Test
14		\| Splice
15		deriving (Eq, Show)
16
17		data Options = Options
18		{ optFile :: FilePath
19		, optVerbose :: Bool
20		, optCommand :: Command
21		} deriving (Eq, Show)
22
23		desc :: String
24		desc = "FINISH ME"
25
26		opts :: Opt.ParserInfo Options
27		opts = Opt.info (p Opt.<**> Opt.helper)
28		(Opt.progDesc desc <>
29		Opt.fullDesc <>
30		Opt.header "arglbargl")
31		where
32		p = Options <$> (path <\|> pure "")
33		<*> verbose
34		<*> Opt.subparser (test <> splice)
35
36		path = Opt.strOption
37		(Opt.short 'f' <>
38		Opt.long "file" <>
39		Opt.metavar "PATH" <>
40		Opt.help "The path to the project file")
41
42		verbose = Opt.switch
43		(Opt.short 'v' <>
44		Opt.long "verbose" <>
45		Opt.help "Show debug messages")
46
47		test = Opt.command "test" $ Opt.info
48		(pure Test Opt.<**> Opt.helper)
49		(Opt.progDesc "test the provided sources")
50
51		splice = Opt.command "splice" $ Opt.info
52		(pure Splice Opt.<**> Opt.helper)
53		(Opt.progDesc "splice sources into a final draft")
54
55		getOpts :: IO Options
56		getOpts = do
57		cwd <- Sys.getCurrentDirectory
58		options <- Opt.execParser opts
59		return $ if null (optFile options)
60		then options { optFile = cwd Sys.</> "collage" }
61		else options

+0

-79

~~src/Collage/Utils.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Collage.Utils
4		( cOutput
5		, cDebug
6		, cWarn
7		, cError
8
9		, cOpenFile
10
11		, throw
12
13		, F.format
14		, (F.%)
15		, F.stext
16		, F.text
17		, F.string
18		, F.shown
19		) where
20
21		import qualified Formatting as F
22		import qualified Data.Text.Lazy as TL
23		import qualified Data.Text.Lazy.Builder as TL
24		import qualified Data.Text.Lazy.IO as TL
25		import qualified System.Directory as Sys
26		import qualified System.Exit as Sys
27		import qualified System.IO as Sys
28		import qualified System.Posix.IO as Posix
29		import qualified System.Posix.Terminal as Posix
30
31		import Prelude (FilePath, IO, Either(Left), ($))
32
33		throw :: F.Format (Either TL.Text r) a -> a
34		throw f =
35		F.runFormat f (\ b -> Left (TL.toLazyText b))
36
37		stderr :: TL.Text -> IO ()
38		stderr = TL.hPutStr Sys.stderr
39
40		-- \| Write output to stdout
41		cOutput :: TL.Text -> IO ()
42		cOutput = TL.putStrLn
43
44		-- \| Write a debug message to stderr.
45		cDebug :: F.Format (IO ()) a -> a
46		cDebug msg = F.runFormat msg $ \ b ->
47		TL.hPutStrLn Sys.stderr (TL.toLazyText b)
48
49		-- \| Write a warning message to stderr. If we are connected to a TTY,
50		-- then this will write in an orange color.
51		cWarn :: F.Format (IO ()) a -> a
52		cWarn msg = F.runFormat msg $ \b -> do
53		isTTY <- Posix.queryTerminal Posix.stdOutput
54		if isTTY
55		then do stderr "\x1b[93m"
56		stderr (TL.toLazyText b)
57		stderr "\x1b[39m\n"
58		else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
59
60		-- \| Write an error message to stderr and exit. If we are connected to
61		-- a TTY, this message will be in red.
62		cError :: F.Format (IO r) a -> a
63		cError msg = F.runFormat msg $ \b -> do
64		isTTY <- Posix.queryTerminal Posix.stdOutput
65		if isTTY
66		then do stderr "\x1b[91m"
67		stderr (TL.toLazyText b)
68		stderr "\x1b[39m\n"
69		else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
70		Sys.exitFailure
71
72
73		cOpenFile :: TL.Text -> FilePath -> IO TL.Text
74		cOpenFile purpose path = do
75		exists <- Sys.doesFileExist path
76		if exists
77		then TL.readFile path
78		else cError ("Unable to open " F.% F.text F.%
79		" file at " F.% F.string) purpose path

+0

-25

~~src/Collage.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Collage
4		( main
5		, Opt.getOpts
6		) where
7
8		import qualified System.Exit as Sys
9
10		import qualified Collage.Config as Conf
11		import qualified Collage.Opts as Opt
12
13		import qualified Collage.Commands.Splice as Cmd
14		import qualified Collage.Commands.Test as Cmd
15
16		-- \| Run the main @collage@ function with the provided options.
17		main :: Opt.Options -> IO ()
18		main opts = do
19		configMb <- Conf.getConfig (Opt.optFile opts)
20		config <- case configMb of
21		Left err -> Sys.die err
22		Right x -> return x
23		case Opt.optCommand opts of
24		Opt.Test -> Cmd.runTest config opts
25		Opt.Splice -> Cmd.runSplice config opts