{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Simple.UUAGC.Parser(parserAG,
                                        parserAG',
                                        scanner,
                                        parseIOAction,
                                        parseClassAG,
                                        parseOptionAG) where

import UU.Parsing
import UU.Scanner
import Distribution.Simple.UUAGC.AbsSyn
import Options
import System.Console.GetOpt
import System.IO.Unsafe(unsafeInterleaveIO)
import System.IO(hPutStr,stderr)
import Control.Monad.Error

data ParserError = DefParserError String
                 deriving (Show, Eq, Read)

instance Error ParserError where
    strMsg x = DefParserError x

uFlags :: [String]
uFlags = concat [ filter (not . null) x | Option _ x _ _ <- options]

kwtxt = uFlags ++ ["file", "options", "class", "with"]
kwotxt = ["=",":","..","."]
sctxt  = "..,"
octxt = "=:.,"

posTxt :: Pos
posTxt = Pos 0 0 ""

puFlag :: OptDescr (Options -> Options) -> Parser Token (Options -> Options)
puFlag (Option _ []  _            _) = pFail
puFlag (Option _ kws (NoArg f)    _) = pAny (\kw -> const f <$> pKey kw) kws
puFlag (Option _ kws (ReqArg f _) _) = pAny (\kw -> f <$ pKey kw <*> pString) kws
puFlag (Option _ kws (OptArg f _) _) = pAny (\kw -> const (f Nothing) <$> pKey kw
                                                    <|> f . Just <$ pKey kw <*> pString) kws

pugFlags :: [Parser Token (Options -> Options)]
pugFlags = map puFlag options

pAnyFlag = pAny id pugFlags

pSep :: Parser Token String
pSep = pKey ":" <|> pKey "="

pFileClasses :: Parser Token [String]
pFileClasses = pKey "with" *> (pCommas pString)
             <|> pSucceed []

pAGFileOption :: Parser Token AGFileOption
pAGFileOption = (\f cl opt -> AGFileOption f cl (constructOptions opt))
                <$> (pKey "file" *> pSep *> pString)
                <*> pFileClasses
                <*> (pKey "options" *> pSep *> pCommas pAnyFlag)

pAGOptionsClass :: Parser Token AGOptionsClass
pAGOptionsClass = (\c opt -> AGOptionsClass c (constructOptions opt))
                  <$> (pKey "class" *> pSep *> pString)
                  <*> (pKey "options" *> pSep *> pCommas pAnyFlag)

pAGFileOptions :: Parser Token AGFileOptions
pAGFileOptions = pList pAGFileOption

parserAG :: FilePath -> IO AGFileOptions
parserAG fp = do s <- readFile fp
                 parseIOAction action pAGFileOptions (scanner fp s)

parserAG' :: FilePath -> IO (Either ParserError AGFileOptions)
parserAG' fp = do s <- readFile fp
                  let steps = parse pAGFileOptions (scanner fp s)
                  let (Pair res _, mesg) = evalStepsMessages steps
                  if null mesg
                     then return $ Right res
                     else do let err = foldr (++) [] $ map message2error mesg
                             return (Left $ DefParserError err)

message2error :: Message Token (Maybe Token) -> String
message2error (Msg e p a) = "Expecting: " ++ (show e) ++ " at " ++ action
    where action = case a of
                     Insert s -> " Inserting: " ++ (show s)
                     Delete s -> " Deleting: " ++ (show s)
                     Other s  -> s

liftParse p text = parseIOAction action p (scanner text text)

parseOptionAG :: String -> IO AGFileOption
parseOptionAG = liftParse pAGFileOption

parseClassAG :: String -> IO AGOptionsClass
parseClassAG = liftParse pAGOptionsClass

scanner     :: String -> String -> [Token]
scanner fn s = scan kwtxt kwotxt sctxt octxt (Pos 0 0 fn) s

action :: (Eq s, Show s, Show p) => Message s p -> IO ()
action m = hPutStr stderr (show m)

test :: (Show a) => Parser Token a -> [Token] -> IO ()
test p inp = do r <- parseIOAction action p inp
                print r

parseIOAction :: (Symbol s, InputState inp s p)
               => (Message s p -> IO ())
               -> AnaParser inp Pair s p a
               -> inp
               -> IO a
parseIOAction  showMessage p inp
 = do  (Pair v final) <- evalStepsIOAction showMessage (parse p inp)
       final `seq` return v -- in order to force the trailing error messages to be printed

evalStepsIOAction :: (Message s p -> IO ())
                  ->  Steps b s p
                  -> IO b
evalStepsIOAction showMessage = evalStepsIOAction' showMessage (-1)


evalStepsIOAction' :: (Message s p -> IO ())
                   -> Int
                   ->  Steps b s p
                   -> IO b
evalStepsIOAction' showMessage n (steps :: Steps b s p) = eval n steps
  where eval                      :: Int -> Steps a s p -> IO a
        eval 0 steps               = return (evalSteps steps)
        eval n steps = case steps of
          OkVal v        rest -> do arg <- unsafeInterleaveIO (eval n rest)
                                    return (v arg)
          Ok             rest -> eval n rest
          Cost  _        rest -> eval n rest
          StRepair _ msg rest -> do showMessage msg
                                    eval (n-1) rest
          Best _   rest   _   -> eval n rest
          NoMoreSteps v       -> return v


evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p])
evalStepsMessages steps = case steps of
     OkVal v             rest -> let (arg, ms) = evalStepsMessages rest
                                 in (v arg, ms)
     Ok                  rest -> evalStepsMessages rest
     Cost _              rest -> evalStepsMessages rest
     StRepair _    msg   rest -> let (v, ms) = evalStepsMessages rest
                                 in (v, msg:ms)
     Best _        rest  _    -> evalStepsMessages rest
     NoMoreSteps v            -> (v,[])