diff --git a/anansi.cabal b/anansi.cabal --- a/anansi.cabal +++ b/anansi.cabal @@ -1,8 +1,8 @@ name: anansi -version: 0.4.1 +version: 0.4.2 license: GPL-3 license-file: license.txt -author: John Millikin +author: John Millikin , Dirk Laurie maintainer: John Millikin build-type: Simple cabal-version: >= 1.6 @@ -27,12 +27,12 @@ source-repository head type: bazaar - location: https://john-millikin.com/software/anansi/ + location: https://john-millikin.com/branches/anansi/0.4/ source-repository this type: bazaar location: https://john-millikin.com/branches/anansi/0.4/ - tag: anansi_0.4.1 + tag: anansi_0.4.2 library hs-source-dirs: lib @@ -57,6 +57,7 @@ Anansi.Loom.Debug Anansi.Loom.HTML Anansi.Loom.LaTeX + Anansi.Loom.Markdown Anansi.Loom.NoWeb Anansi.Main Anansi.Parser diff --git a/lib/Anansi.hs b/lib/Anansi.hs --- a/lib/Anansi.hs +++ b/lib/Anansi.hs @@ -51,6 +51,7 @@ , loomDebug , loomHTML , loomLaTeX + , loomMarkdown , loomNoWeb ) where @@ -60,6 +61,7 @@ import Anansi.Loom.Debug import Anansi.Loom.HTML import Anansi.Loom.LaTeX +import Anansi.Loom.Markdown import Anansi.Loom.NoWeb import Anansi.Main import Anansi.Parser @@ -73,6 +75,7 @@ -- [ (\"anansi.debug\", 'loomDebug') -- , (\"anansi.html\", 'loomHTML') -- , (\"anansi.latex\", 'loomLaTeX') +-- , (\"anansi.markdown\", 'loomMarkdown') -- , (\"anansi.noweb\", 'loomNoWeb') -- ] -- @ @@ -81,5 +84,6 @@ [ ("anansi.debug", loomDebug) , ("anansi.html", loomHTML) , ("anansi.latex", loomLaTeX) + , ("anansi.markdown", loomMarkdown) , ("anansi.noweb", loomNoWeb) ] diff --git a/lib/Anansi/Loom/Markdown.hs b/lib/Anansi/Loom/Markdown.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom/Markdown.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- 2011 Dirk Laurie +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Anansi.Loom.Markdown (loomMarkdown) where + +import Control.Monad (forM_) +import Control.Monad.Reader (asks) +import Control.Monad.Writer (tell) +import Data.ByteString (ByteString) +import Data.Monoid (mconcat) +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +import Anansi.Types + +-- | Generate Markdown. Modified from LaTeX.hs. +loomMarkdown :: Loom +loomMarkdown = mapM_ putBlock . documentBlocks where + putBlock b = case b of + BlockText text -> tell (encodeUtf8 text) + BlockFile path content -> do + tell "\n> **\xC2\xBB " + tell =<< escapeText path + tell "**\n\n" + putContent content + tell "\n" + BlockDefine name content -> do + tell "\n> **\xC2\xAB" + tell =<< escapeText name + tell "\xC2\xBB**\n\n" + putContent content + tell "\n" + + putContent cs = forM_ cs $ \c -> case c of + ContentText _ text -> do + tell "> " + escapeCode text >>= tell + tell "\n" + ContentMacro _ indent name -> formatMacro indent name >>= tell + + formatMacro indent name = do + escIndent <- escapeCode indent + escName <- escapeCode name + return (mconcat ["> ", escIndent, "\xC2\xAB", escName, "\xC2\xBB\n"]) + +escapeCode :: Text -> LoomM ByteString +escapeCode text = do + tabSize <- asks loomOptionTabSize + return $ encodeUtf8 $ Data.Text.concatMap (\c -> case c of + '\t' -> Data.Text.replicate (fromInteger tabSize) " " + _ -> Data.Text.singleton c) text + +escapeText :: Text -> LoomM ByteString +escapeText text = do + tabSize <- asks loomOptionTabSize + + return $ encodeUtf8 $ Data.Text.concatMap (\c -> case c of + '\t' -> Data.Text.replicate (fromInteger tabSize) " " + '\\' -> "\\\\" + '_' -> "\\_" + '*' -> "\\*" + '[' -> "\\[" + ']' -> "\\]" + '`' -> "\\`" + '&' -> "&" + _ -> Data.Text.singleton c) text diff --git a/lib/Anansi/Tangle.hs b/lib/Anansi/Tangle.hs --- a/lib/Anansi/Tangle.hs +++ b/lib/Anansi/Tangle.hs @@ -20,24 +20,29 @@ 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 Control.Monad.RWS as RWS import qualified Data.ByteString.Char8 as ByteString import Data.ByteString.Char8 (ByteString) import qualified Data.Map import Data.Map (Map) +import qualified Data.Text import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) +import qualified Text.Parsec as P import Filesystem.Path (FilePath) import qualified Filesystem.Path.CurrentOS as FP import Anansi.Types +-- macro definitions, #line pragma formatter type ContentMap = Map Text [Content] +data TangleEnv = TangleEnv ContentMap (Position -> Text) -data TangleState = TangleState Position ByteString ContentMap -type TangleT m a = W.WriterT ByteString (S.StateT TangleState m) a +-- current position, current indent +data TangleState = TangleState Position ByteString +type TangleT = RWS.RWST TangleEnv ByteString TangleState + buildMacros :: [Block] -> ContentMap buildMacros blocks = S.execState (mapM_ accumMacro blocks) Data.Map.empty @@ -74,53 +79,123 @@ -> Bool -- ^ Enable writing #line declarations -> Document -> m () -tangle writeFile' enableLine doc = S.evalStateT (mapM_ putFile files) initState where +tangle writeFile' enableLine doc = mapM_ putFile files where blocks = documentBlocks doc + state = TangleState (Position "" 0) "" - 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) + putFile (pathT, content) = do + let path = FP.fromText pathT + let env = TangleEnv macros (if enableLine + then formatPosition doc path + else const "\n") + (_, bytes) <- RWS.evalRWST (mapM_ putContent content) env state + writeFile' 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" +formatPosition :: Document -> FilePath -> Position -> Text +formatPosition doc = checkPath where + fmtC = "#line ${line} ${quoted-path}" + fmtGo = "//line ${path}:${line}" + defaultOptions = Data.Map.fromList + [ ("anansi.line-pragma-hs", fmtC) + , ("anansi.line-pragma-c", fmtC) + , ("anansi.line-pragma-cxx", fmtC) + , ("anansi.line-pragma-cpp", fmtC) + , ("anansi.line-pragma-cs", fmtC) + , ("anansi.line-pragma-pl", fmtC) + , ("anansi.line-pragma-go", fmtGo) + ] + opts = fmap compileTemplate (Data.Map.union (documentOptions doc) defaultOptions) + + checkPath path = case FP.extension path of + Just ext -> case Data.Map.lookup ("anansi.line-pragma-" `Data.Text.append` ext) opts of + Just tmpl -> checkPos tmpl + Nothing -> const "\n" + Nothing -> const "\n" + + checkPos tmpl pos = formatTemplate tmpl (templateParams pos) + + templateParams pos = Data.Map.fromList + [ ("line", show (positionLine pos)) + , ("path", Data.Text.unpack (either id id (FP.toText (positionFile pos)))) + , ("quoted-path", show (either id id (FP.toText (positionFile pos)))) + ] -putContent enableLine (ContentMacro pos indent name) = addIndent putMacro where +data TemplateChunk + = TemplateChunkConst Text + | TemplateChunkVar Text + +type Template = [TemplateChunk] + +compileTemplate :: Text -> Template +compileTemplate "" = [] +compileTemplate txt = check (P.parse parser "" (Data.Text.unpack txt)) where + check (Left _) = error "Internal error: compileTemplate failed." + check (Right tmpl) = tmpl + + parser = do + chunks <- P.many (P.choice [P.try twodollar, P.try var, dollar, text]) + P.eof + return chunks + twodollar = do + _ <- P.string "$$" + return (TemplateChunkConst "$") + dollar = do + _ <- P.char '$' + return (TemplateChunkConst "$") + var = do + _ <- P.string "${" + name <- P.many1 (P.satisfy (\c -> c == '-' || (c >= 'a' && c <= 'z'))) + _ <- P.char '}' + return (TemplateChunkVar (Data.Text.pack name)) + text = do + chars <- P.many1 (P.satisfy (/= '$')) + return (TemplateChunkConst (Data.Text.pack chars)) + +formatTemplate :: Template -> Map Text String -> Text +formatTemplate [] _ = "\n" +formatTemplate chunks vars = Data.Text.concat ("\n" : map formatChunk chunks ++ ["\n"]) where + formatChunk (TemplateChunkConst t) = t + formatChunk (TemplateChunkVar name) = case Data.Map.lookup name vars of + Just value -> Data.Text.pack value + Nothing -> Data.Text.concat ["${", name, "}"] + +putContent :: Monad m => Content -> TangleT m () +putContent (ContentText pos t) = do + TangleState _ indent <- RWS.get + putPosition pos + RWS.tell indent + RWS.tell (encodeUtf8 t) + RWS.tell "\n" + +putContent (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) + TangleState lastPos old <- RWS.get + RWS.put (TangleState lastPos (ByteString.append old (encodeUtf8 indent)) ) _ <- m - TangleState newPos _ _ <- S.get - S.put (TangleState newPos old macros) + TangleState newPos _ <- S.get + S.put (TangleState newPos old) putMacro = do - putPosition enableLine pos - lookupMacro name >>= mapM_ (putContent enableLine) + putPosition pos + lookupMacro name >>= mapM_ putContent -putPosition :: Monad m => Bool -> Position -> TangleT m () -putPosition enableLine pos = do - TangleState lastPos indent macros <- S.get +putPosition :: Monad m => Position -> TangleT m () +putPosition pos = do + TangleState lastPos indent <- RWS.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) + RWS.put (TangleState pos indent) if pos == expectedPos then return () - else W.tell (ByteString.pack line) + else do + TangleEnv _ format <- RWS.ask + RWS.tell (encodeUtf8 (format pos)) lookupMacro :: Monad m => Text -> TangleT m [Content] lookupMacro name = do - TangleState _ _ macros <- S.get + TangleEnv macros _ <- RWS.ask case Data.Map.lookup name macros of Nothing -> error ("unknown macro: " ++ show name) Just content -> return content diff --git a/lib/Anansi/Types.hs b/lib/Anansi/Types.hs --- a/lib/Anansi/Types.hs +++ b/lib/Anansi/Types.hs @@ -136,7 +136,9 @@ parseLoomOptions :: Map Text Text -> LoomOptions parseLoomOptions opts = LoomOptions - { loomOptionTabSize = case Data.Map.lookup "tab-size" opts of + { loomOptionTabSize = case Data.Map.lookup "anansi.tab-size" opts of Just x -> read (Data.Text.unpack x) - Nothing -> 8 + Nothing -> case Data.Map.lookup "tab-size" opts of + Just x -> read (Data.Text.unpack x) + Nothing -> 8 }