lit 0.1.0.9 → 0.1.1.0
raw patch · 10 files changed
+111/−88 lines, 10 files
Files
- lit.cabal +1/−2
- src/Code.hs +27/−15
- src/Highlight.hs +6/−6
- src/Html.hs +14/−14
- src/Markdown.hs +7/−7
- src/Parse.hs +11/−11
- src/Poll.hs +10/−10
- src/Process.hs +12/−8
- src/Types.hs +5/−4
- src/lit.hs +18/−11
lit.cabal view
@@ -1,7 +1,7 @@ -- Initial lit.cabal generated by cabal init. For further documentation, name: lit-version: 0.1.0.9+version: 0.1.1.0 synopsis: A simple tool for literate programming description: lit has a minimal syntax for implementing literate programming. It generates both HTML and the native@@ -11,7 +11,6 @@ license-file: LICENSE author: cdosborn maintainer: cdosborn@uw.edu--- copyright: category: Development build-type: Simple cabal-version: >=1.8
src/Code.hs view
@@ -1,46 +1,58 @@ {-# LANGUAGE OverloadedStrings #-}-module Code ( generate ) where+module Code ( generate, generateWithAnnotation ) where import Data.List (partition, intersperse) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T+import Text.Parsec.Pos import Types generate :: [Chunk] -> T.Text generate = expand . merge . (filter isDef)+generateWithAnnotation :: String -> [Chunk] -> T.Text+generateWithAnnotation ext = expand . merge . (annotate ext) . (filter isDef)++annotate :: String -> [Chunk] -> [Chunk]+annotate langExt chunks = map annotateChunk chunks+ where+ annotateChunk (Def sourcePos name parts) =+ Def sourcePos name $ (Code $ annotation sourcePos):parts+ annotation sourcePos = T.pack $ annotateForLang langExt (sourceName sourcePos) (sourceLine sourcePos) ++ "\n"+ annotateForLang ext filePath lineNo = (comment ext) ++ " " ++ filePath ++ ":" ++ (show lineNo)+ comment ".sh" = "#"+ comment ".hs" = "--"+ comment _ = "//" merge :: [Chunk] -> [Chunk] merge = mergeAux [] mergeAux ans [] = ans-mergeAux ans (next:rest) = - let +mergeAux ans (next:rest) =+ let name = getName next chunkHasName name = (== name) . getName- (found, rem) = partition (chunkHasName name) rest + (found, rem) = partition (chunkHasName name) rest merged = combineChunks (next:found)- in + in mergeAux (merged:ans) rem combineChunks :: [Chunk] -> Chunk combineChunks (a:[]) = a-combineChunks l@(c:cs) = Def line name parts +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 + expandParts parts partMap T.empty+ where -- 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 T.empty+ parts = Map.lookupDefault backup "*" partMap expandParts :: [Part] -> Map.HashMap T.Text [Part] -> T.Text -> T.Text expandParts parts partMap baseIndent =- let - toText = (\part -> + T.concat $ map toText parts+ where+ toText part = case part of 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+ where refParts = Map.lookupDefault [] (T.strip name) partMap
src/Highlight.hs view
@@ -1,5 +1,5 @@ module Highlight (highlight, getLang) where-import qualified Data.Text as T +import qualified Data.Text as T import Data.Monoid (mconcat) import Text.Blaze (toValue, (!))@@ -8,13 +8,13 @@ import Text.Highlighting.Kate ( defaultFormatOpts , highlightAs , languagesByFilename )-import Text.Highlighting.Kate.Types +import Text.Highlighting.Kate.Types highlight :: String -> T.Text -> H.Html-highlight lang txt = +highlight lang txt = let highlighted = highlightAs lang (T.unpack txt) htmlList = map sourceLineToHtml highlighted- in + in mconcat htmlList sourceLineToHtml :: SourceLine -> H.Html sourceLineToHtml line = mconcat $ htmlList ++ [H.toHtml "\n"]@@ -25,7 +25,7 @@ tokenToHtml opts (toktype, str) = if titleAttributes opts then sp ! A.title (toValue $ show toktype)- else sp + else sp where sp = H.span ! A.class_ (toValue $ short toktype) $ H.toHtml str short :: TokenType -> String short KeywordTok = "kw"@@ -42,7 +42,7 @@ short RegionMarkerTok = "re" short ErrorTok = "er" short NormalTok = ""-getLang path = +getLang path = case languagesByFilename path of [] -> "" lst -> head lst
src/Html.hs view
@@ -14,36 +14,36 @@ import Highlight import Types generate :: Maybe String -> String -> [Chunk] -> T.Text-generate maybeCss name chunks = - let +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 + 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 + let cssPath = fromMaybe "" maybeCss cssAttr = toValue cssPath- includeCss = + 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 + in+ H.docTypeHtml $ do H.head $ do H.title $ H.toHtml fileName- H.meta ! A.charset "UTF-8" + H.meta ! A.charset "UTF-8" includeCss H.body $ do bodyHtml simplify :: [Chunk] -> [Chunk] simplify [] = [] simplify lst =- let + let (defs, ps) = span isDef lst (ps', rest) = break isDef ps mergeProse chunks = Prose $ T.concat $ map getProseText chunks@@ -54,11 +54,11 @@ chunkToHtml lang chunk = case chunk of Prose txt -> H.toHtml $ markdown def txt- Def _ name parts -> - let + Def _ name parts ->+ let header = headerToHtml name htmlParts = H.preEscapedToHtml $ map (partToHtml lang) parts- in + in H.pre $ H.code $ (header >> htmlParts) partToHtml :: String -> Part -> H.Html partToHtml lang part =@@ -68,9 +68,9 @@ where link = "<a href=\"#" <++> underscored <++> "\">" <++> slim <++> "</a>" slim = T.strip txt- underscored = underscore slim + underscored = underscore slim headerToHtml :: T.Text -> H.Html-headerToHtml name = H.preEscapedToHtml $ "<< " <++> link <++> " >>=\n" +headerToHtml name = H.preEscapedToHtml $ "<< " <++> link <++> " >>=\n" where link = "<a id=\"" <++> underscored <++> "\" href=\"#" <++> underscored <++> "\">" <++> slim <++> "</a>" slim = T.strip name
src/Markdown.hs view
@@ -5,8 +5,8 @@ import Types import Highlight (getLang) generate :: String -> [Chunk] -> T.Text-generate name chunks = - let +generate name chunks =+ let lang = getLang name toMarkDown = chunkToMarkdown lang in@@ -16,14 +16,14 @@ chunkToMarkdown lang chunk = case chunk of Prose text -> text- Def _ name parts -> - let + Def _ name parts ->+ let lang' = T.pack lang header = "<< " <++> (T.strip name) <++> " >>=" mdParts = T.concat $ map (partToText lang) parts- in - "```" <++> lang' <++> - "\n" <++> header <++> + in+ "```" <++> lang' <++>+ "\n" <++> header <++> "\n" <++> mdParts <++> "```\n" partToText :: String -> Part -> T.Text partToText lang part =
src/Parse.hs view
@@ -5,9 +5,9 @@ import qualified Data.Text as T import Types-encode :: T.Text -> [Chunk]-encode txt =- case (parse entire "" txt) of +encode :: T.Text -> String -> [Chunk]+encode txt fileName =+ case (parse entire fileName txt) of Left err -> [] Right result -> result entire :: Parser Program@@ -23,18 +23,18 @@ 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)+-- Returns (indent, macro-name, SourcePos)+title :: Parser (String, T.Text, SourcePos) title = do pos <- getPosition indent <- many ws name <- packM =<< between (string "<<") (string ">>=") (many notDelim) newline- return $ (indent, T.strip name, sourceLine pos)+ return $ (indent, T.strip name, pos) notDelim = noneOf ">=" part :: String -> Parser Part-part indent = - try (string indent >> varLine) <|> +part indent =+ try (string indent >> varLine) <|> try (string indent >> defLine) <|> (grabLine >>= \extra -> return $ Code extra) varLine :: Parser Part@@ -48,7 +48,7 @@ line <- grabLine return $ Code line grabLine :: Parser T.Text-grabLine = do +grabLine = do line <- many (noneOf "\n\r") last <- newline return $ T.pack $ line ++ [last]@@ -57,12 +57,12 @@ packM str = return $ T.pack str textP :: Parsec T.Text () T.Text -> T.Text -> T.Text textP p txt =- case (parse p "" txt) of + 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 + case (parse p "" txt) of Left err -> Nothing Right result -> Just result
src/Poll.hs view
@@ -1,4 +1,4 @@-module Poll +module Poll ( watch ) where import System.Directory import Data.Time.Clock@@ -7,24 +7,24 @@ import qualified Control.Concurrent as C import System.IO.Error watch :: (String -> IO ()) -> [String] -> IO ()-watch fun fs = - let +watch fun fs =+ let wait = C.threadDelay 1000000- in do + in do 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 + 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 = +retryAtMost times action = let- handle e = if isDoesNotExistError e + handle e = if isDoesNotExistError e then C.threadDelay 50000 >> retryAtMost (times - 1) action else ioError e- in - catchIOError action handle + in+ catchIOError action handle
src/Process.hs view
@@ -6,7 +6,7 @@ , codePipeline ) where import Prelude hiding (readFile, writeFile) import Data.Text.IO (writeFile, readFile)-import System.FilePath.Posix (takeFileName, dropExtension)+import System.FilePath.Posix (takeFileName, dropExtension, takeExtension) import System.Directory import System.FilePath.Posix import Data.List (intercalate)@@ -17,9 +17,9 @@ import Html import Markdown import Types-process pipes file = do +process pipes file = do stream <- readFile file- encoded <- return $ encode stream + encoded <- return $ encode stream file mapM_ (\f -> f fileName encoded) pipes >> return () where fileName = dropExtension $ takeFileName file@@ -32,27 +32,31 @@ where path = (addTrailingPathSeparator dir) ++ name ++ ".md" output = Markdown.generate name enc-codePipeline dir css name enc = writeFile path output+codePipeline dir css showLines name enc = writeFile path output where path = (addTrailingPathSeparator dir) ++ name- output = Code.generate enc+ ext = takeExtension name+ output =+ if showLines+ then Code.generateWithAnnotation ext enc+ else 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 + where moves = filter (\str -> str /= ".") $ splitDirectories output split' = splitDirectories trim' = trimToMatchLength moves helper' = reversePath moves [] join' path = (intercalate "/" path) </> css -trimToMatchLength list listToTrim = +trimToMatchLength list listToTrim = let len1 = length list len2 = length listToTrim- in + in drop (len2 - len1) listToTrim reversePath [] solution curPathParts = solution
src/Types.hs view
@@ -1,7 +1,8 @@ module Types where -import Data.Text -data Chunk = Def Int Text [Part] | Prose Text deriving (Show, Eq)+import Data.Text+import Text.Parsec (SourcePos)+data Chunk = Def SourcePos Text [Part] | Prose Text deriving (Show, Eq) data Part = Code Text | Ref Text Text deriving (Show, Eq) type Program = [Chunk] isDef chunk =@@ -16,7 +17,7 @@ case chunk of Def _ name _ -> name _ -> error "cannot retrieve name, not a def"-getCodeText part = +getCodeText part = case part of Code txt -> txt _ -> error "cannot retrieve text, not a code part"@@ -28,7 +29,7 @@ case chunk of Def line _ _ -> line _ -> error "cannot retrieve line number, not a def"-getProseText chunk = +getProseText chunk = case chunk of Prose txt -> txt _ -> error "cannot retrieve text, not a prose"
src/lit.hs view
@@ -9,13 +9,14 @@ import Process import Poll-data Options = Options { optCodeDir :: String +data Options = Options { optCodeDir :: String , optDocsDir :: String , optCss :: Maybe String , optCode :: Bool , optHtml :: Bool , optMarkdown :: Bool , optWatch :: Bool+ , optNumber :: Bool } startOptions :: Options startOptions = Options { optCodeDir = "./"@@ -25,9 +26,10 @@ , optHtml = False , optMarkdown = False , optWatch = False+ , optNumber = False } options :: [ OptDescr (Options -> IO Options) ]-options = +options = [ Option "h" ["html"] (NoArg (\opt -> return opt { optHtml = True })) "Generate html"@@ -40,6 +42,10 @@ (NoArg (\opt -> return opt { optCode = True })) "Generate code by file extension" + , Option "n" ["number"]+ (NoArg (\opt -> return opt { optNumber = True }))+ "Add annotations to generated code noting the source lit file and line number"+ , Option "" ["css"] (ReqArg (\arg opt -> return opt { optCss = Just arg })@@ -62,14 +68,14 @@ (NoArg (\opt -> return opt { optWatch = True})) "Watch for file changes, automatically run lit"- + , Option "v" ["version"] (NoArg (\_ -> do- hPutStrLn stderr "Version 0.1.0.9"+ hPutStrLn stderr "Version 0.1.1.0" exitWith ExitSuccess)) "Print version"- + , Option "" ["help"] (NoArg (\_ -> do@@ -82,11 +88,11 @@ help = "Try: lit --help" main = do args <- getArgs- + -- Parse options, getting a list of option actions let (actions, files, errors) = getOpt Permute options args opts <- foldl (>>=) (return startOptions) actions- + let Options { optCodeDir = codeDir , optDocsDir = docsDir , optMarkdown = markdown@@ -94,17 +100,18 @@ , optHtml = html , optCss = mCss , optWatch = watching- } = opts + , optNumber = showLines+ } = opts codeDirCheck <- doesDirectoryExist codeDir docsDirCheck <- doesDirectoryExist docsDir 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 + codePipe = if code then [Process.codePipeline codeDir mCss showLines] 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) + then hPutStrLn stderr ((concat allErr) ++ help) else (maybeWatch (Process.process pipes)) files