diff --git a/lit.cabal b/lit.cabal --- a/lit.cabal +++ b/lit.cabal @@ -1,7 +1,7 @@ -- Initial lit.cabal generated by cabal init. For further documentation, name: lit -version: 0.1.0.5 +version: 0.1.0.9 synopsis: A simple tool for literate programming description: lit has a minimal syntax for implementing literate programming. It generates both HTML and the native @@ -27,11 +27,11 @@ build-depends: base ==4.*, text >= 1 && < 2, parsec ==3.*, - filepath ==1.3.*, + filepath ==1.4.*, unordered-containers ==0.2.*, cheapskate ==0.1.*, blaze-markup ==0.6.*, - blaze-html == 0.7.*, + blaze-html == 0.7.0.3, highlighting-kate ==0.5.*, - time ==1.4.*, + time ==1.5.*, directory ==1.2.* diff --git a/src/Code.hs b/src/Code.hs --- a/src/Code.hs +++ b/src/Code.hs @@ -1,15 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Code ( generate ) where - -import Data.List (partition) +import Data.List (partition, intersperse) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T import Types - generate :: [Chunk] -> T.Text generate = expand . merge . (filter isDef) - merge :: [Chunk] -> [Chunk] merge = mergeAux [] mergeAux ans [] = ans @@ -21,7 +18,6 @@ merged = combineChunks (next:found) in mergeAux (merged:ans) rem - combineChunks :: [Chunk] -> Chunk combineChunks (a:[]) = a combineChunks l@(c:cs) = Def line name parts @@ -29,7 +25,6 @@ parts = concatMap getParts l name = getName c line = getLineNo c - expand :: [Chunk] -> T.Text expand chunks = let @@ -38,17 +33,14 @@ backup = getParts $ last chunks parts = Map.lookupDefault backup "*" partMap in - expandParts parts partMap -expandParts :: [Part] -> Map.HashMap T.Text [Part] -> T.Text -expandParts parts partMap = + expandParts parts partMap T.empty +expandParts :: [Part] -> Map.HashMap T.Text [Part] -> T.Text -> T.Text +expandParts parts partMap baseIndent = let toText = (\part -> case part of - Code txt -> txt - Ref name -> expandParts refParts partMap + Code txt -> T.append baseIndent txt + Ref name indent -> (expandParts refParts partMap (T.append baseIndent indent)) where refParts = Map.lookupDefault [] (T.strip name) partMap) in - T.concat (map toText parts) `T.append` "\n" - - - + T.concat $ map toText parts diff --git a/src/Highlight.hs b/src/Highlight.hs --- a/src/Highlight.hs +++ b/src/Highlight.hs @@ -1,5 +1,4 @@ module Highlight (highlight, getLang) where - import qualified Data.Text as T import Data.Monoid (mconcat) @@ -10,7 +9,6 @@ , highlightAs , languagesByFilename ) import Text.Highlighting.Kate.Types - highlight :: String -> T.Text -> H.Html highlight lang txt = let @@ -18,12 +16,10 @@ htmlList = map sourceLineToHtml highlighted in mconcat htmlList - sourceLineToHtml :: SourceLine -> H.Html sourceLineToHtml line = mconcat $ htmlList ++ [H.toHtml "\n"] where htmlList = map (tokenToHtml defaultFormatOpts) line - tokenToHtml :: FormatOptions -> Token -> H.Html tokenToHtml _ (NormalTok, str) = H.toHtml str tokenToHtml opts (toktype, str) = @@ -31,7 +27,6 @@ then sp ! A.title (toValue $ show toktype) else sp where sp = H.span ! A.class_ (toValue $ short toktype) $ H.toHtml str - short :: TokenType -> String short KeywordTok = "kw" short DataTypeTok = "dt" @@ -47,10 +42,7 @@ short RegionMarkerTok = "re" short ErrorTok = "er" short NormalTok = "" - getLang path = case languagesByFilename path of [] -> "" lst -> head lst - - diff --git a/src/Html.hs b/src/Html.hs --- a/src/Html.hs +++ b/src/Html.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} module Html (generate) where - import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Maybe (fromMaybe) @@ -14,7 +13,6 @@ import Highlight import Types - generate :: Maybe String -> String -> [Chunk] -> T.Text generate maybeCss name chunks = let @@ -24,10 +22,8 @@ doc = preface maybeCss name body in TL.toStrict $ renderHtml doc - (<++>) :: T.Text -> T.Text -> T.Text (<++>) = T.append - preface :: Maybe String -> String -> H.Html -> H.Html preface maybeCss fileName bodyHtml = let @@ -44,7 +40,6 @@ H.meta ! A.charset "UTF-8" includeCss H.body $ do bodyHtml - simplify :: [Chunk] -> [Chunk] simplify [] = [] simplify lst = @@ -55,7 +50,6 @@ in case ps' of [] -> defs ++ rest _ -> defs ++ [mergeProse ps'] ++ (simplify rest) - chunkToHtml :: String -> Chunk -> H.Html chunkToHtml lang chunk = case chunk of @@ -66,27 +60,21 @@ htmlParts = H.preEscapedToHtml $ map (partToHtml lang) parts in H.pre $ H.code $ (header >> htmlParts) - partToHtml :: String -> Part -> H.Html partToHtml lang part = case part of Code txt -> highlight lang txt - Ref txt -> H.preEscapedToHtml ("<< " <++> link <++> " >>\n") + Ref txt indent -> H.preEscapedToHtml (indent <++> "<< " <++> link <++> " >>\n") where link = " underscored <++> "\">" <++> slim <++> "" slim = T.strip txt underscored = underscore slim - headerToHtml :: T.Text -> H.Html headerToHtml name = H.preEscapedToHtml $ "<< " <++> link <++> " >>=\n" where link = " underscored <++> "\" href=\"#" <++> underscored <++> "\">" <++> slim <++> "" slim = T.strip name underscored = underscore slim - underscore :: T.Text -> T.Text underscore txt = T.pack $ concatMap (\c -> if c == ' ' then "_" else [c]) $ T.unpack txt - - - diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -1,11 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Markdown ( generate ) where - import qualified Data.Text as T import Types import Highlight (getLang) - generate :: String -> [Chunk] -> T.Text generate name chunks = let @@ -13,10 +11,8 @@ toMarkDown = chunkToMarkdown lang in T.concat $ map toMarkDown chunks - (<++>) :: T.Text -> T.Text -> T.Text (<++>) = T.append - chunkToMarkdown lang chunk = case chunk of Prose text -> text @@ -29,12 +25,8 @@ "```" <++> lang' <++> "\n" <++> header <++> "\n" <++> mdParts <++> "```\n" - partToText :: String -> Part -> T.Text partToText lang part = case part of Code txt -> txt - Ref txt -> ("<< " <++> (T.strip txt) <++> " >>\n") - - - + Ref txt indent -> (indent <++> "<< " <++> (T.strip txt) <++> " >>\n") diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,36 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} module Parse where - import Text.Parsec import Text.Parsec.Text import qualified Data.Text as T import Types - encode :: T.Text -> [Chunk] encode txt = case (parse entire "" txt) of Left err -> [] Right result -> result - entire :: Parser Program entire = manyTill chunk eof - chunk :: Parser Chunk chunk = (try def) <|> prose - prose :: Parser Chunk prose = grabLine >>= (\line -> return $ Prose line) - def :: Parser Chunk def = do (indent, header, lineNum) <- title parts <- manyTill (part indent) $ endDef indent return $ Def lineNum header parts - endDef :: String -> Parser () endDef indent = try $ do { skipMany newline; notFollowedBy (string indent) <|> (lookAhead title >> parserReturn ()) } - -- Returns (indent, macro-name, line-no) title :: Parser (String, T.Text, Int) title = do @@ -39,38 +31,30 @@ name <- packM =<< between (string "<<") (string ">>=") (many notDelim) newline return $ (indent, T.strip name, sourceLine pos) - notDelim = noneOf ">=" - part :: String -> Parser Part part indent = try (string indent >> varLine) <|> try (string indent >> defLine) <|> (grabLine >>= \extra -> return $ Code extra) - varLine :: Parser Part varLine = do + indent <- packM =<< many ws name <- packM =<< between (string "<<") (string ">>") (many notDelim) newline - return $ Ref name - + return $ Ref name indent defLine :: Parser Part defLine = do line <- grabLine return $ Code line - grabLine :: Parser T.Text grabLine = do line <- many (noneOf "\n\r") last <- newline return $ T.pack $ line ++ [last] - ws :: Parser Char ws = char ' ' <|> char '\t' - - packM str = return $ T.pack str - textP :: Parsec T.Text () T.Text -> T.Text -> T.Text textP p txt = case (parse p "" txt) of @@ -82,5 +66,3 @@ case (parse p "" txt) of Left err -> Nothing Right result -> Just result - - diff --git a/src/Poll.hs b/src/Poll.hs --- a/src/Poll.hs +++ b/src/Poll.hs @@ -1,13 +1,11 @@ module Poll ( watch ) where - import System.Directory import Data.Time.Clock import Data.Time.Calendar import Control.Monad (forever) import qualified Control.Concurrent as C import System.IO.Error - watch :: (String -> IO ()) -> [String] -> IO () watch fun fs = let @@ -16,14 +14,12 @@ putStrLn "starting.." mapM_ fun fs forever $ (wait >> mapM_ (onChange fun) fs) - onChange :: (String -> IO ()) -> String -> IO () onChange fun file = do modified <- retryAtMost 10 (getModificationTime file) curTime <- getCurrentTime let diff = (diffUTCTime curTime modified) if diff < 2 then fun file else return () - retryAtMost 1 action = catchIOError action (\e -> ioError e) retryAtMost times action = let @@ -32,5 +28,3 @@ else ioError e in catchIOError action handle - - diff --git a/src/Process.hs b/src/Process.hs --- a/src/Process.hs +++ b/src/Process.hs @@ -4,7 +4,6 @@ , htmlPipeline , mdPipeline , codePipeline ) where - import Prelude hiding (readFile, writeFile) import Data.Text.IO (writeFile, readFile) import System.FilePath.Posix (takeFileName, dropExtension) @@ -18,30 +17,25 @@ import Html import Markdown import Types - process pipes file = do stream <- readFile file encoded <- return $ encode stream mapM_ (\f -> f fileName encoded) pipes >> return () where fileName = dropExtension $ takeFileName file - htmlPipeline dir mCss name enc = do maybeCss <- cssRelativeToOutput dir mCss let path = (addTrailingPathSeparator dir) ++ name ++ ".html" output = Html.generate maybeCss name enc writeFile path output - mdPipeline dir css name enc = writeFile path output where path = (addTrailingPathSeparator dir) ++ name ++ ".md" output = Markdown.generate name enc - codePipeline dir css name enc = writeFile path output where path = (addTrailingPathSeparator dir) ++ name output = Code.generate enc - cssRelativeToOutput :: String -> Maybe String -> IO (Maybe String) cssRelativeToOutput output mCss = case mCss of @@ -66,6 +60,3 @@ if fst == ".." then reversePath rest ((last curPathParts) : solution) (init curPathParts) else reversePath rest (".." : solution) (curPathParts ++ [fst]) - - - diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,19 +1,25 @@ module Types where import Data.Text - data Chunk = Def Int Text [Part] | Prose Text deriving (Show, Eq) -data Part = Code Text | Ref Text deriving (Show, Eq) +data Part = Code Text | Ref Text Text deriving (Show, Eq) type Program = [Chunk] - isDef chunk = case chunk of Def _ _ _ -> True Prose _ -> False +isRef part = + case part of + Ref _ _ -> True + _ -> False getName chunk = case chunk of Def _ name _ -> name _ -> error "cannot retrieve name, not a def" +getCodeText part = + case part of + Code txt -> txt + _ -> error "cannot retrieve text, not a code part" getParts chunk = case chunk of Def _ _ parts -> parts @@ -26,5 +32,3 @@ case chunk of Prose txt -> txt _ -> error "cannot retrieve text, not a prose" - - diff --git a/src/lit.hs b/src/lit.hs --- a/src/lit.hs +++ b/src/lit.hs @@ -9,7 +9,6 @@ import Process import Poll - data Options = Options { optCodeDir :: String , optDocsDir :: String , optCss :: Maybe String @@ -18,7 +17,6 @@ , optMarkdown :: Bool , optWatch :: Bool } - startOptions :: Options startOptions = Options { optCodeDir = "./" , optDocsDir = "./" @@ -28,7 +26,6 @@ , optMarkdown = False , optWatch = False } - options :: [ OptDescr (Options -> IO Options) ] options = [ Option "h" ["html"] @@ -69,7 +66,7 @@ , Option "v" ["version"] (NoArg (\_ -> do - hPutStrLn stderr "Version 0.01" + hPutStrLn stderr "Version 0.1.0.9" exitWith ExitSuccess)) "Print version" @@ -81,11 +78,8 @@ exitWith ExitSuccess)) "Display help" ] - - usage = "Usage: lit OPTIONS... FILES..." help = "Try: lit --help" - main = do args <- getArgs @@ -114,5 +108,3 @@ if allErr /= [] || (not html && not code && not markdown) || files == [] then hPutStrLn stderr ((concat allErr) ++ help) else (maybeWatch (Process.process pipes)) files - -