Commit 3a981cae6083e95bfd78337cbdfe67a4d15f68d4 - bricoleur

Implement naive and largely terrible Splice function Getty Ritter 5 years ago

5 changed file(s) with 131 addition(s) and 23 deletion(s). Collapse all Expand all

-11

collage.cabal less more

1	1	cabal-version: 2.2
2	2	name: collage
3	3	version: 0.1.0.0
4		-- synopsis:
	4	synopsis: A tool for assembling documents out of working, testable code
5	5	-- description:
6	6	license: BSD-3-Clause
7	7	author: Getty Ritter <gettylefou@gmail.com>
8	8	maintainer: Getty Ritter <gettylefou@gmail.com>
9	9	copyright: @2018 Getty Ritter
10		-- category:
	10	category: Text
11	11	build-type: Simple
12	12
13	13
14	14	library
15		hs-source-dirs: src
16		ghc-options: -Wall
	15	exposed-modules: Collage
	16	, Collage.Config
	17	, Collage.Opts
	18	, Collage.Commands.Test
	19	, Collage.Commands.Splice
17	20	build-depends: base >=4.7 && <5
18	21	, adnot
19	22	, bytestring

24	27	, process
25	28	, text
26	29	, vector
	30	hs-source-dirs: src
	31	ghc-options: -Wall
27	32	default-language: Haskell2010
28		default-extensions: ScopedTypeVariables
29		exposed-modules: Collage
30		, Collage.Config
31		, Collage.Opts
32		, Collage.Commands.Test
33		, Collage.Commands.Splice
34	33
35	34	executable collage
36	35	hs-source-dirs: collage
37	36	main-is: Main.hs
38	37	default-language: Haskell2010
39		default-extensions: ScopedTypeVariables
40	38	ghc-options: -Wall
41	39	build-depends: base >=4.7 && <5
42	40	, collage

-0

example/s2/Main.hs less more

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

+108

-2

src/Collage/Commands/Splice.hs less more

1		module Collage.Commands.Splice (runSplice) where
	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Collage.Commands.Splice (runSplice, findFragments) 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 qualified System.Exit as Sys
	11	import System.FilePath ((</>))
	12	import qualified System.FilePath as Sys
