{-|
Module      : PP.Builder
Description : Common behavior for defined builders
Copyright   : (c) 2017 Patrick Champion
License     : see LICENSE file
Maintainer  : chlablak@gmail.com
Stability   : provisional
Portability : portable
-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeSynonymInstances #-}
module PP.Builder
    ( -- *(LA)LR
      LrTable(..)
    , action
    , action'
    , LrAction(..)
    , LrCollection(..)
    , LrSet(..)
    , LrBuilder(..)
      -- *NFA
    , NfaGraph(..)
    , NfaNode(..)
    , NfaSymbol(..)
    , NfaBuilder(..)
      -- *DFA
    , DfaGraph(..)
    , DfaNode(..)
    , DfaSymbol(..)
    , DfaBuilder(..)
    ) where

import           Control.Monad
import           Data.Binary
import qualified Data.Graph.Inductive.Graph        as Gr
import qualified Data.Graph.Inductive.PatriciaTree as Gr
import qualified Data.Map.Strict                   as Map
import           Data.Maybe
import qualified Data.Set                          as Set
import qualified Data.Vector                       as Vector
import           PP.Lexer                          (OToken (..))
import           PP.Rule

-- |All LR parsers have the same table format
type LrTable = Map.Map (Int, Rule) LrAction

-- |Get a LrAction from a LrTable (Rule version)
action :: LrTable -> Int -> Rule -> LrAction
action t i r    = fromMaybe LrError (Map.lookup (i, r) t)

-- |Get a LrAction from a LrTable (OToken version)
action' :: LrTable -> Int -> [OToken] -> LrAction
action' t i []                = action t i Empty
action' t i (OToken1 []:_)    = action t i Empty
action' t i (OToken1 (x:_):_) = action t i $ Term x
action' t i (OToken2 _ s:_)   = action t i $ TermToken s

-- |LR actions for a LR parser
data LrAction
  = LrShift Int
  | LrReduce Rule
  | LrGoto Int
  | LrError
  | LrAccept
    deriving(Eq)

instance Show LrAction where
  show (LrShift i)  = "shift " ++ show i
  show (LrReduce r) = "reduce " ++ show r
  show (LrGoto i)   = "goto " ++ show i
  show LrError      = "error"
  show LrAccept     = "accept"

instance Binary LrAction where
  put (LrShift i)  = putWord8 0 >> put i
  put (LrReduce r) = putWord8 1 >> put r
  put (LrGoto i)   = putWord8 2 >> put i
  put LrError      = putWord8 3
  put LrAccept     = putWord8 4
  get = do
    tag <- getWord8
    case tag of
      0 -> fmap LrShift get
      1 -> fmap LrReduce get
      2 -> fmap LrGoto get
      3 -> return LrError
      4 -> return LrAccept

-- |LR items set collection
type LrCollection item = Vector.Vector (LrSet item)

instance (Binary item) => Binary (LrCollection item) where
  put c = put $ Vector.toList c
  get = fmap Vector.fromList get

-- |LR items set
type LrSet item = Set.Set item

-- |LR parser common functions
class Ord item => LrBuilder item where
  -- |Build the items set collection
  collection :: RuleSet -> FirstSet -> LrCollection item
  -- |Build the parsing table
  table :: LrCollection item -> Either [String] LrTable

-- |Nondeterministic finite automaton (NFA)
type NfaGraph = Gr.Gr NfaNode NfaSymbol

-- |NFA node type
data NfaNode = NfaInitial | NfaNode | NfaFinal String deriving (Eq, Ord, Show, Read)

-- |NFA symbol type
data NfaSymbol = NfaValue Char | NfaEmpty deriving (Eq, Ord, Show, Read)

-- |NFA builders
class NfaBuilder from where
  buildNfa :: from -> NfaGraph
  buildNfa' :: String -> from -> NfaGraph

-- |Deterministic finite automaton (DFA)
type DfaGraph = Gr.Gr DfaNode DfaSymbol

-- |DFA node type
data DfaNode = DfaInitial | DfaNode | DfaFinal String deriving (Eq, Ord, Show, Read)

-- |DFA symbol type
newtype DfaSymbol = DfaValue Char deriving (Eq, Ord, Read)

instance Show DfaSymbol where
  show (DfaValue c) = show c

instance Binary DfaGraph where
  put g = put (Gr.labNodes g) >> put (Gr.labEdges g)
  get = liftM2 Gr.mkGraph get get

instance Binary DfaNode where
  put DfaInitial   = putWord8 0
  put DfaNode      = putWord8 1
  put (DfaFinal s) = putWord8 2 >> put s
  get = do
    tag <- getWord8
    case tag of
      0 -> return DfaInitial
      1 -> return DfaNode
      2 -> fmap DfaFinal get

instance Binary DfaSymbol where
  put (DfaValue c) = put c
  get = fmap DfaValue get

-- |DFA builders
class DfaBuilder from where
  buildDfa :: from -> DfaGraph