module Text.Markdown.Unlit (
run
, unlit
, Selector (..)
, parseSelector
, CodeBlock (..)
, parse
#ifdef TEST
, parseClasses
#endif
) where
import Prelude ()
import Prelude.Compat
import Data.Maybe
import Data.List.Compat
import Data.Char
import Data.String
import System.IO
import System.Exit
import System.Environment
fenceChars :: [Char]
fenceChars = ['`', '~']
fences :: [String]
fences = map (replicate 3) fenceChars
run :: [String] -> IO ()
run args =
case break (== "-h") args of
(xs, ["-h", fileName, infile, outfile]) ->
fmap (unlit fileName $ mkSelector xs) (readFileUtf8 infile) >>= writeFileUtf8 outfile
_ -> do
name <- getProgName
hPutStrLn stderr ("usage: " ++ name ++ " [selector] -h label infile outfile")
exitFailure
where
mkSelector = fromMaybe ("haskell" :&: Not "ignore") . parseSelector . unwords
readFileUtf8 name = openFile name ReadMode >>= \h -> hSetEncoding h utf8 >> hGetContents h
writeFileUtf8 name str = withFile name WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h str)
unlit :: FilePath -> Selector -> String -> String
unlit fileName selector = unlines . concatMap formatCB . filter (toP selector . codeBlockClasses) . parse
where
formatCB :: CodeBlock -> [String]
formatCB cb = ("#line " ++ show (codeBlockStartLine cb) ++ " " ++ show fileName) : codeBlockContent cb
toP :: Selector -> [String] -> Bool
toP = go
where
go s = case s of
Class c -> elem c
Not p -> not . go p
a :&: b -> (&&) <$> go a <*> go b
a :|: b -> (||) <$> go a <*> go b
infixr 3 :&:
infixr 2 :|:
data Selector
= Class String
| Not Selector
| 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 parseClass . split (== '+')
parseClass c = case c of
'!':xs -> Not (Class xs)
_ -> Class c
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]
, codeBlockStartLine :: Int
} deriving (Eq, Show)
type Line = (Int, String)
parse :: String -> [CodeBlock]
parse = go . zip [2..] . lines
where
go :: [Line] -> [CodeBlock]
go xs = case break isFence xs of
(_, []) -> []
(_, y:ys) -> case takeCB y ys of
(cb, rest) -> cb : go rest
takeCB :: Line -> [Line] -> (CodeBlock, [Line])
takeCB (n, fence) xs =
let indent = length . takeWhile isSpace $ fence
in case break isFence xs of
(cb, rest) -> (CodeBlock (parseClasses fence) (map (drop indent . snd) cb) n, drop 1 rest)
isFence :: Line -> Bool
isFence = p . dropWhile isSpace . snd
where
p :: String -> Bool
p line = any (`isPrefixOf` line) fences
parseClasses :: String -> [String]
parseClasses xs = words . replace '.' ' ' $ case dropWhile isSpace . dropWhile (`elem` fenceChars) . dropWhile isSpace $ xs of
'{':ys -> takeWhile (/= '}') ys
ys -> ys
replace :: Char -> Char -> String -> String
replace x sub = map f
where
f y | x == y = sub
| otherwise = y