{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}

module Pugs.Parser.Types (
    RuleParser, RuleState(..), CharClass(..),
    DynParsers(..), ParensOption(..), FormalsOption(..), BracketLevel(..),
    RuleOperator, RuleOperatorTable,
    getRuleEnv, modifyRuleEnv, putRuleEnv, insertIntoPosition,
    clearDynParsers, enterBracketLevel, getCurrCharClass, charClassOf,
    addBlockPad, popClosureTrait, addClosureTrait, addOuterVar,
    -- Alternate Char implementations that keeps track of s_charClass
    satisfy, string, oneOf, noneOf, char, hexDigit, octDigit,
    digit, upper, anyChar, expRule, parserWarn, mkPos,

    Operator(..), Assoc(..),
) where
import Pugs.AST
import Pugs.Rule
import Pugs.Types
import Pugs.Internals
import Pugs.Pretty (pretty)
import Text.ParserCombinators.Parsec.Pos
import Debug.Trace
import qualified Data.Map as Map
import qualified Data.Set as Set

{-# INLINE satisfy #-}
satisfy :: (Char -> Bool) -> RuleParser Char
satisfy f = tokenPrim
    (\c -> show [c]) 
    (\pos c _ -> updatePosChar pos c) 
    -- (Just (\_ c _ state -> state{ s_char = c }))
    (\c -> if f c then Just c else Nothing)

{-# INLINE string #-}
string :: String -> RuleParser String
string s = tokens show updatePosString s
--    `finallyM` modify (\state -> state{ s_char = last s })

{-
_captureNamed :: ID -> RuleParser a -> RuleParser a
_captureNamed newState rule = do
    prev <- gets s_name
    modify $ \state -> state{ s_name = newState }
    rv <- rule
    modify $ \state -> state{ s_name = prev }
    return rv

_capturePositioned :: Int -> RuleParser a -> RuleParser a
_capturePositioned pos rule = do
    prev <- gets s_pos
    modify $ \state -> state{ s_pos = pos }
    rv <- rule
    modify $ \state -> state{ s_pos = prev }
    return rv
-}

charClassOf :: Char -> CharClass
charClassOf c   | isAlphaNum c  = WordClass
                | isSpace c     = SpaceClass
                | '_' <- c      = WordClass
                | otherwise     = SymClass

getCurrCharClass :: RuleParser CharClass
getCurrCharClass = fmap charClassOf (lookAhead anyToken) <|> return SpaceClass

{-
getPrevCharClass :: RuleParser CharClass
getPrevCharClass = do
    p   <- gets s_wsPos
    p'  <- getPosition
    return (if (p == p') then SpaceClass else WordClass)
-}

oneOf, noneOf :: [Char] -> RuleParser Char
oneOf cs    = satisfy (\c -> elem c cs)
noneOf cs   = satisfy (\c -> not (elem c cs))

char :: Char -> RuleParser Char
char c      = satisfy (==c)  <?> show [c]

hexDigit, octDigit, digit, upper :: RuleParser Char
hexDigit    = satisfy (isHexDigit)  <?> "hexadecimal digit"
octDigit    = satisfy (isOctDigit)  <?> "octal digit"

digit       = satisfy (isDigit)     <?> "digit"
upper       = satisfy (isUpper)     <?> "uppercase letter"

{-
whiteSpace  = satisfy (\c -> charClassOf c == SpaceClass)
                                    <?> "whitespace"
-}

{-
perl6WhiteSpace :: RuleParser String
perl6WhiteSpace = do
    cls <- getPrevCharClass 
    let mod = if cls == WordClass then many1 else many
    mod whiteSpace <|> (satisfy (\c -> charClassOf c /= WordClass) >> return "")
-}

anyChar :: RuleParser Char
anyChar     = satisfy (const True)

{-|
Cache holding dynamically-generated parsers for user-defined operators.  This
means we don't have to rebuild them for each token.

The cache is generated inside 'Pugs.Parser.parseOpWith'.
It is cleared each time we do compile-time evaluation with
'Pugs.Parser.Unsafe.unsafeEvalExp', by calling 'clearDynParsers'.

Stored inside 'RuleState', the state component of 'RuleParser'.
-}
data DynParsers = MkDynParsersEmpty | MkDynParsers
    { dynParseOp       :: !(RuleParser Exp)
    , dynParseTightOp  :: !(RuleParser Exp)
    , dynParseLitOp    :: !(RuleParser Exp)
    , dynParseNullary  :: !(RuleParser Exp)
    , dynParsePrePost  :: !(RuleParser String)
    }

{-|
State object that gets passed around during the parsing process.
-}
data RuleState = MkState
    { s_env           :: Env
    , s_parseProgram  :: (Env -> FilePath -> String -> Env)
    , s_dynParsers    :: DynParsers     -- ^ Cache for dynamically-generated
                                        --     parsers
    , s_bracketLevel  :: !BracketLevel  -- ^ The kind of "bracket" we are in
                                        --     part and has to suppress {..} literals
--  , s_char          :: Char           -- ^ What the previous character contains
--  , s_name          :: !ID            -- ^ Capture name
--  , s_pos           :: !Int           -- ^ Capture position
    , s_wsLine        :: !Line          -- ^ Last whitespace position
    , s_wsColumn      :: !Column        -- ^ Last whitespace position
    , s_blockPads     :: Map Scope Pad  -- ^ Hoisted pad for this block
    , s_outerVars     :: Set Var        -- ^ OUTER symbols we remembers
                                       
    , s_closureTraits :: [VCode -> VCode]
                                       -- ^ Closure traits: head is this block, tail is all outer blocks
    }

data BracketLevel
    = ConditionalBracket    -- if ... {}
    | StatementBracket      -- ... ; ...
    | ParensBracket         -- (...)
    | QuoteAdverbBracket    -- q...
    deriving (Show, Eq)

{-|
A parser that operates on @Char@s, and maintains state in a 'RuleState'.
-}
type RuleParser = GenParser Char RuleState

data CharClass = WordClass | SpaceClass | SymClass
    deriving (Show, Eq)

data ParensOption = ParensMandatory | ParensOptional
    deriving (Show, Eq)

data FormalsOption = FormalsSimple | FormalsComplex
    deriving (Show, Eq)

instance MonadReader Env RuleParser where
    ask = getRuleEnv
    local f action = do
        env     <- getRuleEnv
        putRuleEnv (f env)
        rv      <- action
        env'    <- getRuleEnv
        putRuleEnv env'
            { envPackage = envPackage env
            , envLexical = envLexical env
            }
        return rv

instance MonadState RuleState RuleParser where
    get = getState
    put = setState

type RuleOperator a = Operator Char RuleState a
type RuleOperatorTable a = OperatorTable Char RuleState a

-----------------------------------------------------------
-- Assoc and OperatorTable
-----------------------------------------------------------
data Assoc                = AssocNone
                          | AssocLeft
                          | AssocRight
                          | AssocList
                          | AssocChain
                          deriving (Show)

data Operator t st a      = Infix { op_infix :: (GenParser t st (a -> a -> a)), op_assoc :: Assoc }
                          | Prefix (GenParser t st (a -> a))
                          | Postfix (GenParser t st (a -> a))
                          | InfixList { op_infixList :: (GenParser t st ([a] -> a)), op_assoc ::  Assoc }
                          | OptionalPrefix (GenParser t st (a -> a))
                          | DependentPostfix (a -> GenParser t st a)
                          | Term (GenParser t st a)

type OperatorTable t st a = [[Operator t st a]]

{-|
Retrieve the 'Pugs.AST.Internals.Env' from the current state of the parser.
-}
enterBracketLevel :: BracketLevel -> RuleParser a -> RuleParser a
enterBracketLevel bracket rule = do
    prev <- gets s_bracketLevel
    modify $ \state -> state{ s_bracketLevel = bracket }
    rv <- rule
    modify $ \state -> state{ s_bracketLevel = prev }
    return rv

{-|
Retrieve the 'Pugs.AST.Internals.Env' from the current state of the parser.
-}
getRuleEnv :: RuleParser Env
getRuleEnv = gets s_env

{-|
Update the 'Pugs.AST.Internals.Env' in the parser's state by applying a transformation function.
-}
modifyRuleEnv :: (Env -> Env) -> RuleParser ()
modifyRuleEnv f = modify $ \state -> state{ s_env = f (s_env state) }

{-|
Update the 's_blockPads' in the parser's state by applying a transformation function.
-}
addBlockPad :: Scope -> Pad -> RuleParser ()
addBlockPad scope pad = do
    -- First we check that our pad does not contain shadows OUTER symbols.
    state <- get
    let dupSyms = padKeys pad `Set.intersection` s_outerVars state
    unless (Set.null dupSyms) $ do
        fail $ "Redeclaration of "
            ++ unwords (map show (Set.elems dupSyms))
            ++ " conflicts with earlier OUTER references in the same scope"
    put state{ s_blockPads = Map.insertWith unionPads scope pad (s_blockPads state) }

popClosureTrait :: RuleParser ()
popClosureTrait = do
    modify $ \state -> state
        { s_closureTraits = case s_closureTraits state of
            []      -> [id]
            [_]     -> [id]
            (_:fs)  -> fs
        }

addClosureTrait :: String -> VCode -> RuleParser ()
addClosureTrait name code = do
    let names = words " ENTER LEAVE KEEP UNDO FIRST NEXT LAST PRE POST CATCH CONTROL "
    when (not $ name `elem` names) $
        fail ("Invalid closure trait: " ++ name) 
    modify $ \state -> state
        { s_closureTraits = case s_closureTraits state of
            []      -> [addTrait]
            (f:fs)  -> ((addTrait . f) : fs)
        }
    where
    trait = code{ subName = cast name }
    addTrait block = case name of 
        "CONTROL"   -> block{ subControlBlocks = trait:subControlBlocks block }
        "CATCH"     -> block{ subCatchBlocks = trait:subCatchBlocks block }
        "KEEP"      -> block
            { subKeepBlocks     = trait:subKeepBlocks block
            , subLeaveBlocks    = trait:subLeaveBlocks block
            }
        "UNDO"      -> block
            { subUndoBlocks     = trait:subUndoBlocks block
            , subLeaveBlocks    = trait:subLeaveBlocks block
            }
        "ENTER"     -> block{ subEnterBlocks = subEnterBlocks block ++ [trait] }
        "LEAVE"     -> block{ subLeaveBlocks = trait:subLeaveBlocks block }
        "NEXT"      -> block{ subNextBlocks = trait:subNextBlocks block }
        "LAST"      -> block{ subLastBlocks = trait:subLastBlocks block }
        "PRE"       -> block{ subPreBlocks = subPreBlocks block ++ [trait] }
        "POST"      -> block{ subPostBlocks = trait:subPostBlocks block }
        "FIRST"     -> block{ subFirstBlocks = subFirstBlocks block ++ [trait] }
        _           -> trace ("Wrong closure trait name: "++name) block
{-|
Update the 's_outerVars' in the parser's state by applying a transformation function.
-}
addOuterVar :: Var -> RuleParser ()
addOuterVar var = modify $ \state ->
    state{ s_outerVars = Set.insert var (s_outerVars state) }

{-|
Replace the 'Pugs.AST.Internals.Env' in the parser's state with a new one.
-}
putRuleEnv :: Env -> RuleParser ()
putRuleEnv = modifyRuleEnv . const

{-|
Clear the parser's cache of dynamically-generated parsers for user-defined
operators.

These will be re-generated by 'Pugs.Parser.parseOpWith' when needed.
-}
clearDynParsers :: RuleParser ()
clearDynParsers = modify $ \state -> state{ s_dynParsers = MkDynParsersEmpty }

parserWarn :: (Typeable a, Show a) => String -> a -> RuleParser ()
parserWarn str val = do
    currPos <- getPosition
    traceM (pretty (VError (VStr $ str ++ showVal) [mkPos currPos currPos]))
    where
    showVal = case show val of
        "()" -> ""
        txt  -> ":\n    " ++ txt


{-|
Create a Pugs 'Pugs.AST.Pos' (for storing in the AST) from two Parsec
@SourcePos@ positions, being the start and end respectively of the current
region.
-}
mkPos :: SourcePos -- ^ Starting position of the region
      -> SourcePos -- ^ Ending position of the region
      -> Pos
mkPos pos1 pos2 = MkPos
    { posName         = sourceName pos1 
    , posBeginLine    = sourceLine pos1
    , posBeginColumn  = sourceColumn pos1
    , posEndLine      = sourceLine pos2
    , posEndColumn    = sourceColumn pos2
    }

{-|
Record the current parser position, invoke the given subrule, then record the
parser's new position and encapsulate the subrule's result in a
'Pugs.AST.Internals.Pos' indicating the source region matched by the rule.

Also applies 'unwrap' to the result of the given parser.
-}
expRule :: RuleParser Exp -- ^ Sub-rule to invoke
        -> RuleParser Exp
expRule rule = do
    pos1 <- getPosition
    exp  <- rule
    pos2 <- getPosition
    return $ Ann (Pos (mkPos pos1 pos2)) (unwrap exp)


{-|
Modify the input stream by inserting a single 'Char' as the next thing to parse.
-}
insertIntoPosition :: Char -> RuleParser ()
insertIntoPosition ch = do
    currPos <- getPosition
    input <- getInput 
    setInput (ch:input)
    setPosition (setSourceColumn currPos (sourceColumn currPos - 1))
