{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Readme.Convert
( Section (..),
Block (..),
Format (..),
bird,
normal,
parseHs,
printHs,
parseLhs,
printLhs,
parse,
print,
lhs2hs,
hs2lhs
)
where
import qualified Control.Foldl as L
import qualified Data.Attoparsec.Text as A
import qualified Data.List as List
import NumHask.Prelude hiding (print)
data Section = Code | Comment deriving (Show, Eq)
data Block = Block Section [Text] deriving (Show, Eq)
bird :: A.Parser Block
bird =
(\x -> Block Code [x]) <$> ("> " *> A.takeText)
<|> (\_ -> Block Code [""]) <$> (">" *> A.takeText)
<|> (\x -> Block Comment [x]) <$> A.takeText
parseLhs :: [Text] -> [Block]
parseLhs text = L.fold (L.Fold step begin done) $ A.parseOnly bird <$> text
where
begin = (Block Code [], [])
done (Block _ [], out) = unlit' out
done (block, out) = unlit' $ out <> [block]
unlit' ss =
( \(Block s ts) ->
case s of
Comment -> Block s (unlit ts)
Code -> Block s ts
)
<$> ss
step x (Left _) = x
step (Block s ts, out) (Right (Block s' ts')) =
if
| s == s' -> (Block s (ts <> ts'), out)
| otherwise -> case ts of
[] -> (Block s' ts, out)
_ -> (Block s' ts', out <> [Block s ts])
unlit [] = [""]
unlit [""] = [""]
unlit xs =
if
| (head xs == Just "") && (head (reverse xs) == Just "") ->
List.init $ List.tail xs
| (head xs == Just "") ->
List.tail xs
| (head (reverse xs) == Just "") ->
List.init xs
| otherwise ->
xs
printLhs :: [Block] -> [Text]
printLhs ss =
mconcat $
( \(Block s ts) ->
case s of
Code -> ("> " <>) <$> ts
Comment -> lit ts
)
<$> ss
where
lit [] = [""]
lit [""] = [""]
lit xs =
bool [""] [] (head xs == Just "")
<> xs
<> bool [""] [] (List.last xs == "")
normal :: A.Parser (Maybe (Section, Section), [Text])
normal =
(Nothing, [""]) <$ A.endOfInput
<|>
(Just (Comment, Comment), []) <$ ("{-" *> A.endOfInput)
<|> (Just (Comment, Code), []) <$ ("-}" *> A.endOfInput)
<|>
(\x -> (Just (Code, Code), ["{-" <> x <> "-}"]))
<$> ("{-" *> (pack <$> A.manyTill' A.anyChar "-}"))
<|>
(\x -> (Just (Code, Code), ["{-#" <> x])) <$> ("{-#" *> A.takeText)
<|> (\x -> (Just (Code, Code), [x])) <$> (pack <$> A.manyTill' A.anyChar "#-}")
<|>
(\x -> (Just (Comment, Comment), [x])) <$> ("{-" *> A.takeText)
<|>
(\x -> (Just (Comment, Code), [x])) <$> (pack <$> A.manyTill' A.anyChar "-}")
<|>
(\x -> (Nothing, [x])) <$> A.takeText
parseHs :: [Text] -> [Block]
parseHs text = L.fold (L.Fold step begin done) $ A.parseOnly normal <$> text
where
begin = (Block Code [], [])
done (Block _ [], out) = out
done (buff, out) = out <> [buff]
step x (Left _) = x
step (Block s ts, out) (Right (Just (this, next), ts')) =
if
| null (ts <> ts') -> (Block next [], out)
| this == s && next == s -> (Block s (ts <> ts'), out)
| this /= s -> (Block this ts', out <> [Block s ts])
| otherwise -> (Block next [], out <> [Block s (ts <> ts')])
step (Block s ts, out) (Right (Nothing, ts')) =
if
| null (ts <> ts') -> (Block s [], out)
| otherwise -> (Block s (ts <> ts'), out)
printHs :: [Block] -> [Text]
printHs ss =
mconcat $
( \(Block s ts) ->
case s of
Code -> ts
Comment -> ["{-"] <> ts <> ["-}"]
)
<$> ss
data Format = Lhs | Hs
print :: Format -> [Block] -> [Text]
print Lhs f = printLhs f
print Hs f = printHs f
parse :: Format -> [Text] -> [Block]
parse Lhs f = parseLhs f
parse Hs f = parseHs f
lhs2hs :: FilePath -> IO ()
lhs2hs fp = do
t <- readFile (fp <> ".lhs")
writeFile (fp <> ".hs") $ unlines $ print Hs $ parse Lhs $ lines t
hs2lhs :: FilePath -> IO ()
hs2lhs fp = do
t <- readFile (fp <> ".hs")
writeFile (fp <> ".lhs") $ unlines $ print Lhs $ parse Hs $ lines t