module Anansi.Tangle (tangle) where
import Prelude hiding (FilePath)
import qualified Control.Monad.State as S
import Control.Monad.Trans (lift)
import qualified Control.Monad.Writer as W
import qualified Data.ByteString.Char8 as ByteString
import Data.ByteString.Char8 (ByteString)
import qualified Data.Map
import Data.Map (Map)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Filesystem.Path (FilePath)
import qualified Filesystem.Path.CurrentOS as FP
import Anansi.Types
type ContentMap = Map Text [Content]
data TangleState = TangleState Position ByteString ContentMap
type TangleT m a = W.WriterT ByteString (S.StateT TangleState m) a
buildMacros :: [Block] -> ContentMap
buildMacros blocks = S.execState (mapM_ accumMacro blocks) Data.Map.empty
accumMacro :: Block -> S.State ContentMap ()
accumMacro b = case b of
BlockText _ -> return ()
BlockFile _ _ -> return ()
BlockDefine name content -> do
macros <- S.get
S.put (Data.Map.insertWith (\new old -> old ++ new) name content macros)
buildFiles :: [Block] -> ContentMap
buildFiles blocks = S.execState (mapM_ accumFile blocks) Data.Map.empty
accumFile :: Block -> S.State ContentMap ()
accumFile b = case b of
BlockText _ -> return ()
BlockDefine _ _ -> return ()
BlockFile name content -> do
let accum new old = old ++ new
files <- S.get
S.put (Data.Map.insertWith accum name content files)
tangle :: Monad m
=> (FilePath -> ByteString -> m ())
-> Bool
-> Document
-> m ()
tangle writeFile' enableLine doc = S.evalStateT (mapM_ putFile files) initState where
blocks = documentBlocks doc
initState = (TangleState (Position "" 0) "" macros)
fileMap = buildFiles blocks
macros = buildMacros blocks
files = Data.Map.toAscList fileMap
putFile (path, content) = do
bytes <- W.execWriterT (mapM_ (putContent enableLine) content)
lift (writeFile' (FP.fromText path) bytes)
putContent :: Monad m => Bool -> Content -> TangleT m ()
putContent enableLine (ContentText pos t) = do
TangleState _ indent _ <- S.get
putPosition enableLine pos
W.tell indent
W.tell (encodeUtf8 t)
W.tell "\n"
putContent enableLine (ContentMacro pos indent name) = addIndent putMacro where
addIndent m = do
TangleState lastPos old macros <- S.get
S.put (TangleState lastPos (ByteString.append old (encodeUtf8 indent)) macros)
_ <- m
TangleState newPos _ _ <- S.get
S.put (TangleState newPos old macros)
putMacro = do
putPosition enableLine pos
lookupMacro name >>= mapM_ (putContent enableLine)
putPosition :: Monad m => Bool -> Position -> TangleT m ()
putPosition enableLine pos = do
TangleState lastPos indent macros <- S.get
let expectedPos = Position (positionFile lastPos) (positionLine lastPos + 1)
let filename = either id id (FP.toText (positionFile pos))
let line = if enableLine
then "\n#line " ++ show (positionLine pos) ++ " " ++ show filename ++ "\n"
else "\n"
S.put (TangleState pos indent macros)
if pos == expectedPos
then return ()
else W.tell (ByteString.pack line)
lookupMacro :: Monad m => Text -> TangleT m [Content]
lookupMacro name = do
TangleState _ _ macros <- S.get
case Data.Map.lookup name macros of
Nothing -> error ("unknown macro: " ++ show name)
Just content -> return content