diff --git a/Anansi.hs b/Anansi.hs deleted file mode 100644 --- a/Anansi.hs +++ /dev/null @@ -1,43 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 - ( Block (..) - , Content (..) - , Position (..) - - , ParseError (..) - , parseFile - - , Loom (..) - , looms - , loomDebug - , loomHTML - , loomLaTeX - , loomNoWeb - - , tangle - ) where -import Anansi.Types -import Anansi.Loom -import Anansi.Loom.Debug -import Anansi.Loom.HTML -import Anansi.Loom.LaTeX -import Anansi.Loom.NoWeb -import Anansi.Parser -import Anansi.Tangle - -looms :: [Loom] -looms = [loomDebug, loomHTML, loomLaTeX, loomNoWeb] diff --git a/Anansi/Loom.hs b/Anansi/Loom.hs deleted file mode 100644 --- a/Anansi/Loom.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 - ( Loom (..) - ) where -import Control.Monad.Writer -import Data.Text.Lazy (Text) -import Anansi.Types - -data Loom = Loom - { loomName :: Text - , loomWeave :: [Block] -> Writer Text () - } diff --git a/Anansi/Loom/Debug.hs b/Anansi/Loom/Debug.hs deleted file mode 100644 --- a/Anansi/Loom/Debug.hs +++ /dev/null @@ -1,28 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Anansi.Loom.Debug (loomDebug) where -import Data.Text.Lazy (pack) -import Control.Monad (forM_) -import Control.Monad.Writer (tell) -import Anansi.Loom - -loomDebug :: Loom -loomDebug = Loom "debug" $ \blocks -> do - tell "\nweaving\n" - tell "==========================\n" - forM_ blocks $ \b -> do - tell . pack $ show b ++ "\n" diff --git a/Anansi/Loom/HTML.hs b/Anansi/Loom/HTML.hs deleted file mode 100644 --- a/Anansi/Loom/HTML.hs +++ /dev/null @@ -1,54 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Anansi.Loom.HTML (loomHTML) where -import qualified Data.Text.Lazy as TL -import Control.Monad (forM_) -import Control.Monad.Writer (tell) -import Anansi.Types -import Anansi.Loom - -loomHTML :: Loom -loomHTML = Loom "html" $ mapM_ putBlock where - putBlock b = case b of - BlockText text -> tell text - BlockFile path content -> let - label = TL.concat ["» ", escape path, ""] - in putContent label content - BlockDefine name content -> let - label = TL.concat ["«", escape name, "»"] - in putContent label content - - putContent label cs = do - tell "
"
-		tell label
-		tell "\n"
-		forM_ cs $ \c -> case c of
-			ContentText _ text -> tell . escape $ TL.append text "\n"
-			ContentMacro _ indent name -> tell $ formatMacro indent name
-		tell "
" - -formatMacro :: TL.Text -> TL.Text -> TL.Text -formatMacro indent name = TL.concat [indent, "«", escape name, "»\n"] - -escape :: TL.Text -> TL.Text -escape = TL.concatMap $ \c -> case c of - '&' -> "&" - '<' -> "<" - '>' -> ">" - '"' -> """ - '\'' -> "'" - _ -> TL.singleton c diff --git a/Anansi/Loom/LaTeX.hs b/Anansi/Loom/LaTeX.hs deleted file mode 100644 --- a/Anansi/Loom/LaTeX.hs +++ /dev/null @@ -1,58 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Anansi.Loom.LaTeX (loomLaTeX) where -import qualified Data.Text.Lazy as TL -import Control.Monad (forM_) -import Control.Monad.Writer (tell) -import Anansi.Types -import Anansi.Loom - -loomLaTeX :: Loom -loomLaTeX = Loom "latex" $ mapM_ putBlock where - putBlock b = case b of - BlockText text -> tell text - BlockFile path content -> do - tell "\\begin{alltt}\n" - tell "{\\bf\\(\\gg\\) " - tell $ escape path - tell "}\n" - putContent content - tell "\\end{alltt}\n" - - BlockDefine name content -> do - tell "\\begin{alltt}\n" - tell "{\\bf\\(\\ll\\)" - tell $ escape name - tell "\\(\\gg\\)}\n" - putContent content - tell "\\end{alltt}\n" - - putContent cs = forM_ cs $ \c -> case c of - ContentText _ text -> tell . escape $ TL.append text "\n" - ContentMacro _ indent name -> tell $ formatMacro indent name - -formatMacro :: TL.Text -> TL.Text -> TL.Text -formatMacro indent name = TL.concat [escape indent, "|\\emph{", escape name, "}|\n"] - -escape :: TL.Text -> TL.Text -escape = TL.concatMap $ \c -> case c of - '\t' -> " " - '\\' -> "\\textbackslash{}" - '{' -> "\\{" - '}' -> "\\}" - '_' -> "\\_" - _ -> TL.singleton c diff --git a/Anansi/Loom/NoWeb.hs b/Anansi/Loom/NoWeb.hs deleted file mode 100644 --- a/Anansi/Loom/NoWeb.hs +++ /dev/null @@ -1,68 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Anansi.Loom.NoWeb (loomNoWeb) where -import qualified Data.Text.Lazy as TL -import Control.Monad (forM_) -import Control.Monad.Writer (tell) -import Anansi.Types -import Anansi.Loom - -loomNoWeb :: Loom -loomNoWeb = Loom "latex-noweb" $ mapM_ putBlock where - putBlock b = case b of - BlockText text -> tell text - BlockFile path content -> do - tell "\\nwbegincode{0}\\moddef{" - tell $ escapeText path - tell "}\\endmoddef\\nwstartdeflinemarkup\\nwenddeflinemarkup\n" - putContent content - tell "\\nwendcode{}\n" - - BlockDefine name content -> do - tell "\\nwbegincode{0}\\moddef{" - tell $ escapeText name - tell "}\\endmoddef\\nwstartdeflinemarkup\\nwenddeflinemarkup\n" - putContent content - tell "\\nwendcode{}\n" - - putContent cs = forM_ cs $ \c -> case c of - ContentText _ text -> tell . escapeCode $ TL.append text "\n" - ContentMacro _ indent name -> tell $ formatMacro indent name - -formatMacro :: TL.Text -> TL.Text -> TL.Text -formatMacro indent name = TL.concat [escapeCode indent, "\\LA{}", escapeText name, "\\RA{}\n"] - -escapeCode :: TL.Text -> TL.Text -escapeCode = TL.concatMap $ \c -> case c of - '\t' -> " " - '\\' -> "\\\\" - '{' -> "\\{" - '}' -> "\\}" - '_' -> "\\_" - _ -> TL.singleton c - -escapeText :: TL.Text -> TL.Text -escapeText = TL.concatMap $ \c -> case c of - '\t' -> " " - '\\' -> "\\\\" - '{' -> "\\{" - '}' -> "\\}" - '_' -> "\\_" - '<' -> "{$<$}" - '>' -> "{$>$}" - '$' -> "\\$" - _ -> TL.singleton c diff --git a/Anansi/Parser.hs b/Anansi/Parser.hs deleted file mode 100644 --- a/Anansi/Parser.hs +++ /dev/null @@ -1,214 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Anansi.Parser - ( ParseError (..) - , parseFile - ) where -import Prelude hiding (FilePath) -import Control.Applicative ((<|>), (<$>)) -import Control.Monad.Trans (lift) -import qualified Control.Monad.State as S -import qualified Control.Exception as E -import Data.List (unfoldr) -import Data.Typeable (Typeable) -import qualified Text.Parsec as P -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Map as Map -import System.FilePath (replaceFileName) -import Anansi.Types -import Anansi.Util - -data ParseError = ParseError - { parseErrorPosition :: Position - , parseErrorMessage :: TL.Text - } - deriving (Show) - --- too lazy to write proper error handling -data ParseExc = ParseExc ParseError - deriving (Typeable, Show) - -instance E.Exception ParseExc - -data Command - = CommandInclude TL.Text - | CommandFile TL.Text - | CommandDefine TL.Text - | CommandColon - | CommandEndBlock - | CommandComment - deriving (Show) - -data Line - = LineCommand Position Command - | LineText Position TL.Text - deriving (Show) - -untilChar :: Char -> P.Parsec String u TL.Text -untilChar c = TL.pack <$> P.manyTill P.anyChar (P.try (P.char c)) - -getPosition :: Monad m => P.ParsecT s u m Position -getPosition = do - pos <- P.getPosition - return $ Position (TL.pack (P.sourceName pos)) (toInteger (P.sourceLine pos)) - -parseLines :: P.Parsec String u [Line] -parseLines = do - lines' <- P.many parseLine - P.eof - return lines' - -parseLine :: P.Parsec String u Line -parseLine = command <|> text where - command = do - P.char ':' - pos <- getPosition - LineCommand pos <$> parseCommand - - text = do - pos <- getPosition - line <- untilChar '\n' - return . LineText pos $ TL.append line "\n" - -parseCommand :: P.Parsec String u Command -parseCommand = parsed where - string = P.try . P.string - parsed = P.choice [file, include, define, colon, comment, endBlock] - file = do - string "file " <|> string "f " - CommandFile <$> untilChar '\n' - - include = do - string "include " <|> string "i " - CommandInclude <$> untilChar '\n' - - define = do - string "define " <|> string "d " - -- TODO: verify no '|' in name - CommandDefine <$> untilChar '\n' - - colon = do - P.char ':' - return $ CommandColon - - comment = do - P.char '#' - untilChar '\n' - return $ CommandComment - - endBlock = do - line <- untilChar '\n' - if TL.all isSpace line - then return $ CommandEndBlock - else do - pos <- getPosition - let msg = TL.pack $ "unknown command: " ++ show (TL.append ":" line) - E.throw $ ParseExc $ ParseError pos msg - --- TODO: more unicode support -isSpace :: Char -> Bool -isSpace ' ' = True -isSpace '\t' = True -isSpace _ = False - -parseBlocks :: [Line] -> Maybe (Either ParseError Block, [Line]) -parseBlocks [] = Nothing -parseBlocks (line:xs) = parsed where - parsed = case line of - LineText _ text -> Just (Right $ BlockText text, xs) - LineCommand pos cmd -> case cmd of - CommandFile path -> parseContent pos (BlockFile path) xs - CommandDefine name -> parseContent pos (BlockDefine name) xs - CommandColon -> Just (Right $ BlockText ":", xs) - CommandEndBlock -> Just (Right $ BlockText "\n", xs) - CommandComment -> Just (Right $ BlockText "", xs) - CommandInclude _ -> let - msg = "unexpected CommandInclude (internal error)" - in Just (Left $ ParseError pos msg, []) - -parseContent :: Position -> ([Content] -> Block) -> [Line] -> Maybe (Either ParseError Block, [Line]) -parseContent start block = parse [] where - parse acc [] = Just (Right $ block acc, []) - parse acc (line:xs) = case line of - LineText pos text -> case parse' pos text of - Left err -> Just (Left err, []) - Right parsed -> parse (acc ++ [parsed]) xs - LineCommand _ CommandEndBlock -> Just (Right $ block acc, xs) - LineCommand _ _ -> let - msg = "Unterminated content block" - in Just (Left $ ParseError start msg, []) - - parse' pos text = case P.parse (parser pos) "" (TL.unpack text) of - Right content -> Right content - Left err -> let - msg = TL.pack $ "Invalid content line " ++ show text ++ ": " ++ show err - in Left $ ParseError pos msg - - parser pos = do - content <- contentMacro pos <|> contentText pos - P.optional $ P.char '\n' - P.eof - return content - - contentMacro pos = do - (indent, c) <- P.try $ do - indent <- P.many $ P.satisfy isSpace - P.char '|' - c <- P.satisfy (not . isSpace) - return (indent, c) - name <- untilChar '|' - return $ ContentMacro pos (TL.pack indent) (TL.strip (TL.cons c name)) - - contentText pos = do - text <- untilChar '\n' - return . ContentText pos $ text - -type FilePath = TL.Text -type FileMap = Map.Map FilePath [Line] - -genLines :: Monad m => (FilePath -> m [Line]) -> FilePath -> S.StateT FileMap m [Line] -genLines getLines = genLines' where - genLines' path = lift (getLines path) >>= concatMapM (resolveIncludes path) - - relative x y = TL.pack $ replaceFileName (TL.unpack x) (TL.unpack y) - - resolveIncludes root line = case line of - LineCommand _ (CommandInclude path) -> genLines' $ relative root path - _ -> return [line] - -parseFile :: TL.Text -> IO (Either ParseError [Block]) -parseFile root = io where - io = E.handle onError $ do - lines' <- S.evalStateT (genLines getLines root) Map.empty - return . catEithers $ unfoldr parseBlocks lines' - - onError (ParseExc err) = return $ Left err - - getLines :: FilePath -> IO [Line] - getLines path = do - -- TODO: encode 'path' into UTF-8? - let path' = TL.unpack path - bytes <- B.readFile path' - case P.parse parseLines path' (T.unpack $ TE.decodeUtf8 bytes) of - Right x -> return x - Left err -> let - msg = TL.pack $ "getLines parse failed (internal error): " ++ show err - in E.throw $ ParseExc $ ParseError (Position path 0) msg diff --git a/Anansi/Tangle.hs b/Anansi/Tangle.hs deleted file mode 100644 --- a/Anansi/Tangle.hs +++ /dev/null @@ -1,103 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Anansi.Tangle (tangle) where -import Control.Monad (when) -import Control.Monad.Trans (lift) -import qualified Control.Monad.State as S -import qualified Control.Monad.Writer as W -import qualified Data.Text.Lazy as TL -import qualified Data.Map as Map -import Anansi.Types - -type ContentMap = Map.Map TL.Text [Content] - -data TangleState = TangleState Position TL.Text ContentMap -type TangleT m a = W.WriterT TL.Text (S.StateT TangleState m) a - -buildMacros :: [Block] -> ContentMap -buildMacros blocks = S.execState (mapM_ accumMacro blocks) 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 $ Map.insertWith (\new old -> old ++ new) name content macros - -buildFiles :: [Block] -> ContentMap -buildFiles blocks = S.execState (mapM_ accumFile blocks) 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 $ Map.insertWith accum name content files - -tangle :: Monad m - => (TL.Text -> TL.Text -> m ()) - -> Bool -- ^ Enable writing #line declarations - -> [Block] - -> m () -tangle writeFile' enableLine blocks = S.evalStateT (mapM_ putFile files) initState where - initState = (TangleState (Position "" 0) "" macros) - fileMap = buildFiles blocks - macros = buildMacros blocks - files = Map.toAscList fileMap - - putFile (path, content) = do - text <- W.execWriterT (mapM_ (putContent enableLine) content) - lift $ writeFile' path text - -putContent :: Monad m => Bool -> Content -> TangleT m () -putContent enableLine (ContentText pos t) = do - TangleState _ indent _ <- S.get - when enableLine $ putPosition pos - W.tell indent - W.tell 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 (TL.append old indent) macros - m - TangleState newPos _ _ <- S.get - S.put $ TangleState newPos old macros - putMacro = do - when enableLine $ putPosition pos - lookupMacro name >>= mapM_ (putContent enableLine) - -putPosition :: Monad m => Position -> TangleT m () -putPosition pos = do - TangleState lastPos indent macros <- S.get - let expectedPos = Position (positionFile lastPos) (positionLine lastPos + 1) - let line = "\n#line " ++ show (positionLine pos) ++ " " ++ show (positionFile pos) ++ "\n" - S.put $ TangleState pos indent macros - if pos == expectedPos - then return () - else W.tell $ TL.pack line - -lookupMacro :: Monad m => TL.Text -> TangleT m [Content] -lookupMacro name = do - TangleState _ _ macros <- S.get - case Map.lookup name macros of - Nothing -> error $ "unknown macro: " ++ show name - Just content -> return content diff --git a/Anansi/Types.hs b/Anansi/Types.hs deleted file mode 100644 --- a/Anansi/Types.hs +++ /dev/null @@ -1,38 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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.Types - ( Block (..) - , Content (..) - , Position (..) - ) where -import Data.Text.Lazy (Text) - -data Block - = BlockText Text - | BlockFile Text [Content] - | BlockDefine Text [Content] - deriving (Show) - -data Content - = ContentText Position Text - | ContentMacro Position Text Text - deriving (Show) - -data Position = Position - { positionFile :: Text - , positionLine :: Integer - } - deriving (Show, Eq) diff --git a/Anansi/Util.hs b/Anansi/Util.hs deleted file mode 100644 --- a/Anansi/Util.hs +++ /dev/null @@ -1,36 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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.Util - ( concatMapM - , replace - , catEithers - ) where -import Control.Monad (liftM) - -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat $ mapM f xs - -replace :: Eq a => a -> [a] -> [a] -> [a] -replace from to xs = flip concatMap xs $ \x -> if x == from - then to - else [x] - -catEithers :: [Either e a] -> Either e [a] -catEithers = cat' [] where - cat' acc [] = Right $ reverse acc - cat' acc (e:es) = case e of - Left err -> Left err - Right x -> cat' (x : acc) es diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,167 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- 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 . --- -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Anansi -import Anansi.Util - -import Control.Monad (unless) -import Control.Monad.Writer -import Control.Monad.Trans (MonadIO, liftIO) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO -import Data.Text.Lazy.Encoding (encodeUtf8) -import qualified Data.ByteString.Lazy as BL - -import System.Console.GetOpt -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.IO hiding (withFile) - -data Output = Tangle | Weave - -data Option - = OptionOutput Output - | OptionOutputPath TL.Text - | OptionLoom TL.Text - | OptionNoLines - -optionInfo :: [OptDescr Option] -optionInfo = - [ Option ['t'] ["tangle"] (NoArg (OptionOutput Tangle)) - "Generate tangled source code (default)" - , Option ['w'] ["weave"] (NoArg (OptionOutput Weave)) - "Generate woven markup" - , Option ['o'] ["out", "output"] (ReqArg (OptionOutputPath . TL.pack) "PATH") - "Output path (directory for tangle, file for weave)" - , Option ['l'] ["loom"] (ReqArg (OptionLoom . TL.pack) "NAME") - "Which loom should be used to weave output" - , Option [] ["noline"] (NoArg OptionNoLines) - "Disable generating #line declarations in tangled code" - ] - -usage :: String -> String -usage name = "Usage: " ++ name ++ " [OPTION...]" - -getOutput :: [Option] -> Output -getOutput [] = Tangle -getOutput (x:xs) = case x of - OptionOutput o -> o - _ -> getOutput xs - -getPath :: [Option] -> TL.Text -getPath [] = "" -getPath (x:xs) = case x of - OptionOutputPath p -> p - _ -> getPath xs - -withFile :: TL.Text -> (Handle -> IO a) -> IO a -withFile path io = case path of - "" -> io stdout - _ -> withBinaryFile (TL.unpack path) WriteMode io - -loomMap :: [(TL.Text, Loom)] -loomMap = [(loomName l, l) | l <- looms] - -getLoom :: [Option] -> Loom -getLoom [] = loomLaTeX -getLoom (x:xs) = case x of - OptionLoom name -> case lookup name loomMap of - Just loom -> loom - Nothing -> error $ "Unknown loom: " ++ show name - _ -> getLoom xs - -getEnableLines :: [Option] -> Bool -getEnableLines [] = True -getEnableLines (x:xs) = case x of - OptionNoLines -> False - _ -> getEnableLines xs - -main :: IO () -main = do - args <- getArgs - let (options, inputs, errors) = getOpt Permute optionInfo args - unless (null errors) $ do - name <- getProgName - hPutStrLn stderr $ concat errors - hPutStrLn stderr $ usageInfo (usage name) optionInfo - exitFailure - - let path = getPath options - let loom = getLoom options - let enableLines = getEnableLines options - - parsed <- parseInputs inputs - case parsed of - Left err -> do - hPutStrLn stderr (formatError err) - exitFailure - Right blocks -> case getOutput options of - Tangle -> case path of - "" -> tangle debugTangle enableLines blocks - _ -> tangle (realTangle path) enableLines blocks - Weave -> let - texts = execWriter $ loomWeave loom blocks - in withFile path $ \h -> BL.hPut h $ encodeUtf8 texts - -debugTangle :: TL.Text -> TL.Text -> IO () -debugTangle path text = do - putStr "\n" - TLIO.putStrLn path - putStrLn $ replicate (fromIntegral (TL.length path)) '=' - TLIO.putStr text - -realTangle :: TL.Text -> TL.Text -> TL.Text -> IO () -realTangle root path text = do - let fullpath = combine (TL.unpack root) (TL.unpack path) - createDirectoryIfMissing True $ takeDirectory fullpath - let bytes = encodeUtf8 text - withBinaryFile fullpath ReadWriteMode $ \h -> do - equal <- fileContentsEqual h bytes - unless equal $ do - hSetFileSize h 0 - BL.hPut h bytes - -fileContentsEqual :: Handle -> BL.ByteString -> IO Bool -fileContentsEqual h bytes = do - hSeek h SeekFromEnd 0 - size <- hTell h - hSeek h AbsoluteSeek 0 - - if size /= toInteger (BL.length bytes) - then return False - else do - -- FIXME: 'Int' overflow? - contents <- BL.hGet h (fromInteger size) - hSeek h AbsoluteSeek 0 - return $ bytes == contents - -parseInputs :: [String] -> IO (Either ParseError [Block]) -parseInputs inputs = do - eithers <- mapM (parseFile . TL.pack) inputs - return $ case catEithers eithers of - Left err -> Left err - Right bs -> Right $ concat bs - -formatError :: ParseError -> String -formatError err = concat [filename, ":", line, ": error: ", message] where - pos = parseErrorPosition err - filename = TL.unpack $ positionFile pos - line = show $ positionLine pos - message = TL.unpack $ parseErrorMessage err diff --git a/anansi.cabal b/anansi.cabal --- a/anansi.cabal +++ b/anansi.cabal @@ -1,12 +1,12 @@ name: anansi -version: 0.2.1 +version: 0.2.1.1 synopsis: Simple literate programming preprocessor license: GPL-3 license-file: license.txt author: John Millikin maintainer: jmillikin@gmail.com build-type: Simple -cabal-version: >=1.6 +cabal-version: >=1.8 category: Development stability: experimental bug-reports: mailto:jmillikin@gmail.com @@ -18,17 +18,22 @@ location: http://john-millikin.com/software/anansi/ library - ghc-options: -Wall -fno-warn-unused-do-bind + hs-source-dirs: lib + if true + ghc-options: -Wall + + if impl(ghc >= 6.11) + ghc-options: -fno-warn-unused-do-bind + build-depends: base >=4.0 && < 5.0 - , parsec >= 3.0 && < 4 + , parsec >= 3.0 && < 3.2 , bytestring >= 0.9 && < 0.10 - , text >= 0.7 && < 0.10 + , text >= 0.7 && < 0.11 , monads-tf >= 0.1 && < 0.2 , containers >= 0.1 && < 0.4 , filepath >= 1.1 && < 1.2 - , directory >= 1.0 && < 1.1 exposed-modules: Anansi @@ -45,4 +50,20 @@ Anansi.Util executable anansi + hs-source-dirs: src main-is: Main.hs + + if true + ghc-options: -Wall + + if impl(ghc >= 6.11) + ghc-options: -fno-warn-unused-do-bind + + build-depends: + base >=4.0 && < 5.0 + , bytestring >= 0.9 && < 0.10 + , text >= 0.7 && < 0.11 + , monads-tf >= 0.1 && < 0.2 + , filepath >= 1.1 && < 1.2 + , directory >= 1.0 && < 1.1 + , anansi diff --git a/lib/Anansi.hs b/lib/Anansi.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi.hs @@ -0,0 +1,43 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 + ( Block (..) + , Content (..) + , Position (..) + + , ParseError (..) + , parseFile + + , Loom (..) + , looms + , loomDebug + , loomHTML + , loomLaTeX + , loomNoWeb + + , tangle + ) where +import Anansi.Types +import Anansi.Loom +import Anansi.Loom.Debug +import Anansi.Loom.HTML +import Anansi.Loom.LaTeX +import Anansi.Loom.NoWeb +import Anansi.Parser +import Anansi.Tangle + +looms :: [Loom] +looms = [loomDebug, loomHTML, loomLaTeX, loomNoWeb] diff --git a/lib/Anansi/Loom.hs b/lib/Anansi/Loom.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom.hs @@ -0,0 +1,26 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 + ( Loom (..) + ) where +import Control.Monad.Writer +import Data.Text.Lazy (Text) +import Anansi.Types + +data Loom = Loom + { loomName :: Text + , loomWeave :: [Block] -> Writer Text () + } diff --git a/lib/Anansi/Loom/Debug.hs b/lib/Anansi/Loom/Debug.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom/Debug.hs @@ -0,0 +1,28 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Anansi.Loom.Debug (loomDebug) where +import Data.Text.Lazy (pack) +import Control.Monad (forM_) +import Control.Monad.Writer (tell) +import Anansi.Loom + +loomDebug :: Loom +loomDebug = Loom "debug" $ \blocks -> do + tell "\nweaving\n" + tell "==========================\n" + forM_ blocks $ \b -> do + tell . pack $ show b ++ "\n" diff --git a/lib/Anansi/Loom/HTML.hs b/lib/Anansi/Loom/HTML.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom/HTML.hs @@ -0,0 +1,54 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Anansi.Loom.HTML (loomHTML) where +import qualified Data.Text.Lazy as TL +import Control.Monad (forM_) +import Control.Monad.Writer (tell) +import Anansi.Types +import Anansi.Loom + +loomHTML :: Loom +loomHTML = Loom "html" $ mapM_ putBlock where + putBlock b = case b of + BlockText text -> tell text + BlockFile path content -> let + label = TL.concat ["» ", escape path, ""] + in putContent label content + BlockDefine name content -> let + label = TL.concat ["«", escape name, "»"] + in putContent label content + + putContent label cs = do + tell "
"
+		tell label
+		tell "\n"
+		forM_ cs $ \c -> case c of
+			ContentText _ text -> tell . escape $ TL.append text "\n"
+			ContentMacro _ indent name -> tell $ formatMacro indent name
+		tell "
" + +formatMacro :: TL.Text -> TL.Text -> TL.Text +formatMacro indent name = TL.concat [indent, "«", escape name, "»\n"] + +escape :: TL.Text -> TL.Text +escape = TL.concatMap $ \c -> case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> TL.singleton c diff --git a/lib/Anansi/Loom/LaTeX.hs b/lib/Anansi/Loom/LaTeX.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom/LaTeX.hs @@ -0,0 +1,58 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Anansi.Loom.LaTeX (loomLaTeX) where +import qualified Data.Text.Lazy as TL +import Control.Monad (forM_) +import Control.Monad.Writer (tell) +import Anansi.Types +import Anansi.Loom + +loomLaTeX :: Loom +loomLaTeX = Loom "latex" $ mapM_ putBlock where + putBlock b = case b of + BlockText text -> tell text + BlockFile path content -> do + tell "\\begin{alltt}\n" + tell "{\\bf\\(\\gg\\) " + tell $ escape path + tell "}\n" + putContent content + tell "\\end{alltt}\n" + + BlockDefine name content -> do + tell "\\begin{alltt}\n" + tell "{\\bf\\(\\ll\\)" + tell $ escape name + tell "\\(\\gg\\)}\n" + putContent content + tell "\\end{alltt}\n" + + putContent cs = forM_ cs $ \c -> case c of + ContentText _ text -> tell . escape $ TL.append text "\n" + ContentMacro _ indent name -> tell $ formatMacro indent name + +formatMacro :: TL.Text -> TL.Text -> TL.Text +formatMacro indent name = TL.concat [escape indent, "|\\emph{", escape name, "}|\n"] + +escape :: TL.Text -> TL.Text +escape = TL.concatMap $ \c -> case c of + '\t' -> " " + '\\' -> "\\textbackslash{}" + '{' -> "\\{" + '}' -> "\\}" + '_' -> "\\_" + _ -> TL.singleton c diff --git a/lib/Anansi/Loom/NoWeb.hs b/lib/Anansi/Loom/NoWeb.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Loom/NoWeb.hs @@ -0,0 +1,68 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Anansi.Loom.NoWeb (loomNoWeb) where +import qualified Data.Text.Lazy as TL +import Control.Monad (forM_) +import Control.Monad.Writer (tell) +import Anansi.Types +import Anansi.Loom + +loomNoWeb :: Loom +loomNoWeb = Loom "latex-noweb" $ mapM_ putBlock where + putBlock b = case b of + BlockText text -> tell text + BlockFile path content -> do + tell "\\nwbegincode{0}\\moddef{" + tell $ escapeText path + tell "}\\endmoddef\\nwstartdeflinemarkup\\nwenddeflinemarkup\n" + putContent content + tell "\\nwendcode{}\n" + + BlockDefine name content -> do + tell "\\nwbegincode{0}\\moddef{" + tell $ escapeText name + tell "}\\endmoddef\\nwstartdeflinemarkup\\nwenddeflinemarkup\n" + putContent content + tell "\\nwendcode{}\n" + + putContent cs = forM_ cs $ \c -> case c of + ContentText _ text -> tell . escapeCode $ TL.append text "\n" + ContentMacro _ indent name -> tell $ formatMacro indent name + +formatMacro :: TL.Text -> TL.Text -> TL.Text +formatMacro indent name = TL.concat [escapeCode indent, "\\LA{}", escapeText name, "\\RA{}\n"] + +escapeCode :: TL.Text -> TL.Text +escapeCode = TL.concatMap $ \c -> case c of + '\t' -> " " + '\\' -> "\\\\" + '{' -> "\\{" + '}' -> "\\}" + '_' -> "\\_" + _ -> TL.singleton c + +escapeText :: TL.Text -> TL.Text +escapeText = TL.concatMap $ \c -> case c of + '\t' -> " " + '\\' -> "\\\\" + '{' -> "\\{" + '}' -> "\\}" + '_' -> "\\_" + '<' -> "{$<$}" + '>' -> "{$>$}" + '$' -> "\\$" + _ -> TL.singleton c diff --git a/lib/Anansi/Parser.hs b/lib/Anansi/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Parser.hs @@ -0,0 +1,214 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Anansi.Parser + ( ParseError (..) + , parseFile + ) where +import Prelude hiding (FilePath) +import Control.Applicative ((<|>), (<$>)) +import Control.Monad.Trans (lift) +import qualified Control.Monad.State as S +import qualified Control.Exception as E +import Data.List (unfoldr) +import Data.Typeable (Typeable) +import qualified Text.Parsec as P +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Map as Map +import System.FilePath (replaceFileName) +import Anansi.Types +import Anansi.Util + +data ParseError = ParseError + { parseErrorPosition :: Position + , parseErrorMessage :: TL.Text + } + deriving (Show) + +-- too lazy to write proper error handling +data ParseExc = ParseExc ParseError + deriving (Typeable, Show) + +instance E.Exception ParseExc + +data Command + = CommandInclude TL.Text + | CommandFile TL.Text + | CommandDefine TL.Text + | CommandColon + | CommandEndBlock + | CommandComment + deriving (Show) + +data Line + = LineCommand Position Command + | LineText Position TL.Text + deriving (Show) + +untilChar :: Char -> P.Parsec String u TL.Text +untilChar c = TL.pack <$> P.manyTill P.anyChar (P.try (P.char c)) + +getPosition :: Monad m => P.ParsecT s u m Position +getPosition = do + pos <- P.getPosition + return $ Position (TL.pack (P.sourceName pos)) (toInteger (P.sourceLine pos)) + +parseLines :: P.Parsec String u [Line] +parseLines = do + lines' <- P.many parseLine + P.eof + return lines' + +parseLine :: P.Parsec String u Line +parseLine = command <|> text where + command = do + P.char ':' + pos <- getPosition + LineCommand pos <$> parseCommand + + text = do + pos <- getPosition + line <- untilChar '\n' + return . LineText pos $ TL.append line "\n" + +parseCommand :: P.Parsec String u Command +parseCommand = parsed where + string = P.try . P.string + parsed = P.choice [file, include, define, colon, comment, endBlock] + file = do + string "file " <|> string "f " + CommandFile <$> untilChar '\n' + + include = do + string "include " <|> string "i " + CommandInclude <$> untilChar '\n' + + define = do + string "define " <|> string "d " + -- TODO: verify no '|' in name + CommandDefine <$> untilChar '\n' + + colon = do + P.char ':' + return $ CommandColon + + comment = do + P.char '#' + untilChar '\n' + return $ CommandComment + + endBlock = do + line <- untilChar '\n' + if TL.all isSpace line + then return $ CommandEndBlock + else do + pos <- getPosition + let msg = TL.pack $ "unknown command: " ++ show (TL.append ":" line) + E.throw $ ParseExc $ ParseError pos msg + +-- TODO: more unicode support +isSpace :: Char -> Bool +isSpace ' ' = True +isSpace '\t' = True +isSpace _ = False + +parseBlocks :: [Line] -> Maybe (Either ParseError Block, [Line]) +parseBlocks [] = Nothing +parseBlocks (line:xs) = parsed where + parsed = case line of + LineText _ text -> Just (Right $ BlockText text, xs) + LineCommand pos cmd -> case cmd of + CommandFile path -> parseContent pos (BlockFile path) xs + CommandDefine name -> parseContent pos (BlockDefine name) xs + CommandColon -> Just (Right $ BlockText ":", xs) + CommandEndBlock -> Just (Right $ BlockText "\n", xs) + CommandComment -> Just (Right $ BlockText "", xs) + CommandInclude _ -> let + msg = "unexpected CommandInclude (internal error)" + in Just (Left $ ParseError pos msg, []) + +parseContent :: Position -> ([Content] -> Block) -> [Line] -> Maybe (Either ParseError Block, [Line]) +parseContent start block = parse [] where + parse acc [] = Just (Right $ block acc, []) + parse acc (line:xs) = case line of + LineText pos text -> case parse' pos text of + Left err -> Just (Left err, []) + Right parsed -> parse (acc ++ [parsed]) xs + LineCommand _ CommandEndBlock -> Just (Right $ block acc, xs) + LineCommand _ _ -> let + msg = "Unterminated content block" + in Just (Left $ ParseError start msg, []) + + parse' pos text = case P.parse (parser pos) "" (TL.unpack text) of + Right content -> Right content + Left err -> let + msg = TL.pack $ "Invalid content line " ++ show text ++ ": " ++ show err + in Left $ ParseError pos msg + + parser pos = do + content <- contentMacro pos <|> contentText pos + P.optional $ P.char '\n' + P.eof + return content + + contentMacro pos = do + (indent, c) <- P.try $ do + indent <- P.many $ P.satisfy isSpace + P.char '|' + c <- P.satisfy (not . isSpace) + return (indent, c) + name <- untilChar '|' + return $ ContentMacro pos (TL.pack indent) (TL.strip (TL.cons c name)) + + contentText pos = do + text <- untilChar '\n' + return . ContentText pos $ text + +type FilePath = TL.Text +type FileMap = Map.Map FilePath [Line] + +genLines :: Monad m => (FilePath -> m [Line]) -> FilePath -> S.StateT FileMap m [Line] +genLines getLines = genLines' where + genLines' path = lift (getLines path) >>= concatMapM (resolveIncludes path) + + relative x y = TL.pack $ replaceFileName (TL.unpack x) (TL.unpack y) + + resolveIncludes root line = case line of + LineCommand _ (CommandInclude path) -> genLines' $ relative root path + _ -> return [line] + +parseFile :: TL.Text -> IO (Either ParseError [Block]) +parseFile root = io where + io = E.handle onError $ do + lines' <- S.evalStateT (genLines getLines root) Map.empty + return . catEithers $ unfoldr parseBlocks lines' + + onError (ParseExc err) = return $ Left err + + getLines :: FilePath -> IO [Line] + getLines path = do + -- TODO: encode 'path' into UTF-8? + let path' = TL.unpack path + bytes <- B.readFile path' + case P.parse parseLines path' (T.unpack $ TE.decodeUtf8 bytes) of + Right x -> return x + Left err -> let + msg = TL.pack $ "getLines parse failed (internal error): " ++ show err + in E.throw $ ParseExc $ ParseError (Position path 0) msg diff --git a/lib/Anansi/Tangle.hs b/lib/Anansi/Tangle.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Tangle.hs @@ -0,0 +1,103 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Anansi.Tangle (tangle) where +import Control.Monad (when) +import Control.Monad.Trans (lift) +import qualified Control.Monad.State as S +import qualified Control.Monad.Writer as W +import qualified Data.Text.Lazy as TL +import qualified Data.Map as Map +import Anansi.Types + +type ContentMap = Map.Map TL.Text [Content] + +data TangleState = TangleState Position TL.Text ContentMap +type TangleT m a = W.WriterT TL.Text (S.StateT TangleState m) a + +buildMacros :: [Block] -> ContentMap +buildMacros blocks = S.execState (mapM_ accumMacro blocks) 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 $ Map.insertWith (\new old -> old ++ new) name content macros + +buildFiles :: [Block] -> ContentMap +buildFiles blocks = S.execState (mapM_ accumFile blocks) 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 $ Map.insertWith accum name content files + +tangle :: Monad m + => (TL.Text -> TL.Text -> m ()) + -> Bool -- ^ Enable writing #line declarations + -> [Block] + -> m () +tangle writeFile' enableLine blocks = S.evalStateT (mapM_ putFile files) initState where + initState = (TangleState (Position "" 0) "" macros) + fileMap = buildFiles blocks + macros = buildMacros blocks + files = Map.toAscList fileMap + + putFile (path, content) = do + text <- W.execWriterT (mapM_ (putContent enableLine) content) + lift $ writeFile' path text + +putContent :: Monad m => Bool -> Content -> TangleT m () +putContent enableLine (ContentText pos t) = do + TangleState _ indent _ <- S.get + when enableLine $ putPosition pos + W.tell indent + W.tell 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 (TL.append old indent) macros + m + TangleState newPos _ _ <- S.get + S.put $ TangleState newPos old macros + putMacro = do + when enableLine $ putPosition pos + lookupMacro name >>= mapM_ (putContent enableLine) + +putPosition :: Monad m => Position -> TangleT m () +putPosition pos = do + TangleState lastPos indent macros <- S.get + let expectedPos = Position (positionFile lastPos) (positionLine lastPos + 1) + let line = "\n#line " ++ show (positionLine pos) ++ " " ++ show (positionFile pos) ++ "\n" + S.put $ TangleState pos indent macros + if pos == expectedPos + then return () + else W.tell $ TL.pack line + +lookupMacro :: Monad m => TL.Text -> TangleT m [Content] +lookupMacro name = do + TangleState _ _ macros <- S.get + case 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 new file mode 100644 --- /dev/null +++ b/lib/Anansi/Types.hs @@ -0,0 +1,38 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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.Types + ( Block (..) + , Content (..) + , Position (..) + ) where +import Data.Text.Lazy (Text) + +data Block + = BlockText Text + | BlockFile Text [Content] + | BlockDefine Text [Content] + deriving (Show) + +data Content + = ContentText Position Text + | ContentMacro Position Text Text + deriving (Show) + +data Position = Position + { positionFile :: Text + , positionLine :: Integer + } + deriving (Show, Eq) diff --git a/lib/Anansi/Util.hs b/lib/Anansi/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Anansi/Util.hs @@ -0,0 +1,36 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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.Util + ( concatMapM + , replace + , catEithers + ) where +import Control.Monad (liftM) + +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat $ mapM f xs + +replace :: Eq a => a -> [a] -> [a] -> [a] +replace from to xs = flip concatMap xs $ \x -> if x == from + then to + else [x] + +catEithers :: [Either e a] -> Either e [a] +catEithers = cat' [] where + cat' acc [] = Right $ reverse acc + cat' acc (e:es) = case e of + Left err -> Left err + Right x -> cat' (x : acc) es diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,171 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . +-- +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Anansi + +import Control.Monad.Writer +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TLIO +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.ByteString.Lazy as BL + +import System.Console.GetOpt +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO hiding (withFile) + +data Output = Tangle | Weave + +data Option + = OptionOutput Output + | OptionOutputPath TL.Text + | OptionLoom TL.Text + | OptionNoLines + +optionInfo :: [OptDescr Option] +optionInfo = + [ Option ['t'] ["tangle"] (NoArg (OptionOutput Tangle)) + "Generate tangled source code (default)" + , Option ['w'] ["weave"] (NoArg (OptionOutput Weave)) + "Generate woven markup" + , Option ['o'] ["out", "output"] (ReqArg (OptionOutputPath . TL.pack) "PATH") + "Output path (directory for tangle, file for weave)" + , Option ['l'] ["loom"] (ReqArg (OptionLoom . TL.pack) "NAME") + "Which loom should be used to weave output" + , Option [] ["noline"] (NoArg OptionNoLines) + "Disable generating #line declarations in tangled code" + ] + +usage :: String -> String +usage name = "Usage: " ++ name ++ " [OPTION...]" + +getOutput :: [Option] -> Output +getOutput [] = Tangle +getOutput (x:xs) = case x of + OptionOutput o -> o + _ -> getOutput xs + +getPath :: [Option] -> TL.Text +getPath [] = "" +getPath (x:xs) = case x of + OptionOutputPath p -> p + _ -> getPath xs + +withFile :: TL.Text -> (Handle -> IO a) -> IO a +withFile path io = case path of + "" -> io stdout + _ -> withBinaryFile (TL.unpack path) WriteMode io + +loomMap :: [(TL.Text, Loom)] +loomMap = [(loomName l, l) | l <- looms] + +getLoom :: [Option] -> Loom +getLoom [] = loomLaTeX +getLoom (x:xs) = case x of + OptionLoom name -> case lookup name loomMap of + Just loom -> loom + Nothing -> error $ "Unknown loom: " ++ show name + _ -> getLoom xs + +getEnableLines :: [Option] -> Bool +getEnableLines [] = True +getEnableLines (x:xs) = case x of + OptionNoLines -> False + _ -> getEnableLines xs + +main :: IO () +main = do + args <- getArgs + let (options, inputs, errors) = getOpt Permute optionInfo args + unless (null errors) $ do + name <- getProgName + hPutStrLn stderr $ concat errors + hPutStrLn stderr $ usageInfo (usage name) optionInfo + exitFailure + + let path = getPath options + let loom = getLoom options + let enableLines = getEnableLines options + + parsed <- parseInputs inputs + case parsed of + Left err -> do + hPutStrLn stderr (formatError err) + exitFailure + Right blocks -> case getOutput options of + Tangle -> case path of + "" -> tangle debugTangle enableLines blocks + _ -> tangle (realTangle path) enableLines blocks + Weave -> let + texts = execWriter $ loomWeave loom blocks + in withFile path $ \h -> BL.hPut h $ encodeUtf8 texts + +debugTangle :: TL.Text -> TL.Text -> IO () +debugTangle path text = do + putStr "\n" + TLIO.putStrLn path + putStrLn $ replicate (fromIntegral (TL.length path)) '=' + TLIO.putStr text + +realTangle :: TL.Text -> TL.Text -> TL.Text -> IO () +realTangle root path text = do + let fullpath = combine (TL.unpack root) (TL.unpack path) + createDirectoryIfMissing True $ takeDirectory fullpath + let bytes = encodeUtf8 text + withBinaryFile fullpath ReadWriteMode $ \h -> do + equal <- fileContentsEqual h bytes + unless equal $ do + hSetFileSize h 0 + BL.hPut h bytes + +fileContentsEqual :: Handle -> BL.ByteString -> IO Bool +fileContentsEqual h bytes = do + hSeek h SeekFromEnd 0 + size <- hTell h + hSeek h AbsoluteSeek 0 + + if size /= toInteger (BL.length bytes) + then return False + else do + -- FIXME: 'Int' overflow? + contents <- BL.hGet h (fromInteger size) + hSeek h AbsoluteSeek 0 + return $ bytes == contents + +parseInputs :: [String] -> IO (Either ParseError [Block]) +parseInputs inputs = do + eithers <- mapM (parseFile . TL.pack) inputs + return $ case catEithers eithers of + Left err -> Left err + Right bs -> Right $ concat bs + +formatError :: ParseError -> String +formatError err = concat [filename, ":", line, ": error: ", message] where + pos = parseErrorPosition err + filename = TL.unpack $ positionFile pos + line = show $ positionLine pos + message = TL.unpack $ parseErrorMessage err + +catEithers :: [Either e a] -> Either e [a] +catEithers = cat' [] where + cat' acc [] = Right $ reverse acc + cat' acc (e:es) = case e of + Left err -> Left err + Right x -> cat' (x : acc) es