{-| 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
  { ParanthesesCount -> Integer
pcActual :: Integer
  , ParanthesesCount -> Bool
pcHasReached0 :: Bool }
  deriving (Int -> ParanthesesCount -> ShowS
[ParanthesesCount] -> ShowS
ParanthesesCount -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParanthesesCount] -> ShowS
$cshowList :: [ParanthesesCount] -> ShowS
show :: ParanthesesCount -> String
$cshow :: ParanthesesCount -> String
showsPrec :: Int -> ParanthesesCount -> ShowS
$cshowsPrec :: Int -> ParanthesesCount -> ShowS
Show, ParanthesesCount -> ParanthesesCount -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParanthesesCount -> ParanthesesCount -> Bool
$c/= :: ParanthesesCount -> ParanthesesCount -> Bool
== :: ParanthesesCount -> ParanthesesCount -> Bool
$c== :: ParanthesesCount -> ParanthesesCount -> Bool
Eq)

data Context =
    ConStart
  | ConData
  | ConImplicit
  | ConNamelist
  | ConCommon
  deriving (Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show, Context -> Context -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq)

data ParseState a = ParseState
  { forall a. ParseState a -> a
psAlexInput :: a
  , forall a. ParseState a -> ParanthesesCount
psParanthesesCount :: ParanthesesCount
  , forall a. ParseState a -> FortranVersion
psVersion :: FortranVersion  -- To differentiate lexing behaviour
  , forall a. ParseState a -> String
psFilename :: String -- To save correct source location in AST
  , forall a. ParseState a -> [Context]
psContext :: [ Context ]
  }
  deriving (Int -> ParseState a -> ShowS
forall a. Show a => Int -> ParseState a -> ShowS
forall a. Show a => [ParseState a] -> ShowS
forall a. Show a => ParseState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseState a] -> ShowS
$cshowList :: forall a. Show a => [ParseState a] -> ShowS
show :: ParseState a -> String
$cshow :: forall a. Show a => ParseState a -> String
showsPrec :: Int -> ParseState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseState a -> ShowS
Show)

data ParseError a b = ParseError
  { forall {k} (a :: k) b. ParseError a b -> Position
errPos        :: Position
  , forall {k} (a :: k) b. ParseError a b -> Maybe b
errLastToken  :: Maybe b
  , forall {k} (a :: k) b. ParseError a b -> String
errFilename   :: String
  , forall {k} (a :: k) b. ParseError a b -> String
errMsg        :: String }

instance Show b => Show (ParseError a b) where
  show :: ParseError a b -> String
show ParseError a b
err = forall a. Show a => a -> String
show (forall {k} (a :: k) b. ParseError a b -> Position
errPos ParseError a b
err) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall {k} (a :: k) b. ParseError a b -> String
errMsg ParseError a b
err forall a. [a] -> [a] -> [a]
++ String
lastTokenMsg
    where lastTokenMsg :: String
lastTokenMsg = forall a. Show a => Maybe a -> String
tokenMsg (forall {k} (a :: k) b. ParseError a b -> Maybe b
errLastToken ParseError a b
err)

tokenMsg :: Show a => Maybe a -> String
tokenMsg :: forall a. Show a => Maybe a -> String
tokenMsg (Just a
a) = String
"Last parsed token: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
"."
tokenMsg Maybe a
Nothing = String
"No token had been lexed."

data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)
    deriving stock (forall a b. a -> ParseResult b c b -> ParseResult b c a
forall a b. (a -> b) -> ParseResult b c a -> ParseResult b c b
forall b c a b. a -> ParseResult b c b -> ParseResult b c a
forall b c a b. (a -> b) -> ParseResult b c a -> ParseResult b c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParseResult b c b -> ParseResult b c a
$c<$ :: forall b c a b. a -> ParseResult b c b -> ParseResult b c a
fmap :: forall a b. (a -> b) -> ParseResult b c a -> ParseResult b c b
$cfmap :: forall b c a b. (a -> b) -> ParseResult b c a -> ParseResult b c b
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 { forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse :: ParseState b -> ParseResult b c a }

instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where
  return :: forall a. a -> Parse b c a
return a
a = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> forall b c a. a -> ParseState b -> ParseResult b c a
ParseOk a
a ParseState b
s

  (Parse ParseState b -> ParseResult b c a
m) >>= :: forall a b. Parse b c a -> (a -> Parse b c b) -> Parse b c b
>>= a -> Parse b c b
f = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
s ->
    case ParseState b -> ParseResult b c a
m ParseState b
s of
      ParseOk a
a ParseState b
s' -> forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse (a -> Parse b c b
f a
a) ParseState b
s'
      ParseFailed ParseError b c
