-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.
-- SPDX-License-Identifier: BSD-3-Clause.

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
#include "ghclib_api.h"
module Language.Haskell.GhclibParserEx.GHC.Driver.Session(
      readExtension
    , extensionImplications
-- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2654.
#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810)
    , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags
#endif
    , parsePragmasIntoDynFlags
  ) where

#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810)
import qualified GHC.LanguageExtensions as LangExt
#endif
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900)
import GHC.Utils.Panic
import GHC.Parser.Header
import GHC.Data.StringBuffer
import GHC.Driver.Session
#if defined (GHCLIB_API_HEAD)
import GHC.Types.SourceError
#else
import GHC.Driver.Types
#endif
#else
import Panic
import HeaderInfo
import StringBuffer
import DynFlags
import HscTypes
#endif
import GHC.LanguageExtensions.Type
import Data.List
import Data.Maybe
import qualified Data.Map as Map
-- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707.
#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810)
import Data.Function -- For `compareOn`.
instance Ord Extension where
  compare :: Extension -> Extension -> Ordering
compare = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Extension -> Int) -> Extension -> Extension -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Extension -> Int
forall a. Enum a => a -> Int
fromEnum
#endif

-- | Parse a GHC extension.
readExtension :: String -> Maybe Extension
readExtension :: String -> Maybe Extension
readExtension String
s = FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag (FlagSpec Extension -> Extension)
-> Maybe (FlagSpec Extension) -> Maybe Extension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlagSpec Extension -> Bool)
-> [FlagSpec Extension] -> Maybe (FlagSpec Extension)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(FlagSpec String
n Extension
_ Bool -> DynP ()
_ GhcFlagMode
_) -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) [FlagSpec Extension]
xFlags

-- | Implicitly enabled/disabled extensions.
extensionImplications :: [(Extension, ([Extension], [Extension]))]
extensionImplications :: [(Extension, ([Extension], [Extension]))]
extensionImplications = ((String, ([Extension], [Extension]))
 -> (Extension, ([Extension], [Extension])))
-> [(String, ([Extension], [Extension]))]
-> [(Extension, ([Extension], [Extension]))]
forall a b. (a -> b) -> [a] -> [b]
map (String, ([Extension], [Extension]))
-> (Extension, ([Extension], [Extension]))
forall b. (String, b) -> (Extension, b)
f ([(String, ([Extension], [Extension]))]
 -> [(Extension, ([Extension], [Extension]))])
