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.4 +version: 0.1.0.5 synopsis: A simple tool for literate programming description: lit has a minimal syntax for implementing literate programming. It generates both HTML and the native @@ -23,9 +23,9 @@ executable lit main-is: lit.hs hs-source-dirs: src - other-modules: Parse, Poll, Pretty, Processing, Types + other-modules: Parse, Poll, Process, Code, Html, Markdown, Highlight, Types build-depends: base ==4.*, - text ==1.1.*, + text >= 1 && < 2, parsec ==3.*, filepath ==1.3.*, unordered-containers ==0.2.*, diff --git a/src/Code.hs b/src/Code.hs new file mode 100644 --- /dev/null +++ b/src/Code.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +module Code ( generate ) where + +import Data.List (partition) +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 +mergeAux ans (next:rest) = + let + name = getName next + chunkHasName name = (== name) . getName + (found, rem) = partition (chunkHasName name) rest + merged = combineChunks (next:found) + in + mergeAux (merged:ans) rem + +combineChunks :: [Chunk] -> Chunk +combineChunks (a:[]) = a +combineChunks l@(c:cs) = Def line name parts + where + parts = concatMap getParts l + name = getName c + line = getLineNo c + +expand :: [Chunk] -> T.Text +expand chunks = + let + -- map (name, parts) + partMap = Map.fromList $ zip (map getName chunks) (map getParts chunks) + 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 = + let + toText = (\part -> + case part of + Code txt -> txt + Ref name -> expandParts refParts partMap + where refParts = Map.lookupDefault [] (T.strip name) partMap) + in + T.concat (map toText parts) `T.append` "\n" + + + diff --git a/src/Highlight.hs b/src/Highlight.hs new file mode 100644 --- /dev/null +++ b/src/Highlight.hs @@ -0,0 +1,56 @@ +module Highlight (highlight, getLang) where + +import qualified Data.Text as T +import Data.Monoid (mconcat) + +import Text.Blaze (toValue, (!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Highlighting.Kate ( defaultFormatOpts + , highlightAs + , languagesByFilename ) +import Text.Highlighting.Kate.Types + +highlight :: String -> T.Text -> H.Html +highlight lang txt = + let + highlighted = highlightAs lang (T.unpack txt) + 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) = + if titleAttributes opts + 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" +short DecValTok = "dv" +short BaseNTok = "bn" +short FloatTok = "fl" +short CharTok = "ch" +short StringTok = "st" +short CommentTok = "co" +short OtherTok = "ot" +short AlertTok = "al" +short FunctionTok = "fu" +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 new file mode 100644 --- /dev/null +++ b/src/Html.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +module Html (generate) where + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Maybe (fromMaybe) + +import Text.Blaze (toValue, (!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Cheapskate (markdown, def) +import Cheapskate.Html + +import Highlight +import Types + +generate :: Maybe String -> String -> [Chunk] -> T.Text +generate maybeCss name chunks = + let + lang = getLang name + mergedProse = simplify chunks -- adjacent Prose combined to one prose + body = H.preEscapedToHtml $ map (chunkToHtml lang) mergedProse + 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 + cssPath = fromMaybe "" maybeCss + cssAttr = toValue cssPath + includeCss = + if cssPath /= "" + then H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href cssAttr + else H.toHtml T.empty + in + H.docTypeHtml $ do + H.head $ do + H.title $ H.toHtml fileName + H.meta ! A.charset "UTF-8" + includeCss + H.body $ do bodyHtml + +simplify :: [Chunk] -> [Chunk] +simplify [] = [] +simplify lst = + let + (defs, ps) = span isDef lst + (ps', rest) = break isDef ps + mergeProse chunks = Prose $ T.concat $ map getProseText chunks + in case ps' of + [] -> defs ++ rest + _ -> defs ++ [mergeProse ps'] ++ (simplify rest) + +chunkToHtml :: String -> Chunk -> H.Html +chunkToHtml lang chunk = + case chunk of + Prose txt -> H.toHtml $ markdown def txt + Def _ name parts -> + let + header = headerToHtml name + 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") + 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 new file mode 100644 --- /dev/null +++ b/src/Markdown.hs @@ -0,0 +1,40 @@ +{-# 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 + lang = getLang name + 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 + Def _ name parts -> + let + lang' = T.pack lang + header = "<< " <++> (T.strip name) <++> " >>=" + mdParts = T.concat $ map (partToText lang) parts + in + "```" <++> 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") + + + diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -13,18 +13,6 @@ Left err -> [] Right result -> result -textP :: Parsec T.Text () T.Text -> T.Text -> T.Text -textP p txt = - case (parse p "" txt) of - Left err -> T.empty - Right result -> result - -chunkP :: Parsec T.Text () Chunk -> T.Text -> Maybe Chunk -chunkP p txt = - case (parse p "" txt) of - Left err -> Nothing - Right result -> Just result - entire :: Parser Program entire = manyTill chunk eof @@ -32,10 +20,7 @@ chunk = (try def) <|> prose prose :: Parser Chunk -prose = do - txt <- packM =<< many (noneOf "\n\r") - nl <- eol >>= (\c -> return $ T.singleton c) - return $ Prose (txt `T.append` nl) +prose = grabLine >>= (\line -> return $ Prose line) def :: Parser Chunk def = do @@ -43,49 +28,59 @@ 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 + pos <- getPosition + indent <- many ws + name <- packM =<< between (string "<<") (string ">>=") (many notDelim) + newline + return $ (indent, T.strip name, sourceLine pos) + +notDelim = noneOf ">=" + part :: String -> Parser Part -part indent = +part indent = try (string indent >> varLine) <|> - try (string indent >> defLine) <|> - (grabLine >>= (\extra -> return (Code $ extra))) - --(newline >>= (\nl -> return (Code $ T.singleton nl))) + try (string indent >> defLine) <|> + (grabLine >>= \extra -> return $ Code extra) varLine :: Parser Part varLine = do name <- packM =<< between (string "<<") (string ">>") (many notDelim) - eol + newline return $ Ref name defLine :: Parser Part defLine = do - line <- grabLine + line <- grabLine return $ Code line -endDef :: String -> Parser () -endDef indent = try $ do { skipMany newline; notFollowedBy (string indent) <|> (lookAhead title >> parserReturn ()) } - -beginDef = try $ do {lookAhead title >> parserReturn ()} - grabLine :: Parser T.Text grabLine = do - line <- packM =<< many (noneOf "\n\r") - last <- eol >>= (\c -> return $ T.singleton c) - return $ line `T.append` last + 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 --- Pre: Assumes that parser is looking at a fresh line with a macro defn --- Post: Returns (indent, macro-name, line-no) -title :: Parser (String, T.Text, Int) -title = do - pos <- getPosition - indent <- many ws - name <- packM =<< between (string "<<") (string ">>=") (many notDelim) - eol - return $ (indent, T.strip name, sourceLine pos) +textP :: Parsec T.Text () T.Text -> T.Text -> T.Text +textP p txt = + case (parse p "" txt) of + Left err -> T.empty + Right result -> result -notDelim = noneOf ">=" -ws :: Parser Char -ws = char ' ' <|> char '\t' -- consume a whitespace char -eol :: Parser Char -eol = char '\n' <|> char '\r' +chunkP :: Parsec T.Text () Chunk -> T.Text -> Maybe Chunk +chunkP p txt = + 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 @@ -7,31 +7,30 @@ import Control.Monad (forever) import qualified Control.Concurrent as C import System.IO.Error - + watch :: (String -> IO ()) -> [String] -> IO () -watch fun fs = do +watch fun fs = + let + wait = C.threadDelay 1000000 + in do putStrLn "starting.." mapM_ fun fs - -- total microseconds for each file to cause a 1 sec delay per loop - let delay = 1000000 `div` (length fs) - forever $ (C.threadDelay 1000000 >> mapM_ (onDiff fun delay) fs) + forever $ (wait >> mapM_ (onChange fun) fs) -onDiff :: (String -> IO ()) -> Int -> String -> IO () -onDiff fun delay file = do - modified <- errorHandler (getModificationTime file) +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 >> C.threadDelay delay else return () - - --- a really conservative check to prevent file --- "inavailability" due to reading modification bits -errorHandler = errorHandlerNTimes 10 + if diff < 2 then fun file else return () -errorHandlerNTimes 0 mnd = catchIOError mnd (\e -> ioError e) -errorHandlerNTimes times mnd = {-(putStrLn $ show times) >>-} catchIOError mnd handle - where - handle e = - if isDoesNotExistError e - then C.threadDelay 50000 >> errorHandlerNTimes (times - 1) mnd +retryAtMost 1 action = catchIOError action (\e -> ioError e) +retryAtMost times action = + let + handle e = if isDoesNotExistError e + then C.threadDelay 50000 >> retryAtMost (times - 1) action else ioError e + in + catchIOError action handle + + diff --git a/src/Pretty.hs b/src/Pretty.hs deleted file mode 100644 --- a/src/Pretty.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Pretty -( pretty -, mark -, getLang ) where - -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Cheapskate (markdown, def) -import Cheapskate.Html -import Text.Highlighting.Kate (defaultFormatOpts, highlightAs, languagesByFilename) -import Text.Highlighting.Kate.Types -import Text.Blaze (toValue, (!)) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) - -import Types - -pretty :: String -> Maybe String -> String -> [Chunk] -> T.Text -pretty lang maybeCss name chunks = - TL.toStrict $ renderHtml $ preface maybeCss name $ H.preEscapedToHtml $ map (chunkToHtml lang) chunks - -mark :: String -> [Chunk] -> T.Text -mark lang chunks = T.concat $ map (chunkToMarkdown lang) chunks - -chunkToMarkdown lang chunk = - case chunk of - Prose text -> text - Def _ name parts -> - let - lang' = T.pack lang - header = headerName name - mdParts = T.concat $ map (partToText lang) parts - in - "```" `T.append` lang' `T.append` - "\n" `T.append` header `T.append` - "\n" `T.append` mdParts `T.append` "```\n" - - -preface :: Maybe String -> String -> H.Html -> H.Html -preface maybeCss fileName bodyHtml = - let - cssPath = fromMaybe "" maybeCss - cssAttr = toValue cssPath - includeCss = - if cssPath /= "" - then H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href cssAttr - else H.toHtml T.empty - in - H.docTypeHtml $ do - H.head $ do - H.title $ H.toHtml fileName - H.meta ! A.charset "UTF-8" - includeCss - H.body $ do bodyHtml - - -chunkToHtml :: String -> Chunk -> H.Html -chunkToHtml lang chunk = - case chunk of - Prose txt -> H.toHtml $ markdown def txt - Def _ name parts -> - let - header = headerToHtml name - 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 -> mconcat $ map (sourceLineToHtml defaultFormatOpts) - $ highlightAs lang (T.unpack txt) - Ref txt -> H.preEscapedToHtml ("<< " `T.append` link `T.append` " >>\n") - where - link = "" `T.append` slim `T.append` "" - slim = T.strip txt - -partToText :: String -> Part -> T.Text -partToText lang part = - case part of - Code txt -> txt - Ref txt -> ("<< " `T.append` (T.strip txt) `T.append` " >>\n") - -headerToHtml :: T.Text -> H.Html -headerToHtml name = H.preEscapedToHtml $ headerToText name - -headerToText :: T.Text -> T.Text -headerToText name = "<< " `T.append` link `T.append` " >>=\n" - where - link = "" `T.append` slim `T.append` "" - slim = T.strip name - -headerName name = "<< " `T.append` (T.strip name) `T.append` " >>=" - --- The methods below were heavily derived from John MacFarlane's highlighting-kate source -tokenToHtml :: FormatOptions -> Token -> H.Html -tokenToHtml _ (NormalTok, txt) = H.toHtml txt -tokenToHtml opts (toktype, txt) = - if titleAttributes opts - then sp ! A.title (toValue $ show toktype) - else sp - where sp = H.span ! A.class_ (toValue $ short toktype) $ H.toHtml txt - -sourceLineToHtml :: FormatOptions -> SourceLine -> H.Html -sourceLineToHtml opts line = mconcat $ (map (tokenToHtml opts) line) ++ [(H.toHtml ("\n" :: String))] - -short :: TokenType -> T.Text -short KeywordTok = "kw" -short DataTypeTok = "dt" -short DecValTok = "dv" -short BaseNTok = "bn" -short FloatTok = "fl" -short CharTok = "ch" -short StringTok = "st" -short CommentTok = "co" -short OtherTok = "ot" -short AlertTok = "al" -short FunctionTok = "fu" -short RegionMarkerTok = "re" -short ErrorTok = "er" -short NormalTok = "" - -getLang path = - case languagesByFilename path of - [] -> "" - lst -> head lst diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module Process +( process +, htmlPipeline +, mdPipeline +, codePipeline ) where + +import Prelude hiding (readFile, writeFile) +import Data.Text.IO (writeFile, readFile) +import System.FilePath.Posix (takeFileName, dropExtension) +import System.Directory +import System.FilePath.Posix +import Data.List (intercalate) +import qualified Data.Text as T + +import Parse (encode) +import Code +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 + Nothing -> return Nothing + Just css -> do + getCurrentDirectory >>= canonicalizePath >>= \path -> return $ Just $ (join' . helper' . trim' . split') path + where + moves = filter (\str -> str /= ".") $ splitDirectories output + split' = splitDirectories + trim' = trimToMatchLength moves + helper' = reversePath moves [] + join' path = (intercalate "/" path) css + +trimToMatchLength list listToTrim = + let len1 = length list + len2 = length listToTrim + in + drop (len2 - len1) listToTrim + +reversePath [] solution curPathParts = solution +reversePath (fst:rest) solution curPathParts = + if fst == ".." + then reversePath rest ((last curPathParts) : solution) (init curPathParts) + else reversePath rest (".." : solution) (curPathParts ++ [fst]) + + + diff --git a/src/Processing.hs b/src/Processing.hs deleted file mode 100644 --- a/src/Processing.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Processing -( build -, htmlPipeline -, mdPipeline -, codePipeline ) where - -import Prelude hiding (readFile, writeFile) -import Data.Text.IO (writeFile, readFile) -import System.FilePath.Posix (takeFileName, dropExtension) - -import Data.List (partition) -import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T - -import Parse -import Pretty -import Types - -build mCss pipes file = - let fileName = dropExtension $ takeFileName file - lang = getLang fileName - in do - stream <- readFile file - encoded <- return $ encode stream - mapM_ (\f -> f mCss lang fileName encoded) pipes >> return () - -htmlPipeline = (\dir css lang path enc -> writeFile ((ensureTrailingSlash dir) ++ path ++ ".html") $ pretty lang css path enc) -mdPipeline = (\dir css lang path enc -> writeFile ((ensureTrailingSlash dir) ++ path ++ ".md") $ (mark lang) enc) -codePipeline = (\dir css lang path enc -> writeFile ((ensureTrailingSlash dir) ++ path) $ T.strip $ expand $ merge enc) - -ensureTrailingSlash dir = - if last dir == '/' - then dir - else dir ++ "/" - --- merge together definitions with the same name -merge :: [Chunk] -> [Chunk] -merge chunks = mergeAux [] (filter isDef chunks) -mergeAux ans [] = ans -mergeAux ans (next:rest) = - let - name = getName next - (found, rem) = partition (sameName name) rest - merged = combineChunks (next:found) - in - mergeAux (merged:ans) rem - -consecutive :: [Chunk] -> ([Chunk],[Chunk]) -consecutive [] = ([],[]) -consecutive lst@(fst:rest) = - case fst of - Prose _ -> break isDef lst - Def _ _ _ -> span isDef lst - --- assumes always one or more chunk -combineChunks :: [Chunk] -> Chunk -combineChunks (a:[]) = a -combineChunks l@(c:cs) = Def line name parts - where - parts = concatMap getParts l - name = getName c - line = getLineNo c - -isDef chunk = - case chunk of - Def _ _ _ -> True - Prose _ -> False - -getProseText prose = - case prose of - Prose txt -> txt - _ -> error "cannot retrieve txt, not a prose" - -getName chunk = - case chunk of - Def _ name _ -> name - _ -> error "cannot retrieve name, not a chunk" - -getParts chunk = - case chunk of - Def _ _ parts -> parts - _ -> error "cannot retrieve parts, not a chunk" - -getLineNo chunk = - case chunk of - Def line _ _ -> line - _ -> error "cannot retrieve line number, not a chunk" - -sameName name chunk = name == (getName chunk) - -expand :: [Chunk] -> T.Text -expand chunks = - let - -- map (name, parts) - partMap = Map.fromList $ zip (map getName chunks) (map getParts chunks) - rootParts = Map.lookupDefault [] "*" partMap - in - expandParts rootParts partMap - -expandParts :: [Part] -> Map.HashMap T.Text [Part] -> T.Text -expandParts parts partMap = - let - toText = (\part -> - case part of - Code txt -> txt - Ref name -> expandParts refParts partMap - where refParts = Map.lookupDefault [] (T.strip name) partMap) - in - T.concat (map toText parts) `T.append` "\n" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -5,3 +5,26 @@ data Chunk = Def Int Text [Part] | Prose Text deriving (Show, Eq) data Part = Code Text | Ref Text deriving (Show, Eq) type Program = [Chunk] + +isDef chunk = + case chunk of + Def _ _ _ -> True + Prose _ -> False +getName chunk = + case chunk of + Def _ name _ -> name + _ -> error "cannot retrieve name, not a def" +getParts chunk = + case chunk of + Def _ _ parts -> parts + _ -> error "cannot retrieve parts, not a def" +getLineNo chunk = + case chunk of + Def line _ _ -> line + _ -> error "cannot retrieve line number, not a def" +getProseText chunk = + 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 @@ -7,7 +7,7 @@ import System.Exit import Control.Applicative -import Processing +import Process import Poll data Options = Options { optCodeDir :: String @@ -82,6 +82,7 @@ "Display help" ] + usage = "Usage: lit OPTIONS... FILES..." help = "Try: lit --help" @@ -90,8 +91,6 @@ -- Parse options, getting a list of option actions let (actions, files, errors) = getOpt Permute options args - - -- Here we thread startOptions through all supplied option actions opts <- foldl (>>=) (return startOptions) actions let Options { optCodeDir = codeDir @@ -102,19 +101,18 @@ , optCss = mCss , optWatch = watching } = opts - codeDirCheck <- doesDirectoryExist codeDir docsDirCheck <- doesDirectoryExist docsDir - - let htmlPipe = if html then [Processing.htmlPipeline docsDir] else [] - mdPipe = if markdown then [Processing.mdPipeline docsDir] else [] - codePipe = if code then [Processing.codePipeline codeDir] else [] + let htmlPipe = if html then [Process.htmlPipeline docsDir mCss] else [] + mdPipe = if markdown then [Process.mdPipeline docsDir mCss] else [] + codePipe = if code then [Process.codePipeline codeDir mCss] else [] pipes = htmlPipe ++ mdPipe ++ codePipe maybeWatch = if watching then Poll.watch else mapM_ errors' = if codeDirCheck then [] else ["Directory: " ++ codeDir ++ " does not exist\n"] errors'' = if docsDirCheck then [] else ["Directory: " ++ docsDir ++ " does not exist\n"] allErr = errors ++ errors' ++ errors'' - if allErr /= [] || (not html && not code && not markdown) || files == [] then hPutStrLn stderr ((concat allErr) ++ help) - else (maybeWatch (Processing.build mCss pipes)) files + else (maybeWatch (Process.process pipes)) files + +