{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE CPP #-}

module Language.Fortran.ParserMonad
  ( module Language.Fortran.ParserMonad
  , module Language.Fortran.Version -- TODO: temporary plug to avoid API change
  ) 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 GHC.IO.Exception
import Control.Exception

import Control.Monad.State hiding (state)
import Control.Monad.Except

import Data.Typeable
import Language.Fortran.Util.Position

-------------------------------------------------------------------------------
-- Helper datatype definitions
-------------------------------------------------------------------------------

data ParanthesesCount = ParanthesesCount
  { ParanthesesCount -> Integer
pcActual :: Integer
  , ParanthesesCount -> Bool
pcHasReached0 :: Bool }
  deriving (Int -> ParanthesesCount -> ShowS
[ParanthesesCount] -> ShowS
ParanthesesCount -> String
(Int -> ParanthesesCount -> ShowS)
-> (ParanthesesCount -> String)
-> ([ParanthesesCount] -> ShowS)
-> Show ParanthesesCount
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
(ParanthesesCount -> ParanthesesCount -> Bool)
-> (ParanthesesCount -> ParanthesesCount -> Bool)
-> Eq ParanthesesCount
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
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
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
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
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
  { ParseState a -> a
psAlexInput :: a
  , ParseState a -> ParanthesesCount
psParanthesesCount :: ParanthesesCount
  , ParseState a -> FortranVersion
psVersion :: FortranVersion  -- To differentiate lexing behaviour
  , ParseState a -> String
psFilename :: String -- To save correct source location in AST
  , ParseState a -> [Context]
psContext :: [ Context ]
  }
  deriving (Int -> ParseState a -> ShowS
[ParseState a] -> ShowS
ParseState a -> String
(Int -> ParseState a -> ShowS)
-> (ParseState a -> String)
-> ([ParseState a] -> ShowS)
-> Show (ParseState a)
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
  { ParseError a b -> Position
errPos        :: Position
  , ParseError a b -> Maybe b
errLastToken  :: Maybe b
  , ParseError a b -> String
errFilename   :: String
  , ParseError a b -> String
errMsg        :: String }


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

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

instance Functor (ParseResult b c) where
    fmap :: (a -> b) -> ParseResult b c a -> ParseResult b c b
fmap a -> b
f (ParseOk a
a ParseState b
s) = b -> ParseState b -> ParseResult b c b
forall b c a. a -> ParseState b -> ParseResult b c a
ParseOk (a -> b
f a
a) ParseState b
s
    fmap a -> b
_ (ParseFailed ParseError b c
err) = ParseError b c -> ParseResult b c b
forall b c a. ParseError b c -> ParseResult b c a
ParseFailed ParseError b c
err

instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b)

data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)

-- Provides a way to aggregate errors that come
-- from parses with different token types
data ParseErrorSimple = ParseErrorSimple
  { ParseErrorSimple -> Position
errorPos      :: Position
  , ParseErrorSimple -> String
errorFilename :: String
  , ParseErrorSimple -> String
errorMsg      :: String }

fromParseResultUnsafe :: (Show c) => ParseResult b c a -> a
fromParseResultUnsafe :: ParseResult b c a -> a
fromParseResultUnsafe (ParseOk a
a ParseState b
_) = a
a
fromParseResultUnsafe (ParseFailed ParseError b c
err) = String -> a
forall a. String -> a
throwIOerror (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ParseError b c -> String
forall a. Show a => a -> String
show ParseError b c
err

fromRight :: Show a => Either a b -> b
fromRight :: Either a b -> b
fromRight (Left a
x)  = String -> b
forall a. String -> a
throwIOerror (String -> b) -> (a -> String) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
x
fromRight (Right b
x) = b
x

fromParseResult :: (Show c) => ParseResult b c a -> Either ParseErrorSimple a
fromParseResult :: ParseResult b c a -> Either ParseErrorSimple a
fromParseResult (ParseOk a
a ParseState b
_)     = a -> Either ParseErrorSimple a
forall a b. b -> Either a b
Right a
a
fromParseResult (ParseFailed ParseError b c
err) =
    ParseErrorSimple -> Either ParseErrorSimple a
forall a b. a -> Either a b
Left ParseErrorSimple :: Position -> String -> String -> ParseErrorSimple
ParseErrorSimple
      { errorPos :: Position
errorPos = ParseError b c -> Position
forall a b. ParseError a b -> Position
errPos ParseError b c
err
      , errorFilename :: String
errorFilename = ParseError b c -> String
forall a b. ParseError a b -> String
errFilename ParseError b c
err
      , errorMsg :: String
errorMsg = ParseError b c -> String
forall a b. ParseError a b -> String
errMsg ParseError b c
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe c -> String
forall a. Show a => Maybe a -> String
tokenMsg (ParseError b c -> Maybe c
forall a b. ParseError a b -> Maybe b
errLastToken ParseError b c
err)  }

instance Show ParseErrorSimple where
  show :: ParseErrorSimple -> String
show ParseErrorSimple
err = ParseErrorSimple -> String
errorFilename ParseErrorSimple
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (ParseErrorSimple -> Position
errorPos ParseErrorSimple
err) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseErrorSimple -> String
errorMsg ParseErrorSimple
err

class LastToken a b | a -> b where
  getLastToken :: (Show b) => a -> Maybe b

-------------------------------------------------------------------------------
-- Parser Monad definition
-------------------------------------------------------------------------------

newtype Parse b c a = Parse { 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 :: a -> Parse b c a
return a
a = (ParseState b -> ParseResult b c a) -> Parse b c a
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c a) -> Parse b c a)
-> (ParseState b -> ParseResult b c a) -> Parse b c a
forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> a -> ParseState b -> ParseResult b c a
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) >>= :: Parse b c a -> (a -> Parse b c b) -> Parse b c b
>>= a -> Parse b c b
f = (ParseState b -> ParseResult b c b) -> Parse b c b
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c b) -> Parse b c b)
-> (ParseState b -> ParseResult b c b) -> Parse b c b
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' -> Parse b c b -> ParseState b -> ParseResult b c b
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 -> ParseError b c -> ParseResult b c b
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 :: String -> Parse b c a
fail String
msg = (ParseState b -> ParseResult b c a) -> Parse b c a
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c a) -> Parse b c a)
-> (ParseState b -> ParseResult b c a) -> Parse b c a
forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> ParseError b c -> ParseResult b c a
forall b c a. ParseError b c -> ParseResult b c a
ParseFailed ParseError :: forall a b.
Position -> Maybe b -> String -> String -> ParseError a b
ParseError
    { errPos :: Position
errPos        = (b -> Position
forall a. Loc a => a -> Position
getPos (b -> Position) -> (ParseState b -> b) -> ParseState b -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState b -> b
forall a. ParseState a -> a
psAlexInput) ParseState b
s
    , errLastToken :: Maybe c
errLastToken  = (b -> Maybe c
forall a b. (LastToken a b, Show b) => a -> Maybe b
getLastToken (b -> Maybe c) -> (ParseState b -> b) -> ParseState b -> Maybe c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState b -> b
forall a. ParseState a -> a
psAlexInput) ParseState b
s
    , errFilename :: String
errFilename   = ParseState b -> String
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 :: (a -> b) -> Parse b c a -> Parse b c b
fmap = (a -> b) -> Parse b c a -> Parse b c b
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 :: a -> Parse b c a
pure  = a -> Parse b c a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: Parse b c (a -> b) -> Parse b c a -> Parse b c 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 = (ParseState b -> ParseResult b c (ParseState b))
-> Parse b c (ParseState b)
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c (ParseState b))
 -> Parse b c (ParseState b))
