content: {- |
  Module      :  ./Common/RunParsers.hs
  Description :  test some parsers (and printers)
  Copyright   :  (c) Christian Maeder and Uni Bremen 2002-2003
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  test some parsers (and printers)
  -}
  
  module Common.RunParsers (exec, StringParser, toStringParser, fromAParser)
      where
  
  import Common.AnalyseAnnos (addGlobalAnnos)
  import Common.AnnoParser
  import Common.AnnoState
  import Common.DocUtils
  import Common.GlobalAnnotations
  import Common.Lexer (parseString)
  import Common.Parsec ((<<))
  import Common.Result
  import Common.IO
  
  import System.Environment
  
  import Text.ParserCombinators.Parsec
  import Text.ParserCombinators.Parsec.Pos
  
  type StringParser = GlobalAnnos -> AParser () String
  
  fromAParser :: Pretty a => AParser () a -> StringParser
  fromAParser p ga = fmap (flip (showGlobalDoc ga) "") p
  
  toStringParser :: Pretty a => (GlobalAnnos -> AParser () a) -> StringParser
  toStringParser p ga = fmap (flip (showGlobalDoc ga) "") $ p ga
  
  exec :: [(String, StringParser)] -> [(String, StringParser)] -> IO ()
  exec lps fps = do
    l <- getArgs
    setStdEnc Utf8
    case l of
     [] -> parseSpec emptyGlobalAnnos . snd $ head fps
     opt : tl -> do
      let lps' = filter (\ (s, _) -> s == opt) lps
          fps' = filter (\ (s, _) -> s == opt) fps
      ga <- case tl of
       [] -> return emptyGlobalAnnos
       annoFile : _ -> do
          str <- readFile annoFile
          maybe (error "run parser") return $ maybeResult
            $ addGlobalAnnos emptyGlobalAnnos
            $ parseString annotations str
            -- should not fail but may return empty annos
      case (lps', fps') of
        ([], []) -> do
          putStrLn ("unknown option: " ++ opt)
          p <- getProgName
          putStrLn $ "Usage: " ++ p ++ " [OPTIONS] <Annotations> < infile"
          putStrLn "where OPTIONS is one of:"
          putStrLn $ unwords $ map fst lps ++ map fst fps
        ([], (_, hd) : _) -> parseSpec ga hd
        ((_, hd) : _, _) -> checkLines ga hd
  
  checkLines :: GlobalAnnos -> StringParser -> IO ()
  checkLines ga p =
    getContents >>= putStr . unlines . scanLines ga p 1 . lines
  
  scanLines :: GlobalAnnos -> StringParser -> Line -> [String] -> [String]
  scanLines ga p n inp = case inp of
    [] -> []
    x : l -> parseLine ga p x n : scanLines ga p (n + 1) l
  
  parseLine :: GlobalAnnos -> StringParser -> String -> Line -> String
  parseLine ga p line n =
      let pos = setSourceLine (initialPos "") n
          parser = do
            setPosition pos
            i <- p ga
            eof
            return i
          in showParse $ runParser parser (emptyAnnos ()) "" line
  
  parseSpec :: GlobalAnnos -> StringParser -> IO ()
  parseSpec ga p =
    getContents >>= putStrLn . showParse
      . runParser (p ga << eof) (emptyAnnos ()) ""
  
  showParse :: Either ParseError String -> String
  showParse e = case e of
    Left err -> "parse error at " ++ showErr err ++ "\n"
    Right x -> x
  