Implement naive and largely terrible Splice function

collage.cabal

@@ -1,19 +1,22 @@
 cabal-version: 2.2
 name: collage
 version: 0.1.0.0
+synopsis: A tool for assembling documents out of working, testable code
 -- description:
 license: BSD-3-Clause
 author: Getty Ritter <gettylefou@gmail.com>
 maintainer: Getty Ritter <gettylefou@gmail.com>
 copyright: @2018 Getty Ritter
+category: Text
 build-type: Simple
 
 
 library
-  hs-source-dirs: src
-  ghc-options: -Wall
+  exposed-modules: Collage
+                 , Collage.Config
+                 , Collage.Opts
+                 , Collage.Commands.Test
+                 , Collage.Commands.Splice
   build-depends: base >=4.7 && <5
                , adnot
                , bytestring
@@ -24,19 +27,14 @@ library
                , process
                , text
                , vector
+  hs-source-dirs: src
+  ghc-options: -Wall
   default-language: Haskell2010
-  default-extensions: ScopedTypeVariables
-  exposed-modules: Collage
-                 , Collage.Config
-                 , Collage.Opts
-                 , Collage.Commands.Test
-                 , Collage.Commands.Splice
 
 executable collage
   hs-source-dirs: collage
   main-is: Main.hs
   default-language: Haskell2010
-  default-extensions: ScopedTypeVariables
   ghc-options: -Wall
   build-depends: base >=4.7 && <5
                , collage

example/s2/Main.hs

@@ -1,4 +1,8 @@
+-- «front-matter»
 module Main where
+-- «end»
 
+-- «functions»
 main :: IO ()
 main = return ()
+-- «end»

src/Collage/Commands/Splice.hs

