diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +This stuff is public domain. I hereby waive any copyright. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lhs2html.cabal b/lhs2html.cabal new file mode 100644 --- /dev/null +++ b/lhs2html.cabal @@ -0,0 +1,19 @@ +name: lhs2html +version: 0.99 +synopsis: Compile lhs in bird style to md, html, hs. +license: PublicDomain +license-file: LICENSE +author: Julian Fleischer +maintainer: julian.fleischer@warhog.net +category: Development +build-type: Simple +cabal-version: >=1.10 + +executable lhs2html + main-is: lhs2html.hs + build-depends: base >=4.7 && <4.8, nicify + hs-source-dirs: src + default-language: Haskell2010 + + + diff --git a/src/lhs2html.hs b/src/lhs2html.hs new file mode 100644 --- /dev/null +++ b/src/lhs2html.hs @@ -0,0 +1,143 @@ +{-# 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 _     _          = []
+