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.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
diff --git a/src/Code.hs b/src/Code.hs
--- a/src/Code.hs
+++ b/src/Code.hs
@@ -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
diff --git a/src/Highlight.hs b/src/Highlight.hs
--- a/src/Highlight.hs
+++ b/src/Highlight.hs
@@ -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
diff --git a/src/Html.hs b/src/Html.hs
--- a/src/Html.hs
+++ b/src/Html.hs
@@ -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 = " underscored <++> "\">" <++> slim <++> ""
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 = " underscored <++> "\" href=\"#" <++> underscored <++> "\">" <++> slim <++> ""
slim = T.strip name
diff --git a/src/Markdown.hs b/src/Markdown.hs
--- a/src/Markdown.hs
+++ b/src/Markdown.hs
@@ -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 =
diff --git a/src/Parse.hs b/src/Parse.hs
--- a/src/Parse.hs
+++ b/src/Parse.hs
@@ -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
diff --git a/src/Poll.hs b/src/Poll.hs
--- a/src/Poll.hs
+++ b/src/Poll.hs
@@ -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
diff --git a/src/Process.hs b/src/Process.hs
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -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
diff --git a/src/Types.hs b/src/Types.hs
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -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"
diff --git a/src/lit.hs b/src/lit.hs
--- a/src/lit.hs
+++ b/src/lit.hs
@@ -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