# LANGUAGE ScopedTypeVariables #
module CabalHasklint.Parse (
    parse,
) where

import Peura

import qualified Distribution.ModuleName      as C
import qualified Distribution.Types.BuildInfo as C
import qualified Distribution.Types.Version   as C

import GHC.Data.StringBuffer                      (stringToStringBuffer)
import GHC.Driver.Config.Parser                   (initParserOpts)
import GHC.Driver.Ppr                             (showPpr)
import GHC.Driver.Session                         (DynFlags, parseDynamicFilePragma, parseDynamicFlagsCmdLine, xopt)
import GHC.Hs                                     (HsModule)
import GHC.Parser.Header                          (getOptions)
import GHC.Parser.Lexer                           (ParseResult (..), getPsErrorMessages)
import GHC.Types.SrcLoc                           (Located, noLoc)
import GHC.Utils.Error                            (pprMessages)
import Language.Haskell.GhclibParserEx.GHC.Parser (parseFile)

import qualified GHC.LanguageExtensions.Type as LangExt

import CabalHasklint.Cpp
import CabalHasklint.GHC.Utils
import CabalHasklint.Trace

import qualified Prelude

  | Parse module .
--
-- Read file, extract doctest blocks.
--
  In particular , this runs CPP preprocessing if needed .
parse
    :: forall r. TracerPeu r Tr
    -> GhcInfo
    -> Version             -- ^ package version
    -> Path Absolute       -- ^ package directory
    -> [Path Absolute]     -- ^ additional include directories
    -> [PackageIdentifier] -- ^ dependencies
    -> C.BuildInfo
    -> C.ModuleName
    -> Path Absolute
    -> Peu r (Located HsModule)