e -> forall b c a. ParseError b c -> ParseResult b c a
ParseFailed ParseError b c
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 :: forall a. String -> Parse b c a
fail String
msg = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> forall b c a. ParseError b c -> ParseResult b c a
ParseFailed ParseError
    { errPos :: Position
errPos        = (forall a. Loc a => a -> Position
getPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParseState a -> a
psAlexInput) ParseState b
s
    , errLastToken :: Maybe c
errLastToken  = (forall a b. (LastToken a b, Show b) => a -> Maybe b
getLastToken forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParseState a -> a
psAlexInput) ParseState b
s
    , errFilename :: String
errFilename   = forall a. ParseState a -> String
psFilename ParseState b
s
    , errMsg :: String
errMsg        = String
msg }

instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where
  fmap :: forall a b. (a -> b) -> Parse b c a -> Parse b c b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where
  pure :: forall a. a -> Parse b c a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. Parse b c (a -> b) -> Parse b c a -> Parse b c b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where
  get :: Parse b c (ParseState b)
get = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> forall b c a. a -> ParseState b -> ParseResult b c a
ParseOk ParseState b
s ParseState b
s
  put :: ParseState b -> Parse b c ()
put ParseState b
s = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
_ -> forall b c a. a -> ParseState b -> ParseResult b c a
ParseOk () ParseState b
s

instance (Loc b, LastToken b c, Show c) => MonadError (ParseError b c) (Parse b c) where
  throwError :: forall a. ParseError b c -> Parse b c a
throwError ParseError b c
e = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
_ -> forall b c a. ParseError b c -> ParseResult b c a
ParseFailed ParseError b c
e

  (Parse ParseState b -> ParseResult b c a
m) catchError :: forall a.
Parse b c a -> (ParseError b c -> Parse b c a) -> Parse b c a
`catchError` ParseError b c -> Parse b c a
f = forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse forall a b. (a -> b) -> a -> b
$ \ParseState b
s ->
    case ParseState b -> ParseResult b c a
m ParseState b
s of
      ParseFailed ParseError b c
e -> forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse (ParseError b c -> Parse b c a
f ParseError b c
e) ParseState b
s
      ParseResult b c a
m' -> ParseResult b c a
m'


runParse
    :: (Loc b, LastToken b c, Show c)
    => Parse b c a -> ParseState b -> ParseResult b c a
runParse :: forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> ParseResult b c a
runParse = forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse

runParseUnsafe
    :: (Loc b, LastToken b c, Show c)
    => Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe :: forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe Parse b c a
lexer ParseState b
initState =
  case forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse Parse b c a
lexer ParseState b
initState of
    ParseOk a
a ParseState b
s -> (a
a, ParseState b
s)
    ParseFailed ParseError b c
e -> forall a. String -> a
throwIOError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ParseError b c
e

throwIOError :: String -> a
throwIOError :: forall a. String -> a
throwIOError String
s = forall a e. Exception e => e -> a
throw
  IOError { ioe_handle :: Maybe Handle
ioe_handle      = forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
UserError
          , ioe_location :: String
ioe_location    = String
"fortran-src"
          , ioe_description :: String
ioe_description = String
s
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing }

evalParse
    :: (Loc b, LastToken b c, Show c)
    => Parse b c a -> ParseState b -> a
evalParse :: forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> a
evalParse Parse b c a
m ParseState b
s = forall a b. (a, b) -> a
fst (forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe Parse b c a
m ParseState b
s)

execParse
    :: (Loc b, LastToken b c, Show c)
    => Parse b c a -> ParseState b -> ParseState b
execParse :: forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> ParseState b
execParse Parse b c a
m ParseState b
s = forall a b. (a, b) -> b
snd (forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe Parse b c a
m ParseState b
s)

-------------------------------------------------------------------------------
-- Parser helper functions
-------------------------------------------------------------------------------

getVersion :: (Loc a, LastToken a b, Show b) => Parse a b FortranVersion
getVersion :: forall a b.
(Loc a, LastToken a b, Show b) =>
Parse a b FortranVersion
getVersion = do
  ParseState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ParseState a -> FortranVersion
