content: {-| Parser/lexer monad, plus common functionality and definitions. -}
  
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE CPP #-}
  
  module Language.Fortran.Parser.Monad where
  
  #if !MIN_VERSION_base(4,13,0)
  -- Control.Monad.Fail import is redundant since GHC 8.8.1
  import qualified Control.Monad.Fail as Fail
  import Control.Monad.Fail (MonadFail)
  #endif
  
  import Language.Fortran.Version
  import Language.Fortran.Util.Position
  
  import Control.Exception
  import GHC.IO.Exception ( IOException(..), IOErrorType(..) )
  import Control.Monad.State hiding (state)
  import Control.Monad.Except
  import Data.Typeable
  
  -------------------------------------------------------------------------------
  -- Helper datatype definitions
  -------------------------------------------------------------------------------
  
  data ParanthesesCount = ParanthesesCount
    { pcActual :: Integer
    , pcHasReached0 :: Bool }
    deriving (Show, Eq)
  
  data Context =
      ConStart
    | ConData
    | ConImplicit
    | ConNamelist
    | ConCommon
    deriving (Show, Eq)
  
  data ParseState a = ParseState
    { psAlexInput :: a
    , psParanthesesCount :: ParanthesesCount
    , psVersion :: FortranVersion  -- To differentiate lexing behaviour
    , psFilename :: String -- To save correct source location in AST
    , psContext :: [ Context ]
    }
    deriving (Show)
  
  data ParseError a b = ParseError
    { errPos        :: Position
    , errLastToken  :: Maybe b
    , errFilename   :: String
    , errMsg        :: String }
  
  instance Show b => Show (ParseError a b) where
    show err = show (errPos err) ++ ": " ++ errMsg err ++ lastTokenMsg
      where lastTokenMsg = tokenMsg (errLastToken err)
  
  tokenMsg :: Show a => Maybe a -> String
  tokenMsg (Just a) = "Last parsed token: " ++ show a ++ "."
  tokenMsg Nothing = "No token had been lexed."
  
  data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)
      deriving stock (Functor)
  
  instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b)
  
  class LastToken a b | a -> b where
    getLastToken :: (Show b) => a -> Maybe b
  
  class Tok a where
    eofToken :: a -> Bool
  
  -------------------------------------------------------------------------------
  -- Parser Monad definition
  -------------------------------------------------------------------------------
  
  newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a }
  
  instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where
    fmap f (Parse p) = Parse $ \s -> case p s of
      ParseOk a s' -> ParseOk (f a) s'
      ParseFailed e -> ParseFailed e
  
  instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where
    pure a = Parse $ \s -> ParseOk a s
    (Parse pl) <*> (Parse pr) = Parse $ \s ->
      case pl s of
        ParseFailed e -> ParseFailed e
        ParseOk ab s' ->
          case pr s' of
            ParseFailed e -> ParseFailed e
            ParseOk a s'' -> ParseOk (ab a) s''
  
  instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where
    (Parse m) >>= f = Parse $ \s ->
      case m s of
        ParseOk a s' -> unParse (f a) s'
        ParseFailed e -> ParseFailed e
  
  #if !MIN_VERSION_base(4,13,0)
    -- Monad(fail) was removed in GHC 8.8.1
    fail = Fail.fail
  #endif
  
  instance (Loc b, LastToken b c, Show c) => MonadFail (Parse b c) where
    fail msg = Parse $ \s -> ParseFailed ParseError
      { errPos        = (getPos . psAlexInput) s
      , errLastToken  = (getLastToken . psAlexInput) s
      , errFilename   = psFilename s
      , errMsg        = msg }
  
  instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where
    get = Parse $ \s -> ParseOk s s
    put s = Parse $ \_ -> ParseOk () s
  
  instance (Loc b, LastToken b c, Show c) => MonadError (ParseError b c) (Parse b c) where
    throwError e = Parse $ \_ -> ParseFailed e
  
    (Parse m) `catchError` f = Parse $ \s ->
      case m s of
        ParseFailed e -> unParse (f e) s
        m' -> m'
  
  
  runParse
      :: (Loc b, LastToken b c, Show c)
      => Parse b c a -> ParseState b -> ParseResult b c a
  runParse = unParse
  
  runParseUnsafe
      :: (Loc b, LastToken b c, Show c)
      => Parse b c a -> ParseState b -> (a, ParseState b)
  runParseUnsafe lexer initState =
    case unParse lexer initState of
      ParseOk a s -> (a, s)
      ParseFailed e -> throwIOError $ show e
  
  throwIOError :: String -> a
  throwIOError s = throw
    IOError { ioe_handle      = Nothing
            , ioe_type        = UserError
            , ioe_location    = "fortran-src"
            , ioe_description = s
            , ioe_errno       = Nothing
            , ioe_filename    = Nothing }
  
  evalParse
      :: (Loc b, LastToken b c, Show c)
      => Parse b c a -> ParseState b -> a
  evalParse m s = fst (runParseUnsafe m s)
  
  execParse
      :: (Loc b, LastToken b c, Show c)
      => Parse b c a -> ParseState b -> ParseState b
  execParse m s = snd (runParseUnsafe m s)
  
  -------------------------------------------------------------------------------
  -- Parser helper functions
  -------------------------------------------------------------------------------
  
  getVersion :: (Loc a, LastToken a b, Show b) => Parse a b FortranVersion
  getVersion = do
    s <- get
    return (psVersion s)
  
  putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b ()
  putAlex ai = do
    s <- get
    put (s { psAlexInput = ai })
  
  getAlex :: (Loc a, LastToken a b, Show b) => Parse a b a
  getAlex = do
    s <- get
    return (psAlexInput s)
  
  topContext :: (Loc a, LastToken a b, Show b) => Parse a b Context
  topContext = head . psContext <$> get
  
  popContext :: (Loc a, LastToken a b, Show b) => Parse a b ()
  popContext = modify $ \ps -> ps { psContext = tail $ psContext ps }
  
  pushContext :: (Loc a, LastToken a b, Show b) => Context -> Parse a b ()
  pushContext context = modify $ \ps -> ps { psContext = context : psContext ps }
  
  getPosition :: (Loc a, LastToken a b, Show b) => Parse a b Position
  getPosition = do
    parseState <- get
    return $ getPos $ psAlexInput parseState
  
  getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan
  getSrcSpan loc1 = do
    loc2 <- getPosition
    return $ SrcSpan loc1 loc2
  
  getParanthesesCount :: (Loc a, LastToken a b, Show b) => Parse a b ParanthesesCount
  getParanthesesCount = psParanthesesCount <$> get
  
  resetPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
  resetPar = do
    ps <- get
    put $ ps { psParanthesesCount = ParanthesesCount 0 False }
  
  incPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
  incPar = do
    ps <- get
    let pc = psParanthesesCount ps
    let count = pcActual pc
    put $ ps { psParanthesesCount = pc { pcActual = count + 1 } }
  
  decPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
  decPar = do
    ps <- get
    let pc = psParanthesesCount ps
    let newCount = pcActual pc - 1
    let reached0 = pcHasReached0 pc || newCount == 0
    put $ ps { psParanthesesCount = ParanthesesCount newCount reached0 }
  