parse tracer ghcInfo pkgVer pkgDir cppDirs pkgIds bi modname modpath = do
    traceApp tracer $ TraceParse modname modpath
    let dflags0 = fakeDynFlags

    -- set flags from bi
    (dflags1, _, _warns1) <- liftIO $ parseDynamicFlagsCmdLine dflags0 $
        [ noLoc $ "-X" ++ prettyShow ext
        | ext <- C.defaultExtensions bi
        ]

    -- read file
    contents <- fromUTF8BS <$> readByteString modpath

    -- parse in-file options
    let (_, options2) = getOptions (initParserOpts dflags1) (stringToStringBuffer contents) (toFilePath modpath)
    (dflags2, _, _warns2) <- liftIO $ parseDynamicFilePragma dflags1 options2

  do CPP
    contents' <- if xopt LangExt.Cpp dflags2
        then cpphs tracer pkgVer pkgIds cppIncludes cppDefines modpath contents
        else return contents

    -- reparse in-file options
    let (_, options) = getOptions (initParserOpts dflags2) (stringToStringBuffer contents) (toFilePath modpath)
    (dflags, _, _warns) <- liftIO $ parseDynamicFilePragma dflags1 options

    -- parse module
    md <- fromParseResult dflags (parseFile (toFilePath modpath) dflags contents')
    return md
  where
    fromParseResult :: DynFlags -> ParseResult a -> Peu r a
    fromParseResult _dflags (POk _ x)   = return x
    fromParseResult  dflags (PFailed s) = do
        let errors = getPsErrorMessages s
        liftIO $ Prelude.putStrLn $ showPpr dflags $ pprMessages errors
        die tracer "Parse failure"

    cppIncludes :: [Path Absolute]
    cppIncludes =
        -- if there are absolute dirs, they are converted to relative,
        -- so may break
        [ pkgDir </> fromUnrootedFilePath dir
        | dir <- C.includeDirs bi
        ] ++ cppDirs

    cppDefines :: [(String, String)]
    cppDefines =
        [ ("__GLASGOW_HASKELL__", cppGhcVersion (ghcVersion ghcInfo))
        ] ++
        [ d'
        | d <- C.cppOptions bi
        , Just d' <- return (parseDefineFlag d)
        ]

cppGhcVersion :: Version -> String
cppGhcVersion v = case C.versionNumbers v of
    []      -> "0"
    (x:[])  -> show (x * 100)
    (x:y:_) -> show (x * 100 + y)

parseDefineFlag :: String -> Maybe (String, String)
parseDefineFlag ('-' : 'D' : rest) =
    case after of
        []        -> Nothing
        '=':value -> Just (before, value)
        _         -> Nothing -- shouldn't happen
  where
    (before, after) = span (/= '=') rest

parseDefineFlag _ = Nothing


 Read file, extract doctest blocks.

 ^ package version
 ^ package directory
 ^ additional include directories
 ^ dependencies
 set flags from bi
 read file
 parse in-file options
 reparse in-file options
 parse module
 if there are absolute dirs, they are converted to relative,
 so may break
 shouldn't happen
# LANGUAGE ScopedTypeVariables #
module CabalHasklint.Parse (
    parse,
) where

import Peura

import qualified Distribution.ModuleName      as C
import qualified Distribution.Types.BuildInfo as C
import qualified Distribution.Types.Version   as C

import GHC.Data.StringBuffer                      (stringToStringBuffer)
import GHC.Driver.Config.Parser                   (initParserOpts)
import GHC.Driver.Ppr                             (showPpr)
import GHC.Driver.Session                         (DynFlags, parseDynamicFilePragma, parseDynamicFlagsCmdLine, xopt)
import GHC.Hs                                     (HsModule)
import GHC.Parser.Header                          (getOptions)
import GHC.Parser.Lexer                           (ParseResult (..), getPsErrorMessages)
import GHC.Types.SrcLoc                           (Located, noLoc)
import GHC.Utils.Error                            (pprMessages)
import Language.Haskell.GhclibParserEx.GHC.Parser (parseFile)

import qualified GHC.LanguageExtensions.Type as LangExt

import CabalHasklint.Cpp
import CabalHasklint.GHC.Utils
import CabalHasklint.Trace

import qualified Prelude

  | Parse module .
  In particular , this runs CPP preprocessing if needed .
parse
    :: forall r. TracerPeu r Tr
    -> GhcInfo
    -> C.BuildInfo
    -> C.ModuleName
    -> Path Absolute
    -> Peu r (Located HsModule)
parse tracer ghcInfo pkgVer pkgDir cppDirs pkgIds bi modname modpath = do
    traceApp tracer $ TraceParse modname modpath
    let dflags0 = fakeDynFlags

    (dflags1, _, _warns1) <- liftIO $ parseDynamicFlagsCmdLine dflags0 $
        [ noLoc $ "-X" ++ prettyShow ext
        | ext <- C.defaultExtensions bi
        ]

    contents <- fromUTF8BS <$> readByteString modpath

    let (_, options2) = getOptions (initParserOpts dflags1) (stringToStringBuffer contents) (toFilePath modpath)
    (dflags2, _, _warns2) <- liftIO $ parseDynamicFilePragma dflags1 options2

  do CPP
    contents' <- if xopt LangExt.Cpp dflags2
        then cpphs tracer pkgVer pkgIds cppIncludes cppDefines modpath contents
        else return contents

    let (_, options) = getOptions (initParserOpts dflags2) (stringToStringBuffer contents) (toFilePath modpath)
    (dflags, _, _warns) <- liftIO $ parseDynamicFilePragma dflags1 options

    md <- fromParseResult dflags (parseFile (toFilePath modpath) dflags contents')
    return md
  where
    fromParseResult :: DynFlags -> ParseResult a -> Peu r a
    fromParseResult _dflags (POk _ x)   = return x
    fromParseResult  dflags (PFailed s) = do
        let errors = getPsErrorMessages s
        liftIO $ Prelude.putStrLn $ showPpr dflags $ pprMessages errors
        die tracer "Parse failure"

    cppIncludes :: [Path Absolute]
    cppIncludes =
        [ pkgDir </> fromUnrootedFilePath dir
        | dir <- C.includeDirs bi
        ] ++ cppDirs

    cppDefines :: [(String, String)]
    cppDefines =
        [ ("__GLASGOW_HASKELL__", cppGhcVersion (ghcVersion ghcInfo))
        ] ++
        [ d'
        | d <- C.cppOptions bi
        , Just d' <- return (parseDefineFlag d)
        ]

cppGhcVersion :: Version -> String
cppGhcVersion v = case C.versionNumbers v of
    []      -> "0"
    (x:[])  -> show (x * 100)
    (x:y:_) -> show (x * 100 + y)

parseDefineFlag :: String -> Maybe (String, String)
parseDefineFlag ('-' : 'D' : rest) =
    case after of
        []        -> Nothing
        '=':value -> Just (before, value)
  where
    (before, after) = span (/= '=') rest

parseDefineFlag _ = Nothing
