uhc-light-1.1.9.1: src/UHC/Light/Compiler/Base/ParseUtils.hs

module UHC.Light.Compiler.Base.ParseUtils
( P
, parseString
, EHParseOpts (..), defaultEHParseOpts
, EHPrs, EHPrsAna, EHPrsOff
, EHParser
, parseWithFPath )
where
import UHC.Light.Compiler.Base.Common
import UU.Parsing
import UU.Parsing.Offside
import UHC.Util.ParseUtils
import UHC.Util.ScanUtils
import UHC.Light.Compiler.Scanner.Common
import UHC.Light.Compiler.Base.HsName
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Data.Version
import Data.List
import Control.Monad
import Control.Monad.IO.Class
import System.IO
import UHC.Util.Pretty
import UHC.Util.FPath
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.Error.Pretty

{-# LINE 40 "src/ehc/Base/ParseUtils.chs" #-}
type P p = PlainParser Token p

{-# LINE 48 "src/ehc/Base/ParseUtils.chs" #-}
parseString :: ScanOpts -> P res -> String -> Maybe res
parseString scanOpts p s
  = if null errs then Just res else Nothing
  where tokens     = scan scanOpts (initPos s) s
        (res,errs) = parseToResMsgs p tokens

{-# LINE 60 "src/ehc/Base/ParseUtils.chs" #-}
-- | Options to influence parsing
data EHParseOpts
  = EHParseOpts
      { ehpoptsLitMode			:: Bool			-- ^ literal mode?
      , ehpoptsOkToStopAtErr	:: Bool			-- ^ stop prematurely when parse error occurs and be ok with the result parsed until then?
      , ehpoptsForImport		:: Bool			-- ^ for import only?
      }
    deriving (Show)

defaultEHParseOpts :: EHParseOpts
defaultEHParseOpts
  = EHParseOpts
      { ehpoptsLitMode			= False
      , ehpoptsOkToStopAtErr	= False
      , ehpoptsForImport		= False
      }

{-# LINE 83 "src/ehc/Base/ParseUtils.chs" #-}
type EHPrs prs inp sym pos a = prs inp Pair sym pos a
type EHPrsAna a = EHPrs AnaParser [Token] Token (Maybe Token) a
type EHPrsOff a = EHPrs OffsideParser [Token] Token (Maybe Token) a

{-# LINE 89 "src/ehc/Base/ParseUtils.chs" #-}
class ( Eq symmsg, Show symmsg, Show pos, Position pos, PP (Message symmsg pos)
      -- , IsParser (prs inp Pair sym pos) sym
      -- , InputState inp sym pos
      -- , IsParser prs sym
      )
      => EHParser prs inp sym symmsg pos | prs -> inp sym symmsg pos where
  -- | Scan & parse using a parser coupled with a scanner
  ehScanParseToResMsgs :: ScanOpts -> EHParseOpts -> EHPrs prs inp sym pos a -> FilePath -> Handle -> IO (a,[Message symmsg pos])
  -- ehScanParseToResMsgs :: ScanOpts -> EHParseOpts -> prs a -> FilePath -> Handle -> IO (a,[Message symmsg pos])

-- instance (Show sym, Eq sym, Show pos, Position pos, Symbol sym, InputState [Token] sym pos) => EHParser AnaParser [Token] sym sym pos where
-- instance (Show sym, Ord sym, Show pos, Position pos, Symbol sym, InputState [Token] sym pos) => EHParser AnaParser [Token] sym sym pos where
instance EHParser AnaParser [Token] Token Token (Maybe Token) where
-- instance (Show sym, Ord sym, Show pos, Position pos, Symbol sym, InputState [Token] sym pos) => EHParser (AnaParser [Token] Pair sym pos) [Token] sym sym pos where
-- instance (Show pos, Position pos, InputState [Token] Token pos) => EHParser AnaParser [Token] Token Token pos where
-- instance InputState [Token] Token Pos => EHParser AnaParser [Token] Token Token Pos where
  ehScanParseToResMsgs sopts popts prs fn fh = do
    tokens <- scanHandle sopts fn fh
    return $ parseToResMsgs prs tokens

instance EHParser OffsideParser [Token] Token (OffsideSymbol Token) (Maybe Token) where
-- instance EHParser (OffsideParser [Token] Pair Token (Maybe Token)) [Token] Token (OffsideSymbol Token) (Maybe Token) where
  ehScanParseToResMsgs sopts popts prs fn fh = do
    tokens <- offsideScanHandle sopts fn fh
    return $ if ehpoptsOkToStopAtErr popts
      then parseOffsideToResMsgsStopAtErr prs tokens
      else parseOffsideToResMsgs prs tokens

{-# LINE 123 "src/ehc/Base/ParseUtils.chs" #-}
-- | The one and only parsing wrapper for parsing from files
parseWithFPath
  :: ( MonadIO m, Monad m
     , EHParser prs inp sym symmsg pos
     )
     => ScanOpts
     -> EHParseOpts
     -> EHPrs prs inp sym pos a
     -- -> prs a
     -> FPath															-- ^ file
     -> m (a,[Err])
parseWithFPath sopts popts p fp = do
    (fn,fh) <- liftIO $ openFPath fp ReadMode False
    let sopts' | ehpoptsLitMode popts = sopts {scoLitmode = True}
               | otherwise            = sopts
    (res,msgs) <- liftIO $ ehScanParseToResMsgs sopts' popts p fn fh
    let errs = map (rngLift emptyRange mkPPErr) msgs
    liftIO $ res `seq` hClose fh
    return (res,errs)