2	13
3	14	import Collage.Config
4	15	import Collage.Opts
5	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	toIdent :: T.Text -> TL.Text
	25	toIdent = TL.fromStrict . T.cons '«' . flip T.snoc '»'
	26
	27	findFragments :: FilePath -> T.Text -> [Source] -> Either String (IO TL.Text)
	28	findFragments root s sources = case (T.splitOn "/" s) of
	29	[] -> error "(should not happen)"
	30	(x:rs) -> case [ src
	31	\| src@Source { sourceName = n } <- sources
	32	, n == x
	33	] of
	34	[src] -> go src rs (sourceExpose src)
	35	[] -> Left ("Unable to find source named " ++ T.unpack x)
	36	_ -> Left ("Ambiguous source name: " ++ T.unpack x)
	37	where
	38	go :: Source -> [T.Text] -> Expose -> Either String (IO TL.Text)
	39	go q [] (ExposeFile path) =
	40	return (TL.readFile (root </> sourceDir q </> path))
	41	go _ [] ExposeSections{} =
	42	Left $ concat [ "Splice identifier «"
	43	, T.unpack s
	44	, "» matches a file with sections, but "
	45	, "does not specify a section!"
	46	]
	47	go _ [] NamedMap{} =
	48	Left $ concat [ "Splice identifier «"
	49	, T.unpack s
	50	, "» matches a map, but does not specify "
	51	, "a key!"
	52	]
	53
	54	go q [section] (ExposeSections path) =
	55	return (readSection (root </> sourceDir q </> path) section)
	56
	57	go _ (_:_) (ExposeSections path) =
	58	Left $ concat [ "Splice identifier «"
	59	, T.unpack s
	60	, "» indexes too far into the path "
	61	, path
	62	, "!"
	63	]
	64
	65	go _ (_:_) (ExposeFile path) =
	66	Left $ concat [ "Splice identifier «"
	67	, T.unpack s
	68	, "» indexes too far into the file "
	69	, path
	70	, "!"
	71	]
	72
	73	go q (k:rs) (NamedMap m)
	74	\| Just e <- M.lookup k m = go q rs e
	75	\| otherwise = Left $ concat
	76	[ "Splice identifier «"
	77	, T.unpack s
	78	, "» references a key "
	79	, T.unpack k
	80	, " which cannot be found."
	81	]
	82
	83	doReplacements :: FilePath -> [Source] -> TL.Text -> IO TL.Text
	84	doReplacements root e original =
	85	foldM doReplace original (findFragmentIdentifiers original)
	86	where
	87	doReplace file frag = do
	88	new <- case findFragments root frag e of
	89	Left err -> Sys.die err
	90	Right x -> x
	91	return (TL.replace (toIdent frag) new file)
	92
	93	readSection :: FilePath -> T.Text -> IO TL.Text
	94	readSection path f = do
	95	contents <- TL.readFile path
	96	case TL.breakOn (toIdent f) contents of
	97	(_, "") -> Sys.die $ unwords [ "Unable to find section"
	98	, show f
	99	, "in file"
	100	, path
	101	]
	102	(_, rs) ->
	103	let (_, skipLine) = TL.breakOn "\n" rs
	104	(section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)
	105	(skipLine', _) = TL.breakOnEnd "\n" section
	106	in return (TL.init skipLine')
	107
6	108	runSplice :: Config -> Options -> IO ()
7		runSplice ~~_ _ = putStrLn "Unimplemented!"~~
	109	runSplice conf opts = do
	110	let root = Sys.takeDirectory (optFile opts)
	111	f <- TL.readFile (root </> confDocument conf)
	112	rs <- doReplacements root (confSources conf) f
	113	TL.putStrLn rs

-1

src/Collage/Commands/Test.hs less more

12	12
13	13	runTest :: Config -> Options -> IO ()
14	14	runTest conf _ = do
15		dbg ["testing", ~~T.unpack (confDocument conf)~~ ]
	15	dbg ["testing", confDocument conf ]
16	16	forM_ (confSources conf) $ \ samp -> do
17	17	dbg ["-", "building source", T.unpack (sourceName samp) ]
18	18	runCommand samp

-9

src/Collage/Config.hs less more

16	16	import qualified Data.Vector as V
17	17
18	18	data Config = Config
19		{ confDocument :: ~~T.Text~~
	19	{ confDocument :: FilePath
20	20	, confSources :: [Source]
21	21	} deriving (Eq, Show)
22	22

25	25	where
26	26	go payload
27	27	\| Just file <- payload V.!? 0
28		= Config <$> A.~~withString "file name" pure~~ file
	28	= Config <$> A.parseAdnot file
29	29	<*> mapM A.parseAdnot (V.toList (V.tail payload))
30	30	\| otherwise = Left "expected source file in config"
31	31

34	34	{ sourceName :: T.Text
35	35	, sourceDir :: FilePath
36	36	, sourceCommands :: [String]
37		, sourceExpose :: ~~[Expose]~~
	37	, sourceExpose :: Expose
38	38	} deriving (Eq, Show)
39	39
40	40	instance A.FromAdnot Source where

42	42	name <- p A..: "name"
43	43	dir <- p A..: "dir"
44	44	cmds <- p A..: "cmd"
45		expose <- p A..: "expose" ~~<\|> (fmap pure (p A..: "expose"))~~
	45	expose <- p A..: "expose"
46	46	return (Source name dir cmds expose)
47	47
48	48

64	64	sections = A.withSumNamed "exposed fragments" "sections" $ \ ps ->
65	65	case V.toList ps of
66	66	[] -> Left "Expected name for sections"
67		[f] -> Expose~~File~~ <$> A.parseAdnot f
	67	[f] -> ExposeSections <$> A.parseAdnot f
68	68	_ -> Left "Too many arguments to sections"
69	69
70	70	namedMap = A.withProduct "exposed fragments" $ \ p ->

75	75
76	76	getConfig :: FilePath -> IO (Either String Config)
77	77	getConfig loc = do
78		loc <- B.readFile loc
79		return (parseConfig loc)
	78	conf <- B.readFile loc
	79	return (parseConfig conf)
80	80
81	81	example :: Config
82	82	example = Config

86	86	{ sourceName = "rust-sample"
87	87	, sourceDir = "s1"
88	88	, sourceCommands = ["cargo clean", "cargo build"]
89		, sourceExpose = ~~[ExposeFile "src/main.rs"]~~
	89	, sourceExpose = ExposeFile "src/main.rs"
90	90	}
91	91	, Source
92	92	{ sourceName = "haskell-sample"
93	93	, sourceDir = "s2"
94	94	, sourceCommands = ["cabal new-build"]
95		, sourceExpose = ~~[ExposeSections "Main.hs"]~~
	95	, sourceExpose = ExposeSections "Main.hs"
96	96	}
97	97	]
98	98	}