module Language.Haskell.Preprocessor.Parser (
  quasi, quasiBy, parse, parseBy, parseTokens, parseTokensBy
) where

import List (delete, union)

import qualified Language.Haskell.Preprocessor.SynSpec as SS
import qualified Language.Haskell.Preprocessor.Error   as E
import qualified Language.Haskell.Preprocessor.Loc     as Loc
import qualified Language.Haskell.Preprocessor.Lexer   as Lexer
import Language.Haskell.Preprocessor.Ast

import qualified Text.ParserCombinators.Parsec as P

quasiBy :: SS.SynSpec -> String -> [Ast] -> [Ast]
quasiBy spec input subs =
  case parseBy spec "<quasi>" input of
    Left e  -> error (show e)
    Right r -> format (Loc.scrub r) subs

quasi :: String -> [Ast] -> [Ast]
quasi = quasiBy SS.defaultSpec

parse :: String -> String -> Either E.Error [Ast]
parse  = parseBy SS.defaultSpec

parseBy :: SS.SynSpec -> String -> String -> Either E.Error [Ast]
parseBy spec file input = parseTokensBy spec tokens where
  tokens = Lexer.scan spec file input

parseTokens :: [Token] -> Either E.Error [Ast]
parseTokens  = parseTokensBy SS.defaultSpec

type Grammar = [Rule]
data Rule = Branch SS.Keyword Grammar
          | Epsilon
  deriving (Eq, Show)

leftFactor :: [[SS.Keyword]] -> Grammar
leftFactor  = foldr add [] where
  add :: [SS.Keyword] -> Grammar -> Grammar
  add []     gram = delete Epsilon gram ++ [Epsilon]
  add (kw:r) gram = case findSplit (headIs kw) gram of
    Just (a, Branch kw' r', c)
            -> Branch (max kw kw') (add r r') : a ++ c
    _       -> Branch kw (add r []) : gram

  max (SS.I kw) _ = SS.I kw
  max _ (SS.I kw) = SS.I kw
  max x _         = x

  headIs kw (Branch kw' _) = SS.getKey kw == SS.getKey kw'
  headIs _  _              = False

  findSplit _    [] = Nothing
  findSplit pred (x:xs)
    | pred x        = Just ([], x, xs)
    | otherwise     = do (a, b, c) <- findSplit pred xs
                         Just (x:a, b, c)

parseTokensBy :: SS.SynSpec -> [Token] -> Either E.Error [Ast]
parseTokensBy spec input = case P.parse start source input of
    Left pe    -> Left (E.fromParseError pe)
    Right asts -> Right asts
  where

  gram = leftFactor (SS.blocks spec)

  start = do
    res <- until []
    P.eof
    return res

  source = case input of
    t:_ -> Loc.file (loc t)
    _   -> "<bogus>"

  until stop = P.many (any stop)

  any stop   = parseRules gram (single stop) stop

  single stop = do
    item <- tokenP (\i -> val i `notElem` stop && tag i /= VDedent)
    return (Single item)

  parseRules r orelse stop =
    foldr (<|>) orelse (map (flip parseRule stop) r)

  parseRule Epsilon _                           = return Empty
  parseRule (Branch (SS.I key) r) stop          = do
    item <- tokenV key
    curlyBraces item r stop <|> virtualBraces item r stop
  parseRule (Branch (SS.P key) [Epsilon]) _     = do
    item <- tokenV key
    return (Single item)
  parseRule (Branch (SS.P key) r) stop          = do
    item <- tokenV key
    body <- until (follow stop r)
    next <- parseRules r P.pzero stop           <??> r
    return (Block item Nothing body Nothing next)

  curlyBraces item r stop                       = do
    lbrace <- tokenV "{"                        <?> "{"
    body   <- until ["}"]
    rbrace <- tokenV "}"                        <?> "}"
    next   <- parseRules r P.pzero stop         <??> r
    return (Block item (Just lbrace) body (Just rbrace) next)

  virtualBraces item r stop                     = do
    lbrace <- tokenT VIndent
    body   <- until (follow stop r)
    rbrace <- do
                vbrace <- tokenT VDedent
                return (Just vbrace)
          <|> do
                killDedent
                return Nothing
    next   <- parseRules r P.pzero stop         <??> r
    return (Block item (Just lbrace) body rbrace next)

  follow oldStop r
    | Epsilon `elem` r = oldStop `union` newStop
    | otherwise        = newStop
    where newStop = [ SS.getKey kw | Branch kw _ <- r ]

  killDedent = do
      inp <- P.getInput
      P.setInput (clean 0 inp)
    where
      clean     :: Int -> [Token] -> [Token]
      clean _ [] = []
      clean 0 (  Token { tag = VDedent }:r) = r
      clean n (t@Token { tag = VIndent }:r) = t : clean (n + 1) r
      clean n (t@Token { tag = VDedent }:r) = t : clean (n - 1) r
      clean n (t                        :r) = t : clean n r

  tokenRaw :: (Token -> Maybe a) -> P.GenParser Token () a
  tokenRaw = P.token val (Loc.toSourcePos . loc)

  token :: (Token -> Maybe a) -> P.GenParser Token () a
  token pred = tokenRaw pred <|> errorToken

  tokenP :: (Token -> Bool) -> P.GenParser Token () Token
  tokenP pred = token (\i -> if pred i then Just i else Nothing)

  tokenV :: String -> P.GenParser Token () Token
  tokenV v = tokenP ((== v) . val)

  tokenT :: Tag -> P.GenParser Token () Token
  tokenT t = tokenP ((== t) . tag)

  errorToken :: P.GenParser Token () a
  errorToken = do
    tok <- tokenRaw (\i -> if tag i == Error then Just i else Nothing)
    P.setPosition (Loc.toSourcePos (loc tok))
    fail (val tok)

  (<|>) = (P.<|>)
  (<?>) = (P.<?>)

  p <??> []              = p
  p <??> (Epsilon:_)     = p
  p <??> (Branch kw _:r) = (p <?> SS.getKey kw) <??> r