Ticket #122: unlit.hs

import Data.Char

main :: IO ()
main = do xs <- getContents
          putStr $ unlines $ unlit BirdAllowed $ lines xs

data State = InCode | InBird | BirdAllowed | BirdNotAllowed
data LineType = BeginCode | EndCode | BirdTrack String | Blank | Normal

unlit :: State -> [String] -> [String]
unlit InCode [] = error "File ended in a code block"
unlit _      [] = []
unlit s (x:xs)
 = case (lineType x, s) of
   -- First deal with code blocks
   (BeginCode,    InCode)         -> error "Can't nest code blocks"
   (BeginCode,    _)              -> unlit InCode              xs
   (EndCode,      InCode)         -> unlit BirdAllowed         xs
   (EndCode,      _)              -> error "Closing non-existent code block"
   (_,            InCode)         -> x  : unlit InCode         xs
   -- Now deal with bird tracks
   (BirdTrack _,  BirdNotAllowed) -> error "Bird track next to stuff"
   (BirdTrack x', _)              -> x' : unlit InBird         xs
   (Normal,       InBird)         -> error "Bird track next to stuff"
   (Normal,       _)              ->      unlit BirdNotAllowed xs
   (Blank,        _)              ->      unlit BirdAllowed    xs

lineType :: String -> LineType
lineType x
 | x `starts` "\\begin{code}" = BeginCode
 | x `starts` "\\end{code}"   = EndCode
 | all isSpace x              = Blank
lineType ('>':x')             = BirdTrack (' ':x')
lineType _                    = Normal

starts :: String -> String -> Bool
x `starts` pref = case x `stripPrefix` pref of
                  Just s
                   | all isSpace s -> True
                   | otherwise -> error ("Trailing characters after " ++ pref)
                  Nothing -> False

stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]
xs `stripPrefix` [] = Just xs
[] `stripPrefix` _ = Nothing
(x:xs) `stripPrefix` (y:ys)
 | x == y = xs `stripPrefix` ys
 | otherwise = Nothing