Commit 309076d8293ea157abc97bb870d1626c18411210 - bricoleur

ormolu Getty Ritter 4 years ago

7 changed file(s) with 242 addition(s) and 197 deletion(s). Collapse all Expand all

-0

examples/basic-example/s2/Main.hs less more

1	1	-- «front-matter»
2	2	module Main where
	3
3	4	-- «end»
4	5
5	6	-- «functions»
6	7	main :: IO ()
7	8	main = return ()
	9
8	10	-- «end»

+67

-45

src/Bricoleur/Commands/Splice.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2
3		module Bricoleur.Commands.Splice(runSplice) where
	3	module Bricoleur.Commands.Splice (runSplice) where
4	4
5		import ~~Control.Monad (foldM)~~
	5	import Bricoleur.Config
	6	import Bricoleur.Opts
	7	import Bricoleur.Utils
	8	import Control.Monad (foldM)
6	9	import qualified Data.Map as M
7	10	import qualified Data.Text as T
8	11	import qualified Data.Text.Lazy as TL
9	12	import qualified Data.Text.Lazy.IO as TL
10		import System.FilePath ((</>))
	13	import System.FilePath ((</>))
11	14	import qualified System.FilePath as Sys
12
13		import Bricoleur.Config
14		import Bricoleur.Opts
15		import Bricoleur.Utils
16	15
17	16	findFragmentIdentifiers :: TL.Text -> [T.Text]
18	17	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'~~
	18	\| (_, rs) <- TL.break (== '«') t,
	19	(f, rs') <- TL.break (== '»') (TL.drop 1 rs),
	20	not (TL.null f) =
	21	TL.toStrict f : findFragmentIdentifiers rs'
22	22	\| otherwise = []
23	23
24	24	newtype Fragment = Fragment [T.Text] deriving (Eq, Show)

28	28
29	29	findFragments :: FilePath -> T.Text -> [Source] -> Either TL.Text (IO TL.Text)
30	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
	31	[] -> throw "Invalid empty fragment name!"
	32	(x : rs) -> case [ src
	33	\| src@Source {sourceName = n} <- sources,
	34	n == x
35	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~~
	36	[src] -> go src rs (sourceExpose src)
	37	[] -> throw ("Unable to find source named " % stext) x
	38	_ -> throw ("Ambiguous source name: " % stext) x
39	39	where
40
41	40	go q [] (ExposeFile path) =
42	41	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
	42	go _ [] ExposeSections {} =
	43	throw
	44	( "Splice identifier «" % stext
	45	% "» matches a file with sections"
	46	)
	47	s
	48	go _ [] NamedMap {} =
	49	throw
	50	( "Splice identifier «" % stext
	51	% "» matches a map, but does not specify a key!"
	52	)
	53	s
50	54	go q [section] (ExposeSections path) =
51	55	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)
	56	go _ (_ : _) (ExposeSections path) =
	57	throw
	58	( "Splice identifier «" % stext
	59	% "» indexes too far into the path "
	60	% string
	61	% "!"
	62	)
	63	s
	64	path
	65	go _ (_ : _) (ExposeFile path) =
	66	throw
	67	( "Splice identifier «" % stext
	68	% "» indexes too far into the file "
	69	% string
	70	% "!"
	71	)
	72	s
	73	path
	74	go q (k : rs) (NamedMap m)
64	75	\| 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
	76	\| otherwise =
	77	throw
	78	( "Splice identifier «" % stext
	79	% "» references a key "
	80	% stext
	81	% " which cannot be found."
	82	)
	83	s
	84	k
69	85
70	86	doReplacements :: FilePath -> [Source] -> TL.Text -> IO TL.Text
71	87	doReplacements root e original =

74	90	doReplace file frag = do
75	91	new <- case findFragments root frag e of
76	92	Left err -> cDie ("Fragment error: " % text) err
77		Right x -> x
	93	Right x -> x
78	94	return (TL.replace (toIdent frag) new file)
79	95
80	96	readSection :: FilePath -> T.Text -> IO TL.Text
81	97	readSection path f = do
82	98	contents <- cOpenFile "section source" path
83	99	case TL.breakOn (toIdent f) contents of
84		(_, "") -> cDie ("Unable to find section " % shown %
85		" in file " % string) f path
	100	(_, "") ->
	101	cDie
	102	( "Unable to find section " % shown
	103	% " in file "
	104	% string
	105	)
	106	f
	107	path
86	108	(_, rs) ->
87	109	let (_, skipLine) = TL.breakOn "\n" rs
88	110	(section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)
89	111	(skipLine', _) = TL.breakOnEnd "\n" section
90		in return (TL.init skipLine')
	112	in return (TL.init skipLine')
91	113
92	114	runSplice :: Config -> Options -> IO ()
93	115	runSplice conf opts = do

+20

-16

src/Bricoleur/Commands/Test.hs less more

2	2
3	3	module Bricoleur.Commands.Test (runTest) where
4	4
5		import ~~Control.Monad (forM_)~~
	5	import Bricoleur.Config
	6	import Bricoleur.Opts
	7	import Bricoleur.Utils
	8	import Control.Monad (forM_)
6	9	import qualified Data.ByteString.Lazy.Char8 as B
7	10	import qualified GHC.IO.Exception as Exn
8		import System.FilePath ((</>))
	11	import System.FilePath ((</>))
9	12	import qualified System.FilePath as Sys
10	13	import qualified System.Process as Sys
11
12		import Bricoleur.Opts
13		import Bricoleur.Config
14		import Bricoleur.Utils
15
16	14
17	15	runTest :: Config -> Options -> IO ()
18	16	runTest conf opts = do
19	17	let root = Sys.takeDirectory (optFile opts)
20	18	cDebug ("running tests for " % shown) (confDocument conf)
21		forM_ (confSources conf) $ \ samp -> do
	19	forM_ (confSources conf) $ \samp -> do
22	20	cDebug ("- running test for " % stext) (sourceName samp)
23	21	runCommand root samp
24
25	22
26	23	runCommand :: FilePath -> Source -> IO ()
27	24	runCommand root src = do

29	26	let dir = root </> sourceDir src
30	27	cDebug (" $ " % string % " (in '" % string % "')") ln dir
31	28	(outH, inH) <- Sys.createPipe
32		let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src)
33		, Sys.std_out = Sys.UseHandle inH
34		, Sys.std_err = Sys.UseHandle inH
35		}
	29	let process =
	30	(Sys.shell ln)
	31	{ Sys.cwd = Just (root </> sourceDir src),
	32	Sys.std_out = Sys.UseHandle inH,
	33	Sys.std_err = Sys.UseHandle inH
	34	}
36	35	(_, _, _, p) <- Sys.createProcess process
37	36	bufOutput <- B.hGetContents outH
38	37	code <- Sys.waitForProcess p

40	39	Exn.ExitSuccess -> return ()
41	40	Exn.ExitFailure n -> do
42	41	let idtext = map (B.append " - ") (B.lines bufOutput)
43		cError ("\nCommand '" % string %
44		"' exited with error (" % shown %
45		~~")") ln n~~
	42	cError
	43	( "\nCommand '" % string
	44	% "' exited with error ("
	45	% shown
	46	% ")"
	47	)
	48	ln
	49	n
46	50	mapM_ bsErrorLn idtext

+50

-48

src/Bricoleur/Config.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2
3	3	module Bricoleur.Config
4		( Config(..)
5		, Source(..)
6		, Expose(..)
7		, getConfig
8		, example
9		) where
	4	( Config (..),
	5	Source (..),
	6	Expose (..),
	7	getConfig,
	8	example,
	9	)
	10	where
10	11
11		import Control.Applicative ((<\|>))
	12	import Control.Applicative ((<\|>))
12	13	import qualified Data.Adnot as A
13	14	import qualified Data.ByteString as B
14	15	import qualified Data.Map.Strict as M

16	17	import qualified Data.Vector as V
17	18
18	19	data Config = Config
19		{ confDocument :: FilePath
20		, confSources :: [Source]
21		~~} deriving (Eq, Show)~~
	20	{ confDocument :: FilePath,
	21	confSources :: [Source]
	22	}
	23	deriving (Eq, Show)
22	24
23	25	instance A.FromAdnot Config where
24	26	parseAdnot = A.withSumNamed "config file" "document" go
25	27	where
26	28	go payload
27		\| Just file <- payload V.!? 0
28		= Config <$> A.parseAdnot file
29		~~<*> mapM A.parseAdnot (V.toList (V.tail payload))~~
	29	\| Just file <- payload V.!? 0 =
	30	Config <$> A.parseAdnot file
	31	<*> mapM A.parseAdnot (V.toList (V.tail payload))
30	32	\| otherwise = Left "expected source file in config"
31	33
32
33	34	data Source = Source
34		{ sourceName :: T.Text
35		, sourceDir :: FilePath
36		, sourceCommands :: [String]
37		, sourceExpose :: Expose
38		~~} deriving (Eq, Show)~~
	35	{ sourceName :: T.Text,
	36	sourceDir :: FilePath,
	37	sourceCommands :: [String],
	38	sourceExpose :: Expose
	39	}
	40	deriving (Eq, Show)
39	41
40	42	instance A.FromAdnot Source where
41	43	parseAdnot = A.withProduct "source" $ \p -> do
42		name <- p A..: "name"
43		dir <- p A..: "dir"
44		~~cmds <- p A..: "cmd~~"
	44	name <- p A..: "name"
	45	dir <- p A..: "dir"
	46	cmds <- p A..: "cmd"
45	47	expose <- p A..: "expose"
46	48	return (Source name dir cmds expose)
47
48	49
49	50	data Expose
50	51	= ExposeFile FilePath
51	52	\| ExposeSections FilePath
52	53	\| NamedMap (M.Map T.Text Expose)
53		deriving (Eq, Show)
	54	deriving (Eq, Show)
54	55
55	56	instance A.FromAdnot Expose where
56	57	parseAdnot v = file v <\|> sections v <\|> namedMap v
57	58	where
58		file = A.withSumNamed "exposed fragments" "file" $ \ ps ->
	59	file = A.withSumNamed "exposed fragments" "file" $ \ps ->
59	60	case V.toList ps of
60		[] -> Left "Expected name for file"
	61	[] -> Left "Expected name for file"
61	62	[f] -> ExposeFile <$> A.parseAdnot f
62		_ -> Left "Too many arguments to file"
	63	_ -> Left "Too many arguments to file"
63	64
64		sections = A.withSumNamed "exposed fragments" "sections" $ \ ps ->
	65	sections = A.withSumNamed "exposed fragments" "sections" $ \ps ->
65	66	case V.toList ps of
66		[] -> Left "Expected name for sections"
	67	[] -> Left "Expected name for sections"
67	68	[f] -> ExposeSections <$> A.parseAdnot f
68		_ -> Left "Too many arguments to sections"
	69	_ -> Left "Too many arguments to sections"
69	70
70		namedMap = A.withProduct "exposed fragments" $ \ p ->
	71	namedMap = A.withProduct "exposed fragments" $ \p ->
71	72	NamedMap <$> mapM A.parseAdnot p
72	73
73	74	parseConfig :: B.ByteString -> Either String Config

79	80	return (parseConfig conf)
80	81
81	82	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		}
	83	example =
	84	Config
	85	{ confDocument = "main.md",
	86	confSources =
	87	[ Source
	88	{ sourceName = "rust-sample",
	89	sourceDir = "s1",
	90	sourceCommands = ["cargo clean", "cargo build"],
	91	sourceExpose = ExposeFile "src/main.rs"
	92	},
	93	Source
	94	{ sourceName = "haskell-sample",
	95	sourceDir = "s2",
	96	sourceCommands = ["cabal new-build"],
	97	sourceExpose = ExposeSections "Main.hs"
	98	}
	99	]
	100	}

+50

-35

src/Bricoleur/Opts.hs less more

1	1	module Bricoleur.Opts
2		( Command(..)
3		, Options(..)
4		, getOpts
5		) where
	2	( Command (..),
	3	Options (..),
	4	getOpts,
	5	)
	6	where
6	7
7		import Control.Applicative ((<\|>))
	8	import Control.Applicative ((<\|>))
8	9	import qualified Options.Applicative as Opt
9	10	import qualified System.Directory as Sys
10	11	import qualified System.FilePath as Sys

12	13	data Command
13	14	= Test
14	15	\| Splice
15		deriving (Eq, Show)
	16	deriving (Eq, Show)
16	17
17	18	data Options = Options
18		{ optFile :: FilePath
19		, optVerbose :: Bool
20		, optCommand :: Command
21		} deriving (Eq, Show)
	19	{ optFile :: FilePath,
	20	optVerbose :: Bool,
	21	optCommand :: Command
	22	}
	23	deriving (Eq, Show)
22	24
23	25	desc :: String
24	26	desc = "Bricoleur: a tool for testing and stiching code into documents"
25	27
26	28	opts :: Opt.ParserInfo Options
27		opts = Opt.info (p Opt.<**> Opt.helper)
28		(Opt.progDesc desc <>
29		Opt.fullDesc <>
30		Opt.header "arglbargl")
	29	opts =
	30	Opt.info
	31	(p Opt.<**> Opt.helper)
	32	( Opt.progDesc desc
	33	<> Opt.fullDesc
	34	<> Opt.header "arglbargl"
	35	)
31	36	where
32		p = Options <$> (path <\|> pure "")
33		<*> verbose
34		~~<*> Opt.subparser (test <> splice)~~
	37	p =
	38	Options <$> (path <\|> pure "")
	39	<*> verbose
	40	<*> Opt.subparser (test <> splice)
35	41
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")~~
	42	path =
	43	Opt.strOption
	44	( Opt.short 'f'
	45	<> Opt.long "file"
	46	<> Opt.metavar "PATH"
	47	<> Opt.help "The path to the project file"
	48	)
41	49
42		verbose = Opt.switch
43		(Opt.short 'v' <>
44		Opt.long "verbose" <>
45		Opt.help "Show debug messages")
	50	verbose =
	51	Opt.switch
	52	( Opt.short 'v'
	53	<> Opt.long "verbose"
	54	<> Opt.help "Show debug messages"
	55	)
46	56
47		test = Opt.command "test" $ Opt.info
48		(pure Test Opt.<**> Opt.helper)
49		~~(Opt.progDesc "test the provided sources")~~
	57	test =
	58	Opt.command "test" $
	59	Opt.info
	60	(pure Test Opt.<**> Opt.helper)
	61	(Opt.progDesc "test the provided sources")
50	62
51		splice = Opt.command "splice" $ Opt.info
52		(pure Splice Opt.<**> Opt.helper)
53		~~(Opt.progDesc "splice sources into a final draft")~~
	63	splice =
	64	Opt.command "splice" $
	65	Opt.info
	66	(pure Splice Opt.<**> Opt.helper)
	67	(Opt.progDesc "splice sources into a final draft")
54	68
55	69	getOpts :: IO Options
56	70	getOpts = do
57	71	cwd <- Sys.getCurrentDirectory
58	72	options <- Opt.execParser opts
59		return $ if null (optFile options)
60		then options { optFile = cwd Sys.</> "bricoleur" }
61		~~else options~~
	73	return $
	74	if null (optFile options)
	75	then options {optFile = cwd Sys.</> "bricoleur"}
	76	else options

+45

-44

src/Bricoleur/Utils.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2
3	3	module Bricoleur.Utils
4		( cOutput
5		, cDebug
6		, cWarn
7		, cError
8		, cDie
9		, bsErrorLn
	4	( cOutput,
	5	cDebug,
	6	cWarn,
	7	cError,
	8	cDie,
	9	bsErrorLn,
	10	cOpenFile,
	11	throw,
	12	F.format,
	13	(F.%),
	14	F.stext,
	15	F.text,
	16	F.string,
	17	F.shown,
	18	)
	19	where
10	20
11		, cOpenFile
12
13		, throw
14
15		, F.format
16		, (F.%)
17		, F.stext
18		, F.text
19		, F.string
20		, F.shown
21		) where
22
23		import qualified Formatting as F
24	21	import qualified Data.ByteString.Lazy.Char8 as BS
25	22	import qualified Data.Text.Lazy as TL
26	23	import qualified Data.Text.Lazy.Builder as TL
27	24	import qualified Data.Text.Lazy.IO as TL
	25	import qualified Formatting as F
28	26	import qualified System.Directory as Sys
29	27	import qualified System.Exit as Sys
30	28	import qualified System.IO as Sys
31	29	import qualified System.Posix.IO as Posix
32	30	import qualified System.Posix.Terminal as Posix
33
34		import Prelude (FilePath, IO, Either(Left), ($))
	31	import Prelude (Either (Left), FilePath, IO, ($))
35	32
36	33	-- \| Produce a 'Left' value from a format string
37	34	throw :: F.Format (Either TL.Text r) a -> a
38	35	throw f =
39		F.runFormat f (\ b -> Left (TL.toLazyText b))
40
	36	F.runFormat f (\b -> Left (TL.toLazyText b))
41	37
42	38	stderr :: TL.Text -> IO ()
43	39	stderr = TL.hPutStr Sys.stderr
44
45	40
46	41	-- \| Write output to stdout
47	42	cOutput :: TL.Text -> IO ()
48	43	cOutput = TL.putStrLn
49	44
50
51	45	-- \| Write a debug message to stderr.
52	46	cDebug :: F.Format (IO ()) a -> a
53		cDebug msg = F.runFormat msg $ \ b ->
	47	cDebug msg = F.runFormat msg $ \b ->
54	48	TL.hPutStrLn Sys.stderr (TL.toLazyText b)
55
56	49
57	50	-- \| Write a warning message to stderr. If we are connected to a TTY,
58	51	-- then this will write in an orange color.

60	53	cWarn msg = F.runFormat msg $ \b -> do
61	54	isTTY <- Posix.queryTerminal Posix.stdOutput
62	55	if isTTY
63		then do stderr "\x1b[93m"
64		stderr (TL.toLazyText b)
65		~~stderr "\x1b[39m\n"~~
	56	then do
	57	stderr "\x1b[93m"
	58	stderr (TL.toLazyText b)
	59	stderr "\x1b[39m\n"
66	60	else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
67
68	61
69	62	-- \| Write an error message to stderr and exit. If we are connected to
70	63	-- a TTY, this message will be in red.

72	65	cError msg = F.runFormat msg $ \b -> do
73	66	isTTY <- Posix.queryTerminal Posix.stdOutput
74	67	if isTTY
75		then do stderr "\x1b[91m"
76		stderr (TL.toLazyText b)
77		~~stderr "\x1b[39m\n"~~
	68	then do
	69	stderr "\x1b[91m"
	70	stderr (TL.toLazyText b)
	71	stderr "\x1b[39m\n"
78	72	else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
79	73
80	74	-- \| Write an error message to stderr and exit. If we are connected to
81	75	-- a TTY, this message will be in red.
82	76	cDie :: F.Format (IO r) a -> a
83		cDie msg = F.runFormat msg $ \ b -> do
	77	cDie msg = F.runFormat msg $ \b -> do
84	78	isTTY <- Posix.queryTerminal Posix.stdOutput
85	79	if isTTY
86		then do stderr "\x1b[91m"
87		stderr (TL.toLazyText b)
88		~~stderr "\x1b[39m\n"~~
	80	then do
	81	stderr "\x1b[91m"
	82	stderr (TL.toLazyText b)
	83	stderr "\x1b[39m\n"
89	84	else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
90	85	Sys.exitFailure
91
92	86
93	87	bsErrorLn :: BS.ByteString -> IO ()
94	88	bsErrorLn bs = do
95	89	isTTY <- Posix.queryTerminal Posix.stdOutput
96	90	if isTTY
97		then do BS.hPutStr Sys.stderr "\x1b[91m"
98		BS.hPutStr Sys.stderr bs
99		~~BS.hPutStr Sys.stderr "\x1b[39m\n"~~
	91	then do
	92	BS.hPutStr Sys.stderr "\x1b[91m"
	93	BS.hPutStr Sys.stderr bs
	94	BS.hPutStr Sys.stderr "\x1b[39m\n"
100	95	else BS.hPutStrLn Sys.stderr bs
101	96
102	97	cOpenFile :: TL.Text -> FilePath -> IO TL.Text

104	99	exists <- Sys.doesFileExist path
105	100	if exists
106	101	then TL.readFile path
107		else cDie ("Unable to open " F.% F.text F.%
108		" file at " F.% F.string) purpose path
	102	else
	103	cDie
	104	( "Unable to open " F.% F.text
	105	F.% " file at "
	106	F.% F.string
	107	)
	108	purpose
	109	path

-9

src/Bricoleur.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2
3	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
	4	( main,
	5	Opt.getOpts,
	6	)
	7	where
12	8
13	9	import qualified Bricoleur.Commands.Splice as Cmd
14	10	import qualified Bricoleur.Commands.Test as Cmd
	11	import qualified Bricoleur.Config as Conf
	12	import qualified Bricoleur.Opts as Opt
	13	import qualified System.Exit as Sys
15	14
16	15	-- \| Run the main @bricoleur@ function with the provided options.
17	16	main :: Opt.Options -> IO ()

21	20	Left err -> Sys.die err
22	21	Right x -> return x
23	22	case Opt.optCommand opts of
24		Opt.Test -> Cmd.runTest config opts
	23	Opt.Test -> Cmd.runTest config opts
25	24	Opt.Splice -> Cmd.runSplice config opts