{-|
Module      : PP.Lexers.Dfa
Description : Lexer simulation with DFA
Copyright   : (c) 2017 Patrick Champion
License     : see LICENSE file
Maintainer  : chlablak@gmail.com
Stability   : provisional
Portability : portable
-}
module PP.Lexers.Dfa
    ( DfaConfig
    , dfaConfig
    , createDfa
    , createDfa'
    ) where

import           Control.Exception
import           Data.Either
import qualified Data.Graph.Inductive.Graph as Gr
import           Data.Maybe
import           PP.Builder
import           PP.Builders.Dfa
import           PP.Builders.Nfa
import           PP.Grammar
import           PP.Grammars.Lexical
import           PP.Lexer
import           PP.Rule

-- |DFA configuration
data DfaConfig = DfaConfig
  { dfaInput  :: [IToken]             -- ^Input tokens
  , dfaBuffer :: [IToken]             -- ^Buffer
  , dfaOutput :: [OToken]             -- ^Output tokens
  , dfaGraph  :: DfaGraph             -- ^Automaton
  , dfaPath   :: [Gr.LNode DfaNode]   -- ^Path for the current buffer
  }

instance Show DfaConfig where
  show (DfaConfig is bs os _ ps) =
    "DfaConfig {dfaInput = " ++ show is ++
    ", dfaBuffer = " ++ show bs ++
    ", dfaOutput = " ++ show os ++
    ", dfaGraph = ..., dfaPath = " ++ show ps ++ "}"

-- |Lexer instance for DFA configuration
-- Dragon Book (2nd edition, fr), page 156, example 3.28
instance Lexer DfaConfig where
  simulate = simulateDfa
  consumed c = null $ dfaInput c
  output = reverse . dfaOutput
  consume c = if consumed c then simulate c else consume $ simulate c

-- |Create DFA configuration
dfaConfig :: String -> DfaGraph -> DfaConfig
dfaConfig s g = DfaConfig s [] [] g [findInitial g]

-- |Create a complete DFA from a list of lexical rules
createDfa :: [Rule] -> DfaGraph
createDfa = buildDfa . combineNfa . map createNfa . regexfy
  where
    createNfa (Rule n (RegEx re:_)) =
      case parseAst re :: To RegExpr of
        Left e    -> error $ show e
        Right ast -> buildNfa' n ast

-- |Exception-safe version of `createDfa`
createDfa' :: [Rule] -> IO (Either String DfaGraph)
createDfa' rs = do
    a <- try (evaluate $ createDfa rs) :: IO (Either SomeException DfaGraph)
    case a of
        Left e  -> return $ Left $ head $ lines $ displayException e
        Right r -> return $ Right r

-- |Simulate one iteration
simulateDfa :: DfaConfig -> DfaConfig
simulateDfa c@(DfaConfig [] _ _ _ _) = reducePath c
simulateDfa c@(DfaConfig (i:is) bs os g ps@(p:_)) =
  case findNext g i p of
    Nothing -> reducePath c
    Just q  -> DfaConfig is (i:bs) os g (q:ps)

-- |Find next node
findNext :: DfaGraph -> IToken -> Gr.LNode DfaNode -> Maybe (Gr.LNode DfaNode)
findNext g i (n, _) =
  case map fst $ filter (\(_, DfaValue v) -> i == v) $ Gr.lsuc g n of
    []  -> Nothing
    [m] -> Just (m, fromMaybe DfaNode $ Gr.lab g m)

-- |Reduce path to initial node and construct an output token, if any
reducePath :: DfaConfig -> DfaConfig
reducePath c@(DfaConfig [] _ _ _ ((_, DfaInitial):_)) = c
reducePath (DfaConfig (_:is) bs os g ps@((_, DfaInitial):_)) =
  DfaConfig is bs os g ps
reducePath (DfaConfig is (b:bs) os g ((_, DfaNode):ps)) =
  reducePath $ DfaConfig (b:is) bs os g ps
reducePath (DfaConfig is bs os g ((_, DfaFinal n):_)) =
  DfaConfig is [] (OToken2 (reverse bs) n:os) g [findInitial g]

-- |Find initial node
findInitial :: DfaGraph -> Gr.LNode DfaNode
findInitial g = let [n] = filter isInitial (Gr.labNodes g) in n
  where
    isInitial (_, DfaInitial) = True
    isInitial _               = False