{-# LANGUAGE DeriveDataTypeable #-}
{-|
Module : PP.Templates.Lr
Description : LR template
Copyright : (c) 2017 Patrick Champion
License : see LICENSE file
Maintainer : chlablak@gmail.com
Stability : provisional
Portability : portable
-}
module PP.Templates.Lr
( LrContext
, context
) where
import Data.Char
import Data.Data
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Typeable
import PP.Builder
import PP.Rule
import PP.Template
import Text.StringTemplate
import Text.StringTemplate.GenericStandard
-- |LR table context
data LrContext = LrContext
{ states :: [LrContextState] -- ^States informations
, terms :: [LrContextTerm] -- ^Terminals informations
, nonTerms :: [LrContextNonTerm] -- ^Non-terminals informations (without length)
, table :: LrContextTable -- ^LR table informations
} deriving (Data, Typeable, Eq)
data LrContextState = LrContextState
{ id :: Int -- ^State ID
, alt :: LrContextNonTerm -- ^Associated non-terminal (not impl. yet)
} deriving (Data, Typeable, Eq)
data LrContextTerm = LrContextTerm
{ symbol :: Char -- ^Terminal symbol
, isEmpty :: Bool -- ^It's the EMPTY symbol?
} deriving (Data, Typeable, Eq)
data LrContextNonTerm = LrContextNonTerm
{ name :: String -- ^Non-terminal name
, length :: Int -- ^Rule length (right side)
} deriving (Data, Typeable, Eq)
data LrContextTable = LrContextTable
{ rows :: [LrContextTableRow] -- ^Table flatten in rows only
, total :: Int -- ^Total rows (with errors)
} deriving (Data, Typeable, Eq)
data LrContextTableRow = LrContextTableRow
{ state :: LrContextState -- ^Row state
, isTerm :: Bool -- ^Row state is associated with ?
, term :: LrContextTerm -- ^Row is associated with terminal
, nonTerm :: LrContextNonTerm -- ^Row is associated with non-terminal
, action :: LrContextAction -- ^Associated action
} deriving (Data, Typeable, Eq)
data LrContextAction = LrContextAction
{ isReduce :: Bool -- ^Is action reduce?
, isShift :: Bool -- ^Is action shift?
, isGoto :: Bool -- ^Is action goto?
, isError :: Bool -- ^Is action error?
, isAccept :: Bool -- ^Is action accept?
, shift :: Int -- ^Shift value
, goto :: Int -- ^Goto value
, reduce :: LrContextNonTerm -- ^Reduce associated non-terminal (with length)
} deriving (Data, Typeable, Eq)
-- |Construct the LR context
context :: LrTable -> LrContext
context t = LrContext states' terms' nonTerms' table'
where
states' = L.nub [LrContextState i (nonTerm' Empty) | ((i, _), _) <- list']
terms' = term' Empty : L.nub [term' r | ((_, r), _) <- list', isTerm' r]
nonTerms' = L.nub [nonTerm' r | ((_, r), _) <- list', isNonTerm' r]
table' = LrContextTable rows'
(L.length states' * (L.length terms' + L.length nonTerms'))
rows' = [LrContextTableRow (LrContextState i (nonTerm' Empty))
(isTermOrEmpty' r)
(term' r)
(nonTerm' r)
(action' a)
| ((i, r), a) <- list']
term' (Term x) = LrContextTerm x False
term' Empty = LrContextTerm (chr 0) True
term' _ = LrContextTerm (chr 0) False
nonTerm' (NonTerm n) = LrContextNonTerm n (-1)
nonTerm' _ = LrContextNonTerm "" (-1)
action' (LrReduce (Rule n xs)) =
LrContextAction True False False False False (-1) (-1)
(LrContextNonTerm n (L.length xs - 1))
action' (LrShift s) =
LrContextAction False True False False False s (-1) (nonTerm' Empty)
action' (LrGoto s) =
LrContextAction False False True False False (-1) s (nonTerm' Empty)
action' LrError =
LrContextAction False False False True False (-1) (-1) (nonTerm' Empty)
action' LrAccept =
LrContextAction False False False False True (-1) (-1) (nonTerm' Empty)
list' = Map.toList t
isTerm' (Term _) = True
isTerm' _ = False
isTermOrEmpty' (Term _) = True
isTermOrEmpty' Empty = True
isTermOrEmpty' _ = False
isNonTerm' (NonTerm _) = True
isNonTerm' _ = False
isReduce' (LrReduce _) = True
isReduce' _ = False
-- |Template instance for LrContext
instance Template LrContext where
attributes = setAttribute "lr"