packages feed

lit 0.1.0.1 → 0.1.0.2

raw patch · 6 files changed

+406/−3 lines, 6 files

Files

lit.cabal view
@@ -1,12 +1,12 @@ -- Initial lit.cabal generated by cabal init.  For further documentation,   name:                lit-version:             0.1.0.1+version:             0.1.0.2 synopsis:            A simple tool for literate programming description:         lit has a minimal syntax for implementing literate                      programming. It generates both HTML and the native-                     source code. Follow active development here https://github.com/cdosborn/lit-homepage:            cdosborn.com+                     source code.+homepage:            https://github.com/cdosborn/lit license:             GPL license-file:        LICENSE author:              cdosborn@@ -16,9 +16,14 @@ build-type:          Simple cabal-version:       >=1.8 +Source-repository head+  type: git+  location: git://github.com/cdosborn/lit.git+ executable lit   main-is:           lit.hs     hs-source-dirs:    src+  other-modules:     Parse, Poll, Pretty, Processing, Types   build-depends:     base ==4.*,                      text ==1.1.*,                       regex-compat ==0.95.*,
+ src/Parse.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}+module Parse where++import Text.Regex+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++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++chunk :: Parser Chunk+chunk = (try def) <|> prose++--prose :: Parser Chunk+--prose = do +--    txts <- manyTill grabLine beginDef+--    return $ Prose $ T.concat txts+prose :: Parser Chunk+prose = do +    txt <- packM =<< many (noneOf "\n\r")+    nl <- eol >>= (\c -> return $ T.singleton c)+    return $ Prose (txt `T.append` nl)++def :: Parser Chunk+def = do+    (indent, header, lineNum) <- title+    parts <- manyTill (part indent) $ endDef indent+    return $ Def lineNum header parts++part :: String -> Parser Part+part indent =+    try (string indent >> varLine) <|> +    try (string indent >> defLine) <|> +    (grabLine >>= (\extra -> return (Code $ extra)))+  --(newline >>= (\nl -> return (Code $ T.singleton nl)))++varLine :: Parser Part+varLine = do+    name <- packM =<< between (string "<<") (string ">>") (many notDelim)+    eol+    return $ Ref name++defLine :: Parser Part+defLine = do+    line <- grabLine +    return $ Code line++-- Post: Consume newlines between a Code Chunk's last line and a Prose+--endDef :: String -> Parser ()+--endDef indent = try (skipMany newline >> (notFollowedBy (string indent) <|> ((lookAhead title) >> parserReturn ())))++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++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)++notDelim = noneOf ">="+ws :: Parser Char+ws = char ' ' <|> char '\t'  -- consume a whitespace char+eol :: Parser Char+eol = char '\n' <|> char '\r'++fileNameFromPath :: String -> String+fileNameFromPath path =+    let r = mkRegex "(\\w+\\.\\w+)\\.lit$"+        m = matchRegex r path +    in case m of +        Just (fst:rest) -> fst+        Nothing -> ""
+ src/Poll.hs view
@@ -0,0 +1,37 @@+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 = do +    putStrLn "starting.."+     -- total microseconds for each file to cause a 1 sec delay per loop+    let delay = 1000000 `div` (length fs)+    forever $ mapM_ (onDiff fun delay) fs++onDiff :: (String -> IO ()) -> Int -> String -> IO ()+onDiff fun delay file = do+    modified <- errorHandler (getModificationTime file) +    curTime <- getCurrentTime +    let diff = (diffUTCTime curTime modified)++    if diff < 1 then fun file >> C.threadDelay delay else return ()+ ++-- a really conservative check to prevent file+-- "inavailability" due to reading modification bits+errorHandler = errorHandlerNTimes 100++errorHandlerNTimes 0 mnd = catchIOError mnd (\e -> ioError e)+errorHandlerNTimes times mnd = catchIOError mnd handle +    where   +        handle e =+            if isDoesNotExistError e +            then C.threadDelay 5000 >> errorHandlerNTimes (times - 1) mnd+            else ioError e
+ src/Pretty.hs view
@@ -0,0 +1,122 @@+{-# 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+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 -> [Chunk] -> T.Text+pretty lang maybeCss chunks = +    TL.toStrict $ renderHtml $ preface maybeCss $ 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 -> H.Html -> H.Html+preface mCss rest = H.docTypeHtml $ do +    let css = toValue $ fromMaybe "" mCss+    H.head $ do+        H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href css+    H.body $ do rest+            ++chunkToHtml :: String -> Chunk -> H.Html+chunkToHtml lang chunk =+    case chunk of+    Prose txt -> toMarkup $ 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 = "<a href=\"#" `T.append` slim `T.append` "\">" `T.append` slim `T.append` "</a>"+            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 = "<a id=\"" `T.append` slim `T.append` "\" href=\"#" `T.append` slim `T.append` "\">" `T.append` slim `T.append` "</a>"+        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
+ src/Processing.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}+module Processing +( build+, htmlPipeline+, mdPipeline+, codePipeline +, simplify ) where++import Prelude hiding (readFile, writeFile)+import Data.Text.IO (writeFile, readFile)++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 = fileNameFromPath 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 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++-- many consecutive Proses are reduced to a single Prose+simplify :: [Chunk] -> [Chunk]+simplify [] = []+simplify lst =+    let (defs, ps) = span isDef lst+        (ps', rest) = break isDef ps+    in case ps' of+        [] -> defs ++ rest+        _ -> defs ++ [mergeProse ps'] ++ (simplify rest)++mergeProse :: [Chunk] -> Chunk+mergeProse lst = +    Prose $ T.concat $ map getProseText lst++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)
+ src/Types.hs view
@@ -0,0 +1,7 @@+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)+type Program = [Chunk]