diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2012 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import System.Environment +import Text.Markdown.Unlit + +main :: IO () +main = getArgs >>= run diff --git a/markdown-unlit.cabal b/markdown-unlit.cabal new file mode 100644 --- /dev/null +++ b/markdown-unlit.cabal @@ -0,0 +1,56 @@ +name: markdown-unlit +version: 0.1.0 +synopsis: Literate Haskell support for GitHub's Markdown flavor +category: Development +license: MIT +license-file: LICENSE +copyright: (c) 2012 Simon Hengel +author: Simon Hengel +maintainer: Simon Hengel +build-type: Simple +cabal-version: >= 1.8 +description: Documentation is here: + +source-repository head + type: git + location: https://github.com/sol/markdown-unlit + +library + ghc-options: + -Wall + hs-source-dirs: + src + exposed-modules: + Text.Markdown.Unlit + build-depends: + base < 5 + +executable markdown-unlit + ghc-options: + -Wall + hs-source-dirs: + driver + main-is: + Main.hs + build-depends: + base + , markdown-unlit + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror + cpp-options: + -DTEST + hs-source-dirs: + src, test + main-is: + Spec.hs + build-depends: + base + , stringbuilder + , directory + , silently + , hspec >= 1.3 + , QuickCheck diff --git a/src/Text/Markdown/Unlit.hs b/src/Text/Markdown/Unlit.hs new file mode 100644 --- /dev/null +++ b/src/Text/Markdown/Unlit.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +module Text.Markdown.Unlit ( + run +, unlit +, Selector (..) +, parseSelector +, CodeBlock (..) +, parse +#ifdef TEST +, parseClasses +#endif +) where + +import Control.Applicative +import Data.Maybe +import Data.List +import Data.Char +import Data.String +import System.IO +import System.Exit +import System.Environment + +-- | Program entry point. +run :: [String] -> IO () +run args = + -- GHC calls unlit like so: + -- + -- > unlit [args] -h label Foo.lhs /tmp/somefile + -- + -- [args] are custom arguments provided with -optL + -- + -- The label is meant to be used in line pragmas, like so: + -- + -- #line 1 "label" + -- + case break (== "-h") args of + (xs, ["-h", _, infile, outfile]) -> + fmap (unlit $ mkSelector xs) (readFile infile) >>= writeFile outfile + _ -> do + name <- getProgName + hPutStrLn stderr ("usage: " ++ name ++ " [selector] -h label infile outfile") + exitFailure + where + mkSelector = fromMaybe (Class "haskell") . parseSelector . unwords + +unlit :: Selector -> String -> String +unlit selector = unlines . concatMap codeBlockContent . filter (toP selector . codeBlockClasses) . parse + where + toP :: Selector -> [String] -> Bool + toP = go + where + go s = case s of + Class c -> elem c + a :&: b -> (&&) <$> go a <*> go b + a :|: b -> (||) <$> go a <*> go b + +infixr 3 :&: +infixr 2 :|: + +data Selector + = Class String + | Selector :&: Selector + | Selector :|: Selector + deriving (Eq, Show) + +parseSelector :: String -> Maybe Selector +parseSelector input = case words input of + [] -> Nothing + xs -> (Just . foldr1 (:|:) . map parseAnds) xs + where + parseAnds = foldr1 (:&:) . map Class . split (== '+') + + -- a copy from https://github.com/sol/string + split :: (Char -> Bool) -> String -> [String] + split p = go + where + go xs = case break p xs of + (ys, []) -> [ys] + (ys, _:zs) -> ys : go zs + +instance IsString Selector where + fromString = Class + +data CodeBlock = CodeBlock { + codeBlockClasses :: [String] +, codeBlockContent :: [String] +} deriving (Eq, Show) + +parse :: String -> [CodeBlock] +parse = go . lines + where + go :: [String] -> [CodeBlock] + go xs = case break isFence xs of + (_, []) -> [] + (_, y:ys) -> case takeCB y ys of + (cb, rest) -> cb : go rest + + takeCB :: String -> [String] -> (CodeBlock, [String]) + takeCB fence xs = case break isFence xs of + (cb, rest) -> (CodeBlock (parseClasses fence) cb, drop 1 rest) + +parseClasses :: String -> [String] +parseClasses xs = case dropWhile isSpace . dropWhile (== '~') $ xs of + '{':ys -> words . replace '.' ' ' . takeWhile (/= '}') $ ys + _ -> [] + +isFence :: String -> Bool +isFence = isPrefixOf "~~~" + +replace :: Char -> Char -> String -> String +replace x sub = map f + where + f y | x == y = sub + | otherwise = y diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}