psVersion ParseState a
s)

putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b ()
putAlex :: forall a b. (Loc a, LastToken a b, Show b) => a -> Parse a b ()
putAlex a
ai = do
  ParseState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState a
s { psAlexInput :: a
psAlexInput = a
ai })

getAlex :: (Loc a, LastToken a b, Show b) => Parse a b a
getAlex :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b a
getAlex = do
  ParseState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ParseState a -> a
psAlexInput ParseState a
s)

topContext :: (Loc a, LastToken a b, Show b) => Parse a b Context
topContext :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b Context
topContext = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParseState a -> [Context]
psContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get

popContext :: (Loc a, LastToken a b, Show b) => Parse a b ()
popContext :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b ()
popContext = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ParseState a
ps -> ParseState a
ps { psContext :: [Context]
psContext = forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. ParseState a -> [Context]
psContext ParseState a
ps }

pushContext :: (Loc a, LastToken a b, Show b) => Context -> Parse a b ()
pushContext :: forall a b.
(Loc a, LastToken a b, Show b) =>
Context -> Parse a b ()
pushContext Context
context = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ParseState a
ps -> ParseState a
ps { psContext :: [Context]
psContext = Context
context forall a. a -> [a] -> [a]
: forall a. ParseState a -> [Context]
psContext ParseState a
ps }

getPosition :: (Loc a, LastToken a b, Show b) => Parse a b Position
getPosition :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b Position
getPosition = do
  ParseState a
parseState <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Loc a => a -> Position
getPos forall a b. (a -> b) -> a -> b
$ forall a. ParseState a -> a
psAlexInput ParseState a
parseState

getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan
getSrcSpan :: forall a b.
(Loc a, LastToken a b, Show b) =>
Position -> Parse a b SrcSpan
getSrcSpan Position
loc1 = do
  Position
loc2 <- forall a b. (Loc a, LastToken a b, Show b) => Parse a b Position
getPosition
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Position -> Position -> SrcSpan
SrcSpan Position
loc1 Position
loc2

getParanthesesCount :: (Loc a, LastToken a b, Show b) => Parse a b ParanthesesCount
getParanthesesCount :: forall a b.
(Loc a, LastToken a b, Show b) =>
Parse a b ParanthesesCount
getParanthesesCount = forall a. ParseState a -> ParanthesesCount
psParanthesesCount forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get

resetPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
resetPar :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b ()
resetPar = do
  ParseState a
ps <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ParseState a
ps { psParanthesesCount :: ParanthesesCount
psParanthesesCount = Integer -> Bool -> ParanthesesCount
ParanthesesCount Integer
0 Bool
False }

incPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
incPar :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b ()
incPar = do
  ParseState a
ps <- forall s (m :: * -> *). MonadState s m => m s
get
  let pc :: ParanthesesCount
pc = forall a. ParseState a -> ParanthesesCount
psParanthesesCount ParseState a
ps
  let count :: Integer
count = ParanthesesCount -> Integer
pcActual ParanthesesCount
pc
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ParseState a
ps { psParanthesesCount :: ParanthesesCount
psParanthesesCount = ParanthesesCount
pc { pcActual :: Integer
pcActual = Integer
count forall a. Num a => a -> a -> a
+ Integer
1 } }

decPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
decPar :: forall a b. (Loc a, LastToken a b, Show b) => Parse a b ()
decPar = do
  ParseState a
ps <- forall s (m :: * -> *). MonadState s m => m s
get
  let pc :: ParanthesesCount
pc = forall a. ParseState a -> ParanthesesCount
psParanthesesCount ParseState a
ps
  let newCount :: Integer
newCount = ParanthesesCount -> Integer
pcActual ParanthesesCount
pc forall a. Num a => a -> a -> a
- Integer
1
  let reached0 :: Bool
reached0 = ParanthesesCount -> Bool
pcHasReached0 ParanthesesCount
pc Bool -> Bool -> Bool
|| Integer
newCount forall a. Eq a => a -> a -> Bool
== Integer
0
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ParseState a
ps { psParanthesesCount :: ParanthesesCount
psParanthesesCount = Integer -> Bool -> ParanthesesCount
ParanthesesCount Integer
newCount Bool
reached0 }