{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Readme.Convert
( Section (..),
Block (..),
Format (..),
bird,
normal,
parseHs,
printHs,
parseLhs,
printLhs,
parse,
print,
)
where
import qualified Control.Foldl as L
import qualified Data.Attoparsec.Text as Text
import qualified Data.List as List
import qualified Data.Text as Text
import Protolude hiding (print)
data Section = Code | Comment deriving (Show, Eq)
data Block = Block Section [Text] deriving (Show, Eq)
bird :: Text.Parser Block
bird =
(\x -> Block Code [x]) <$> ("> " *> Text.takeText)
<|> (\_ -> Block Code [""]) <$> (">" *> Text.takeText)
<|> (\x -> Block Comment [x]) <$> Text.takeText
parseLhs :: [Text] -> [Block]
parseLhs text = L.fold (L.Fold step begin done) $ Text.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
| (Protolude.head xs == Just "") && (Protolude.head (reverse xs) == Just "") ->
List.init $ List.tail xs
| (Protolude.head xs == Just "") ->
List.tail xs
| (Protolude.head (reverse xs) == Just "") ->
List.init xs
| otherwise ->
xs
printLhs :: [Block] -> [Text]
printLhs ss =
Protolude.mconcat $
( \(Block s ts) ->
case s of
Code -> ("> " <>) <$> ts
Comment -> lit ts
)
<$> ss
where
lit [] = [""]
lit [""] = [""]
lit xs =
(if Protolude.head xs == Just "" then [] else [""])
<> xs
<> (if List.last xs == "" then [] else [""])
normal :: Text.Parser (Maybe (Section, Section), [Text])
normal =
(\_ -> (Nothing, [""])) <$> Text.endOfInput
<|>
(\_ -> (Just (Comment, Comment), [])) <$> ("{-" *> Text.endOfInput)
<|> (\_ -> (Just (Comment, Code), [])) <$> ("-}" *> Text.endOfInput)
<|>
(\x -> (Just (Code, Code), ["{-" <> x <> "-}"]))
<$> ("{-" *> (Text.pack <$> Text.manyTill' Text.anyChar "-}"))
<|>
(\x -> (Just (Code, Code), ["{-#" <> x])) <$> ("{-#" *> Text.takeText)
<|> (\x -> (Just (Code, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "#-}")
<|>
(\x -> (Just (Comment, Comment), [x])) <$> ("{-" *> Text.takeText)
<|>
(\x -> (Just (Comment, Code), [x])) <$> (Text.pack <$> Text.manyTill' Text.anyChar "-}")
<|>
(\x -> (Nothing, [x])) <$> Text.takeText
parseHs :: [Text] -> [Block]
parseHs text = L.fold (L.Fold step begin done) $ Text.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
| 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
| ts <> ts' == [] -> (Block s [], out)
| otherwise -> (Block s (ts <> ts'), out)
printHs :: [Block] -> [Text]
printHs ss =
Protolude.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