lit 0.1.1.0 → 0.1.10.0
raw patch · 10 files changed
+79/−80 lines, 10 files
Files
- lit.cabal +1/−1
- src/Code.hs +13/−14
- src/Highlight.hs +6/−6
- src/Html.hs +14/−14
- src/Markdown.hs +7/−7
- src/Parse.hs +6/−6
- src/Poll.hs +10/−10
- src/Process.hs +8/−8
- src/Types.hs +3/−3
- src/lit.hs +11/−11
lit.cabal view
@@ -1,7 +1,7 @@ -- Initial lit.cabal generated by cabal init. For further documentation, name: lit-version: 0.1.1.0+version: 0.1.10.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
src/Code.hs view
@@ -13,28 +13,27 @@ annotate :: String -> [Chunk] -> [Chunk] annotate langExt chunks = map annotateChunk chunks- where- annotateChunk (Def sourcePos name parts) =+ 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 _ = "//"+ annotateForLang ".sh" filePath lineNo = "# " ++ filePath ++ ":" ++ (show lineNo)+ annotateForLang ".hs" filePath lineNo = "-- " ++ filePath ++ ":" ++ (show lineNo)+ annotateForLang _ filePath lineNo = "// " ++ filePath ++ ":" ++ (show lineNo) 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@@ -42,15 +41,15 @@ expand :: [Chunk] -> T.Text expand chunks = expandParts parts partMap T.empty- where+ where -- map (name, parts) partMap = Map.fromList $ zip (map getName chunks) (map getParts chunks) backup = getParts $ last chunks- parts = Map.lookupDefault backup "*" partMap+ parts = Map.lookupDefault backup "*" partMap expandParts :: [Part] -> Map.HashMap T.Text [Part] -> T.Text -> T.Text expandParts parts partMap baseIndent = T.concat $ map toText parts- where+ where toText part = case part of Code txt -> T.append baseIndent txt
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
@@ -7,7 +7,7 @@ import Types encode :: T.Text -> String -> [Chunk] encode txt fileName =- case (parse entire fileName txt) of+ case (parse entire fileName txt) of Left err -> [] Right result -> result entire :: Parser Program@@ -33,8 +33,8 @@ 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
@@ -17,7 +17,7 @@ import Html import Markdown import Types-process pipes file = do+process pipes file = do stream <- readFile file encoded <- return $ encode stream file mapM_ (\f -> f fileName encoded) pipes >> return ()@@ -36,27 +36,27 @@ where path = (addTrailingPathSeparator dir) ++ name ext = takeExtension name- output =- if showLines- then Code.generateWithAnnotation ext enc- else Code.generate enc+ 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,6 +1,6 @@ module Types where -import Data.Text+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)@@ -17,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"@@ -29,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,7 +9,7 @@ import Process import Poll-data Options = Options { optCodeDir :: String+data Options = Options { optCodeDir :: String , optDocsDir :: String , optCss :: Maybe String , optCode :: Bool@@ -29,7 +29,7 @@ , optNumber = False } options :: [ OptDescr (Options -> IO Options) ]-options =+options = [ Option "h" ["html"] (NoArg (\opt -> return opt { optHtml = True })) "Generate html"@@ -44,7 +44,7 @@ , Option "n" ["number"] (NoArg (\opt -> return opt { optNumber = True }))- "Add annotations to generated code noting the source lit file and line number"+ "Add annotations to generated code noting the lit file and line from which it came" , Option "" ["css"] (ReqArg@@ -68,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.1.0"+ hPutStrLn stderr "Version 0.1.10.0" exitWith ExitSuccess)) "Print version"-+ , Option "" ["help"] (NoArg (\_ -> do@@ -88,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@@ -101,17 +101,17 @@ , optCss = mCss , optWatch = watching , optNumber = showLines- } = opts+ } = 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 showLines] else []- pipes = htmlPipe ++ mdPipe ++ codePipe+ 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