content: {-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-}
  
  module Text.Markdown.Pap.Parser (
      parseMrd
  ) where
  
  import Control.Arrow
  import "monads-tf" Control.Monad.State
  import "monads-tf" Control.Monad.Error
  import Data.Maybe
  import Data.Char
  import Text.Papillon
  
  import Text.Markdown.Pap.Text
  
  parseMrd :: String -> Maybe [Text]
  parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of
      (Right (r, _), _) -> Just r
      _ -> Nothing
  
  clear :: State (Int, [Int]) Bool
  clear = put (0, [- 1]) >> return True
  
  reset :: State (Int, [Int]) Bool
  reset = modify (first $ const 0) >> return True
  
  count :: State (Int, [Int]) ()
  count = modify $ first (+ 1)
  
  deeper :: State (Int, [Int]) Bool
  deeper = do
      (n, n0 : ns) <- get
      if n > n0 then put (n, n : n0 : ns) >> return True else return False
  
  same :: State (Int, [Int]) Bool
  same = do
      (n, n0 : _) <- get
      return $ n == n0
  
  shallow :: State (Int, [Int]) Bool
  shallow = do
      (n, n0 : ns) <- get
      if n < n0 then put (n, ns) >> return True else return False
  
  [papillon|
  
  monad: State (Int, [Int])
  
  markdown :: [Text]
      = md:(m:markdown1 _:dmmy[clear] { return m })*      { return md }
  
  markdown1 :: Text
      = h:header              { return h }
      / l:link '\n'*              { return l }
      / i:image '\n'*             { return i }
      / l:list '\n'*              { return $ List l }
      / c:code                { return $ Code c }
      / p:paras               { return $ Paras p }
  
  header :: Text
      = n:sharps _:<isSpace>* l:line '\n'+    { return $ Header n l }
      / l:line '\n' _:equals '\n'+        { return $ Header 1 l }
      / l:line '\n' _:hyphens '\n'+       { return $ Header 2 l }
  
  sharps :: Int
      = '#' n:sharps              { return $ n + 1 }
      / '#'                   { return 1 }
  
  equals :: ()
      = '=' _:equals
      / '='
  
  hyphens :: ()
      = '-' _:hyphens
      / '-'
  
  line :: String
      = l:<(`notElem` "#\n")>+        { return l }
  
  line' :: String
      = l:<(`notElem` "\n")>+         { return l }
  
  code :: String
      = l:fourSpacesLine c:code       { return $ l ++ c }
      / l:fourSpacesLine          { return l }
  
  fourSpacesLine :: String
      = _:fourSpaces l:line' ns:('\n' { return '\n' })+   { return $ l ++ ns }
  
  fourSpaces :: ()
      = ' ' ' ' ' ' ' '
  
  list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw  { return $ l : ls }
  
  cnt :: () = _:dmmy[reset] _:(' ' { count })*
  
  list1' :: List1
      = _:cnt _:dmmy[same] l:list1        { return l }
  
  list1 :: List1
      = _:listHead ' ' l:line '\n' ls:list?
          { return $ BulItem l $ fromMaybe [] ls }
      / _:nListHead ' ' l:line '\n' ls:list?
          { return $ OrdItem l $ fromMaybe [] ls }
  
  listHead :: ()
      = '*' / '-' / '+'
  
  nListHead :: ()
      = _:<isDigit>+ '.'
  
  paras :: [String]
      = ps:para+              { return ps }
  
  para :: String
      = ls:(!_:('!') !_:listHead !_:nListHead !_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para)
                          { return $ unwords ls }
  
  shllw :: ()
      = _:dmmy[shallow]
      / !_
      / !_:list
  
  dmmy :: () =
  
  link :: Text
      = '[' t:<(/= ']')>+ ']' ' '* '(' a:<(/= ')')>+ ')' { return $ Link t a "" }
  
  image :: Text
      = '!' '[' alt:<(/= ']')>+ ']' ' '* '(' addrs:<(`notElem` ")\" ")>+ ' '*
          '"' t:<(/= '"')>+ '"' ')'
          { return $ Image alt addrs t }
  
  |]
  