-> [(String, ([Extension], [Extension]))]
-> [(Extension, ([Extension], [Extension]))]
forall a b. (a -> b) -> a -> b
$ Map String ([Extension], [Extension])
-> [(String, ([Extension], [Extension]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ([Extension], [Extension])
implicationsMap
  where
    f :: (String, b) -> (Extension, b)
f (String
e, b
ps) = (Maybe Extension -> Extension
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe Extension
readExtension String
e), b
ps)
    implicationsMap :: Map.Map String ([Extension], [Extension])
    implicationsMap :: Map String ([Extension], [Extension])
implicationsMap = (([Extension], [Extension])
 -> ([Extension], [Extension]) -> ([Extension], [Extension]))
-> [(String, ([Extension], [Extension]))]
-> Map String ([Extension], [Extension])
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ([Extension], [Extension])
-> ([Extension], [Extension]) -> ([Extension], [Extension])
forall a. Semigroup a => a -> a -> a
(<>)
      [(Extension -> String
forall a. Show a => a -> String
show Extension
a, ([Extension
c | Bool
b], [Extension
c | Bool -> Bool
not Bool
b]))
        | (Extension
a, Bool
flag, Extension
c) <- [(Extension, Bool, Extension)]
impliedXFlags, let b :: Bool
b = Bool
flag Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
turnOn]

-- Landed in
-- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. Copied from
-- 'ghc/compiler/main/DynFlags.hs'.
#if defined(GHCLIB_API_808) || defined(GHCLIB_API_810)

type TurnOnFlag = Bool   -- True  <=> we are turning the flag on
                         -- False <=> we are turning the flag off
turnOn  :: TurnOnFlag; turnOn :: Bool
turnOn  = Bool
True
turnOff :: TurnOnFlag; turnOff :: Bool
turnOff = Bool
False

-- General flags that are switched on/off when other general flags are switched
-- on
impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
impliedGFlags :: [(GeneralFlag, Bool, GeneralFlag)]
impliedGFlags = [(GeneralFlag
Opt_DeferTypeErrors, Bool
turnOn, GeneralFlag
Opt_DeferTypedHoles)
                ,(GeneralFlag
Opt_DeferTypeErrors, Bool
turnOn, GeneralFlag
Opt_DeferOutOfScopeVariables)
                ,(GeneralFlag
Opt_Strictness, Bool
turnOn, GeneralFlag
Opt_WorkerWrapper)
                ,(GeneralFlag
Opt_UnclutterValidHoleFits, Bool
turnOff, GeneralFlag
Opt_ShowTypeAppOfHoleFits)
                ,(GeneralFlag
Opt_UnclutterValidHoleFits, Bool
turnOff, GeneralFlag
Opt_ShowTypeAppVarsOfHoleFits)
                ,(GeneralFlag
Opt_UnclutterValidHoleFits, Bool
turnOff, GeneralFlag
Opt_ShowDocsOfHoleFits)
                ,(GeneralFlag
Opt_ShowTypeAppVarsOfHoleFits, Bool
turnOff, GeneralFlag
Opt_ShowTypeAppOfHoleFits)
                ,(GeneralFlag
Opt_UnclutterValidHoleFits, Bool
turnOff, GeneralFlag
Opt_ShowProvOfHoleFits)]

-- General flags that are switched on/off when other general flags are switched
-- off
impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
impliedOffGFlags :: [(GeneralFlag, Bool, GeneralFlag)]
impliedOffGFlags = [(GeneralFlag
Opt_Strictness, Bool
turnOff, GeneralFlag
Opt_WorkerWrapper)]

impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
impliedXFlags :: [(Extension, Bool, Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
  = [ (Extension
LangExt.RankNTypes,                Bool
turnOn, Extension
LangExt.ExplicitForAll)
    , (Extension
LangExt.QuantifiedConstraints,     Bool
turnOn, Extension
LangExt.ExplicitForAll)
    , (Extension
LangExt.ScopedTypeVariables,       Bool
turnOn, Extension
LangExt.ExplicitForAll)
    , (Extension
LangExt.LiberalTypeSynonyms,       Bool
turnOn, Extension
LangExt.ExplicitForAll)
    , (Extension
LangExt.ExistentialQuantification, Bool
turnOn, Extension
LangExt.ExplicitForAll)
    , (Extension
LangExt.FlexibleInstances,         Bool
turnOn, Extension
LangExt.TypeSynonymInstances)
    , (Extension
LangExt.FunctionalDependencies,    Bool
turnOn, Extension
LangExt.MultiParamTypeClasses)
    , (Extension
LangExt.MultiParamTypeClasses,     Bool
turnOn, Extension
LangExt.ConstrainedClassMethods)  -- c.f. #7854
    , (Extension
LangExt.TypeFamilyDependencies,    Bool
turnOn, Extension
LangExt.TypeFamilies)

    , (Extension
LangExt.RebindableSyntax, Bool
turnOff, Extension
LangExt.ImplicitPrelude)      -- NB: turn off!

    , (Extension
LangExt.DerivingVia, Bool
turnOn, Extension
LangExt.DerivingStrategies)

    , (Extension
LangExt.GADTs,            Bool
turnOn, Extension
LangExt.GADTSyntax)
    , (Extension
LangExt.GADTs,            Bool
turnOn, Extension
LangExt.MonoLocalBinds)
    , (Extension
LangExt.TypeFamilies,     Bool
turnOn, Extension
LangExt.MonoLocalBinds)

    , (Extension
LangExt.TypeFamilies,     Bool
turnOn, Extension
LangExt.KindSignatures)  -- Type families use kind signatures
    , (Extension
LangExt.PolyKinds,        Bool
turnOn, Extension
LangExt.KindSignatures)  -- Ditto polymorphic kinds

    -- TypeInType is now just a synonym for a couple of other extensions.
    , (Extension
LangExt.TypeInType,       Bool
turnOn, Extension
LangExt.DataKinds)
    , (Extension
LangExt.TypeInType,       Bool
turnOn, Extension
LangExt.PolyKinds)
    , (Extension
LangExt.TypeInType,       Bool
turnOn, Extension
LangExt.KindSignatures)

#if defined(GHCLIB_API_810)
    -- Standalone kind signatures are a replacement for CUSKs.
    , (Extension
LangExt.StandaloneKindSignatures, Bool
turnOff, Extension
LangExt.CUSKs)
#endif

    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable
    , (Extension
LangExt.AutoDeriveTypeable, Bool
turnOn, Extension
LangExt.DeriveDataTypeable)

    -- We turn this on so that we can export associated type
    -- type synonyms in subordinates (e.g. MyClass(type AssocType))
    , (Extension
LangExt.TypeFamilies,     Bool
turnOn, Extension
LangExt.ExplicitNamespaces)
    , (Extension
LangExt.TypeOperators, Bool
turnOn, Extension
LangExt.ExplicitNamespaces)

    , (Extension
LangExt.ImpredicativeTypes,  Bool
turnOn, Extension
LangExt.RankNTypes)

        -- Record wild-cards implies field disambiguation
        -- Otherwise if you write (C {..}) you may well get
        -- stuff like " 'a' not in scope ", which is a bit silly
        -- if the compiler has just filled in field 'a' of constructor 'C'
    , (Extension
LangExt.RecordWildCards,     Bool
turnOn, Extension
LangExt.DisambiguateRecordFields)

    , (Extension
LangExt.ParallelArrays, Bool
turnOn, Extension
LangExt.ParallelListComp)

    , (Extension
LangExt.JavaScriptFFI, Bool
turnOn, Extension
LangExt.InterruptibleFFI)

    , (Extension
LangExt.DeriveTraversable, Bool
turnOn, Extension
LangExt.DeriveFunctor)
    , (Extension
LangExt.DeriveTraversable, Bool
turnOn, Extension
LangExt.DeriveFoldable)

    -- Duplicate record fields require field disambiguation
    , (Extension
LangExt.DuplicateRecordFields, Bool
turnOn, Extension
LangExt.DisambiguateRecordFields)

    , (Extension
LangExt.TemplateHaskell, Bool
turnOn, Extension
LangExt.TemplateHaskellQuotes)
    , (Extension
LangExt.Strict, Bool
turnOn, Extension
LangExt.StrictData)
  ]
#endif

parsePragmasIntoDynFlags :: DynFlags
                         -> ([Extension], [Extension])
                         -> FilePath
                         -> String
                         -> IO (Either String DynFlags)
parsePragmasIntoDynFlags :: DynFlags
-> ([Extension], [Extension])
-> String
-> String
-> IO (Either String DynFlags)
parsePragmasIntoDynFlags DynFlags
flags ([Extension]
enable, [Extension]
disable) String
file String
str =
  IO (Either String DynFlags) -> IO (Either String DynFlags)
catchErrors (IO (Either String DynFlags) -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ do
    let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
flags (String -> StringBuffer
stringToStringBuffer String
str) String
file
    -- Important : apply enables, disables *before* parsing dynamic
    -- file pragmas.
    let flags' :: DynFlags
flags' =  (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_set DynFlags
flags [Extension]
enable
    let flags'' :: DynFlags
flags'' = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_unset DynFlags
flags' [Extension]
disable
    (DynFlags
flags, [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
flags'' [Located String]
opts
    Either String DynFlags -> IO (Either String DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DynFlags -> IO (Either String DynFlags))
-> Either String DynFlags -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Either String DynFlags
forall a b. b -> Either a b
Right (DynFlags
flags DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream)
  where
    catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
    catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
catchErrors IO (Either String DynFlags)
act = (GhcException -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException GhcException -> IO (Either String DynFlags)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr
                        ((SourceError -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> IO (Either String DynFlags)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr IO (Either String DynFlags)
act)
    reportErr :: a -> m (Either String b)
reportErr a
e = Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
e)