module Options where

import qualified GHC as GHC
import qualified DynFlags as GHC
import List( (\\) )

data Options = Options
    { allowOverlappingInstances :: Bool
    , allowIncoherentInstances  :: Bool  -- FIXME: implies overlapping instances
    , allowUndecidableInstances :: Bool
    , contextStackDepth         :: Int
    , arrows                    :: Bool
    , generics                  :: Bool
    , monomorphismRestriction   :: Bool
    } deriving (Eq, Show, Read)

ghcflagsToOptions :: GHC.DynFlags -> Options
ghcflagsToOptions ghcFlags =
    Options { allowOverlappingInstances = isSet GHC.Opt_OverlappingInstances
            , allowIncoherentInstances  = isSet GHC.Opt_IncoherentInstances
            , allowUndecidableInstances = isSet GHC.Opt_UndecidableInstances
            , contextStackDepth         = GHC.ctxtStkDepth ghcFlags
            , arrows                    = isSet GHC.Opt_Arrows
            , generics                  = isSet GHC.Opt_Generics
            , monomorphismRestriction   = isSet GHC.Opt_MonomorphismRestriction
            }
        where
          isSet flag     = elem flag (GHC.flags ghcFlags)

setOptions :: Options -> GHC.DynFlags -> GHC.DynFlags
setOptions options dynFlags =
    let mapping =
            [ (allowOverlappingInstances, GHC.Opt_OverlappingInstances)
            , (allowIncoherentInstances,  GHC.Opt_IncoherentInstances)
            , (allowUndecidableInstances, GHC.Opt_UndecidableInstances)
            , (arrows,                    GHC.Opt_Arrows)
            , (generics,                  GHC.Opt_Generics)
            , (monomorphismRestriction,   GHC.Opt_MonomorphismRestriction)
            ]
        include opt (optionF, ghcOption) =
            if optionF opt
               then [ghcOption]
               else []
        compileOptions = map (include options) mapping
        removeFlags = GHC.flags dynFlags \\ map snd mapping
    in dynFlags { GHC.flags = concat (removeFlags:compileOptions)
                , GHC.ctxtStkDepth = contextStackDepth options
                }