@@ -1,7 +1,113 @@
-module Collage.Commands.Splice (runSplice) where
+{-# LANGUAGE OverloadedStrings #-}
+
+module Collage.Commands.Splice (runSplice, findFragments) where
+
+import           Control.Monad (foldM)
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
+import qualified System.Exit as Sys
+import           System.FilePath ((</>))
+import qualified System.FilePath as Sys
 
 import Collage.Config
 import Collage.Opts
 
+findFragmentIdentifiers :: TL.Text -> [T.Text]
+findFragmentIdentifiers t
+  | (_, rs) <- TL.break (== '«') t
+  , (f, rs') <- TL.break (== '»') (TL.drop 1 rs)
+  , not (TL.null f) = TL.toStrict f : findFragmentIdentifiers rs'
+  | otherwise = []
+
+toIdent :: T.Text -> TL.Text
+toIdent = TL.fromStrict . T.cons '«' . flip T.snoc '»'
+
+findFragments :: FilePath -> T.Text -> [Source] -> Either String (IO TL.Text)
+findFragments root s sources = case (T.splitOn "/" s) of
+    [] -> error "(should not happen)"
+    (x:rs) -> case [ src
+                   | src@Source { sourceName = n } <- sources
+                   , n == x
+                   ] of
+               [src] -> go src rs (sourceExpose src)
+               []  -> Left ("Unable to find source named " ++ T.unpack x)
+               _   -> Left ("Ambiguous source name: " ++ T.unpack x)
+  where
+    go :: Source -> [T.Text] -> Expose -> Either String (IO TL.Text)
+    go q [] (ExposeFile path) =
+      return (TL.readFile (root </> sourceDir q </> path))
+    go _ [] ExposeSections{} =
+      Left $ concat [ "Splice identifier «"
+                    , T.unpack s
+                    , "» matches a file with sections, but "
+                    , "does not specify a section!"
+                    ]
+    go _ [] NamedMap{} =
+      Left $ concat [ "Splice identifier «"
+                    , T.unpack s
+                    , "» matches a map, but does not specify "
+                    , "a key!"
+                    ]
+
+    go q [section] (ExposeSections path) =
+      return (readSection (root </> sourceDir q </> path) section)
+
+    go _ (_:_) (ExposeSections path) =
+      Left $ concat [ "Splice identifier «"
+                    , T.unpack s
+                    , "» indexes too far into the path "
+                    , path
+                    , "!"
+                    ]
+
+    go _ (_:_) (ExposeFile path) =
+      Left $ concat [ "Splice identifier «"
+                    , T.unpack s
+                    , "» indexes too far into the file "
+                    , path
+                    , "!"
+                    ]
+
+    go q (k:rs) (NamedMap m)
+      | Just e <- M.lookup k m = go q rs e
+      | otherwise = Left $ concat
+                    [ "Splice identifier «"
+                    , T.unpack s
+                    , "» references a key "
+                    , T.unpack k
+                    , " which cannot be found."
+                    ]
+
+doReplacements :: FilePath -> [Source] -> TL.Text -> IO TL.Text
+doReplacements root e original =
+  foldM doReplace original (findFragmentIdentifiers original)
+  where
+    doReplace file frag = do
+      new <- case findFragments root frag e of
+        Left err -> Sys.die err
+        Right x  -> x
+      return (TL.replace (toIdent frag) new file)
+
+readSection :: FilePath -> T.Text -> IO TL.Text
+readSection path f = do
+  contents <- TL.readFile path
+  case TL.breakOn (toIdent f) contents of
+    (_, "") -> Sys.die $ unwords [ "Unable to find section"
+                                 , show f
+                                 , "in file"
+                                 , path
+                                 ]
+    (_, rs) ->
+      let (_, skipLine) = TL.breakOn "\n" rs
+          (section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)
+          (skipLine', _) = TL.breakOnEnd "\n" section
+      in return (TL.init skipLine')
+
 runSplice :: Config -> Options -> IO ()
-runSplice _ _ = putStrLn "Unimplemented!"
+runSplice conf opts = do
+  let root = Sys.takeDirectory (optFile opts)
+  f <- TL.readFile (root </> confDocument conf)
+  rs <- doReplacements root (confSources conf) f
+  TL.putStrLn rs

src/Collage/Commands/Test.hs

@@ -12,7 +12,7 @@ dbg = putStrLn . unwords
 
 runTest :: Config -> Options -> IO ()
 runTest conf _ = do
-  dbg ["testing", T.unpack (confDocument conf) ]
+  dbg ["testing", confDocument conf ]
   forM_ (confSources conf) $ \ samp -> do
     dbg ["-", "building source", T.unpack (sourceName samp) ]
     runCommand samp

src/Collage/Config.hs

@@ -16,7 +16,7 @@ import qualified Data.Text as T
 import qualified Data.Vector as V
 
 data Config = Config
-  { confDocument :: T.Text
+  { confDocument :: FilePath
   , confSources :: [Source]
   } deriving (Eq, Show)
 
@@ -25,7 +25,7 @@ instance A.FromAdnot Config where
     where
       go payload
         | Just file <- payload V.!? 0
-        = Config <$> A.withString "file name" pure file
+        = Config <$> A.parseAdnot file
                  <*> mapM A.parseAdnot (V.toList (V.tail payload))
         | otherwise = Left "expected source file in config"
 
@@ -34,7 +34,7 @@ data Source = Source
   { sourceName     :: T.Text
   , sourceDir      :: FilePath
   , sourceCommands :: [String]
-  , sourceExpose   :: [Expose]
+  , sourceExpose   :: Expose
   } deriving (Eq, Show)
 
 instance A.FromAdnot Source where
@@ -42,7 +42,7 @@ instance A.FromAdnot Source where
     name   <- p A..: "name"
     dir    <- p A..: "dir"
     cmds   <- p A..: "cmd"
-    expose <- p A..: "expose" <|> (fmap pure (p A..: "expose"))
+    expose <- p A..: "expose"
     return (Source name dir cmds expose)
 
 
@@ -64,7 +64,7 @@ instance A.FromAdnot Expose where
       sections = A.withSumNamed "exposed fragments" "sections" $ \ ps ->
         case V.toList ps of
           []  -> Left "Expected name for sections"
-          [f] -> ExposeFile <$> A.parseAdnot f
+          [f] -> ExposeSections <$> A.parseAdnot f
           _   -> Left "Too many arguments to sections"
 
       namedMap = A.withProduct "exposed fragments" $ \ p ->
@@ -75,8 +75,8 @@ parseConfig = A.decode
 
 getConfig :: FilePath -> IO (Either String Config)
 getConfig loc = do
-  loc <- B.readFile loc
-  return (parseConfig loc)
+  conf <- B.readFile loc
+  return (parseConfig conf)
 
 example :: Config
 example = Config
@@ -86,13 +86,13 @@ example = Config
         { sourceName = "rust-sample"
         , sourceDir = "s1"
         , sourceCommands = ["cargo clean", "cargo build"]
-        , sourceExpose = [ExposeFile "src/main.rs"]
+        , sourceExpose = ExposeFile "src/main.rs"
         }
     , Source
         { sourceName = "haskell-sample"
         , sourceDir = "s2"
         , sourceCommands = ["cabal new-build"]
-        , sourceExpose = [ExposeSections "Main.hs"]
+        , sourceExpose = ExposeSections "Main.hs"
         }
     ]
   }