{-# LANGUAGE Haskell2010, LambdaCase #-} module Main where import Control.Applicative import System.Environment import Text.Nicify main = getArgs >>= \case [] -> lhs2html <$> getContents >>= putStrLn args -> flip mapM_ args $ \f -> lhs2html <$> readFile f >>= writeFile (f ++ ".html") preamble = "\n\ \\n\ \\n\ \ \n\ \\n\ \\n\ \\n\ \\n
\n" lhs2html :: String -> String lhs2html = (preamble ++) . foldr toHTML "" . parse parse :: String -> [Object] parse = filter (\x -> x /= Empty && x /= Para []) . process . map identify . lines data Object = Empty | Para [String] | Quote [String] | Code [String] | OrdList [String] | List [String] | H1 String | H2 String | H3 String | H1' | H2' | H3' deriving (Eq, Show) identify :: String -> Object identify = \case '>' : ' ' : xs -> Code [xs] '-' : xs | all (== '-') xs -> H2' '-' : ' ' : xs -> List [xs] line@('=' : xs) | all (== '=') xs -> H1' | otherwise -> Para [line] '+' : ' ' : xs -> OrdList [xs] line@(' ' : xs) | all (== ' ') xs -> Empty | otherwise -> Quote [line] '#' : '#' : '#' : ' ' : xs -> H3 xs '#' : '#' : ' ' : xs -> H2 xs '#' : ' ' : xs -> H1 xs [] -> Empty xs -> Para [xs] process :: [Object] -> [Object] process = \case Empty : xs@(Empty : _) -> process xs Para x : Para y : xs -> process (Para (x ++ y) : xs) Para x : H1' : xs -> process (Para (init x) : H1 (last x) : xs) Para x : H2' : xs -> process (Para (init x) : H2 (last x) : xs) Para x : H3' : xs -> process (Para (init x) : H3 (last x) : xs) OrdList x : OrdList y : xs -> process (OrdList (x ++ y) : xs) List x : List y : xs -> process (List (x ++ y) : xs) Quote x : Quote y : xs -> process (Quote (x ++ y) : xs) Code x : Code y : xs -> process (Code (x ++ y) : xs) x : xs -> x : process xs [] -> [] toHTML :: Object -> ShowS toHTML obj xs = case obj of Para ls -> foldr (++) ("

\n" ++ xs) ("

" : map' htmlize ls) Code ls -> foldr (++) ("\n" ++ xs) ("

" : map' (spanify . escape) ls)

    H1 ls -> "
" ++ htmlize ls ++ "
\n" ++ xs
    H2 ls -> "
" ++ htmlize ls ++ "
\n" ++ xs
    H3 ls -> "
" ++ htmlize ls ++ "
\n" ++ xs

    _ -> xs

spanify xs = "" ++ xs ++ ""

map' :: (String -> String) -> [String] -> [String]
map' f = foldr (\a b -> (f a ++ "\n") : b) []

htmlize :: String -> String
htmlize = codify False . escape 

escape :: String -> String
escape = concatMap $ \case
    '<' -> "<"
    '>' -> ">"
    '&' -> "&"
    x -> [x]

codify :: Bool -> String -> String
codify False ('`' : xs) = ""  ++ codify True  xs
codify True  ('`' : xs) = "" ++ codify False xs
codify flag  (x   : xs) = x : codify flag xs
codify _     _          = []