-> (ParseState b -> ParseResult b c (ParseState b))
-> Parse b c (ParseState b)
forall a b. (a -> b) -> a -> b
$ \ParseState b
s -> ParseState b -> ParseState b -> ParseResult b c (ParseState b)
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 = (ParseState b -> ParseResult b c ()) -> Parse b c ()
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c ()) -> Parse b c ())
-> (ParseState b -> ParseResult b c ()) -> Parse b c ()
forall a b. (a -> b) -> a -> b
$ \ParseState b
_ -> () -> ParseState b -> ParseResult b c ()
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 :: ParseError b c -> Parse b c a
throwError ParseError b c
e = (ParseState b -> ParseResult b c a) -> Parse b c a
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c a) -> Parse b c a)
-> (ParseState b -> ParseResult b c a) -> Parse b c a
forall a b. (a -> b) -> a -> b
$ \ParseState b
_ -> ParseError b c -> ParseResult b c a
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 :: Parse b c a -> (ParseError b c -> Parse b c a) -> Parse b c a
`catchError` ParseError b c -> Parse b c a
f = (ParseState b -> ParseResult b c a) -> Parse b c a
forall b c a. (ParseState b -> ParseResult b c a) -> Parse b c a
Parse ((ParseState b -> ParseResult b c a) -> Parse b c a)
-> (ParseState b -> ParseResult b c a) -> Parse b c a
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 -> Parse b c a -> ParseState b -> ParseResult b c a
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'

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

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

putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b ()
putAlex :: a -> Parse a b ()
putAlex a
ai = do
  ParseState a
s <- Parse a b (ParseState a)
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState a -> Parse a b ()
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 :: Parse a b a
getAlex = do
  ParseState a
s <- Parse a b (ParseState a)
forall s (m :: * -> *). MonadState s m => m s
get
  a -> Parse a b a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseState a -> a
forall a. ParseState a -> a
psAlexInput ParseState a
s)

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

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

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

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

getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan
getSrcSpan :: Position -> Parse a b SrcSpan
getSrcSpan Position
loc1 = do
  Position
loc2 <- Parse a b Position
forall a b. (Loc a, LastToken a b, Show b) => Parse a b Position
getPosition
  SrcSpan -> Parse a b SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Parse a b SrcSpan) -> SrcSpan -> Parse a b SrcSpan
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 :: Parse a b ParanthesesCount
getParanthesesCount = ParseState a -> ParanthesesCount
forall a. ParseState a -> ParanthesesCount
psParanthesesCount (ParseState a -> ParanthesesCount)
-> Parse a b (ParseState a) -> Parse a b ParanthesesCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse a b (ParseState a)
forall s (m :: * -> *). MonadState s m => m s
get

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

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

-------------------------------------------------------------------------------
-- Generic token collection and functions
-------------------------------------------------------------------------------

throwIOerror :: String -> a
throwIOerror :: String -> a
throwIOerror String
s = IOException -> a
forall a e. Exception e => e -> a
throw
  IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError { ioe_handle :: Maybe Handle
ioe_handle      = Maybe 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       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing }

runParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> ParseResult b c a
runParse :: Parse b c a -> ParseState b -> ParseResult b c a
runParse = Parse b c a -> ParseState b -> ParseResult b c a
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 :: Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe Parse b c a
lexer ParseState b
initState =
  case Parse b c a -> ParseState b -> ParseResult b c a
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 -> String -> (a, ParseState b)
forall a. String -> a
throwIOerror (String -> (a, ParseState b)) -> String -> (a, ParseState b)
forall a b. (a -> b) -> a -> b
$ ParseError b c -> String
forall a. Show a => a -> String
show ParseError b c
e

evalParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> a
evalParse :: Parse b c a -> ParseState b -> a
evalParse Parse b c a
m ParseState b
s = (a, ParseState b) -> a
forall a b. (a, b) -> a
fst (Parse b c a -> ParseState b -> (a, ParseState b)
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 :: Parse b c a -> ParseState b -> ParseState b
execParse Parse b c a
m ParseState b
s = (a, ParseState b) -> ParseState b
forall a b. (a, b) -> b
snd (Parse b c a -> ParseState b -> (a, ParseState b)
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)

class Tok a where
  eofToken :: a -> Bool

collectTokens :: forall a b . (Loc b, Tok a, LastToken b a, Show a) => Parse b a a -> ParseState b -> [a]
collectTokens :: Parse b a a -> ParseState b -> [a]
collectTokens Parse b a a
lexer ParseState b
initState =
    Parse b a [a] -> ParseState b -> [a]
forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> a
evalParse ((Loc b, Tok a, LastToken b a, Show a) =>
ParseState b -> Parse b a [a]
ParseState b -> Parse b a [a]
_collectTokens ParseState b
initState) ParseState b
forall a. HasCallStack => a
undefined
  where
    _collectTokens :: (Loc b, Tok a, LastToken b a, Show a) => ParseState b -> Parse b a [a]
    _collectTokens :: ParseState b -> Parse b a [a]
_collectTokens ParseState b
state = do
      let (a
_token, ParseState b
_state) = Parse b a a -> ParseState b -> (a, ParseState b)
forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> (a, ParseState b)
runParseUnsafe Parse b a a
lexer ParseState b
state
      if a -> Bool
forall a. Tok a => a -> Bool
eofToken a
_token
      then [a] -> Parse b a [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
_token]
      else do
        [a]
_tokens <- (Loc b, Tok a, LastToken b a, Show a) =>
ParseState b -> Parse b a [a]
ParseState b -> Parse b a [a]
_collectTokens ParseState b
_state
        [a] -> Parse b a [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Parse b a [a]) -> [a] -> Parse b a [a]
forall a b. (a -> b) -> a -> b
$ a
_tokena -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
_tokens

collectTokensSafe :: forall a b . (Loc b, Tok a, LastToken b a, Show a) => Parse b a a -> ParseState b -> Maybe [a]
collectTokensSafe :: Parse b a a -> ParseState b -> Maybe [a]
collectTokensSafe Parse b a a
lexer ParseState b
initState =
    Parse b a (Maybe [a]) -> ParseState b -> Maybe [a]
forall b c a.
(Loc b, LastToken b c, Show c) =>
Parse b c a -> ParseState b -> a
evalParse ((Loc b, Tok a, LastToken b a, Show a) =>
ParseState b -> Parse b a (Maybe [a])
ParseState b -> Parse b a (Maybe [a])
_collectTokens ParseState b
initState) ParseState b
forall a. HasCallStack => a
undefined
  where
    _collectTokens :: (Loc b, Tok a, LastToken b a, Show a) => ParseState b -> Parse b a (Maybe [a])
    _collectTokens :: ParseState b -> Parse b a (Maybe [a])
_collectTokens ParseState b
state =
      case Parse b a a -> ParseState b -> ParseResult b a a
forall b c a. Parse b c a -> ParseState b -> ParseResult b c a
unParse Parse b a a
lexer ParseState b
state of
        ParseOk a
_token ParseState b
_state ->
          if a -> Bool
forall a. Tok a => a -> Bool
eofToken a
_token
          then Maybe [a] -> Parse b a (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [a] -> Parse b a (Maybe [a]))
-> Maybe [a] -> Parse b a (Maybe [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
_token]
          else do
            Maybe [a]
_mTokens <- (Loc b, Tok a, LastToken b a, Show a) =>
ParseState b -> Parse b a (Maybe [a])
ParseState b -> Parse b a (Maybe [a])
_collectTokens ParseState b
_state
            case Maybe [a]
_mTokens of
              Just [a]
_tokens -> Maybe [a] -> Parse b a (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [a] -> Parse b a (Maybe [a]))
-> Maybe [a] -> Parse b a (Maybe [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ a
_tokena -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
_tokens
              Maybe [a]
_ -> Maybe [a] -> Parse b a (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing
        ParseResult b a a
_ -> Maybe [a] -> Parse b a (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing