<|start_filename|>examples/mini-compile/test/MiniCompileTest.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: (Apache-2.0 OR BSD-3-Clause)

-- Based on https://github.com/ghc/ghc/blob/23f6f31dd66d7c370cb8beec3f1d96a0cb577393/libraries/ghc-prim/GHC/Types.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MagicHash #-}

module GHC.Types (
        -- Data types that are built-in syntax
        -- They are defined here, but not explicitly exported
        --
        --    Lists:          []( [], (::) )

        Bool(..), Int (..), Word, TextLit,
        Ordering(..),
        Symbol,
        ifThenElse,
        Multiplicity(..)
    ) where

import GHC.Prim

infixr 5 :

-- | The kind of constraints, like `Show a`
data Constraint

data Multiplicity = Many | One

-- | (Kind) This is the kind of type-level symbols.
-- Declared here because class IP needs it
data Symbol

-- | Documentation for lists
data [] a = [] | a : [a]


-- | Information about ordering
data Ordering = LT | EQ | GT

-- | A 64-bit integer.
data Int =
  I# Int#

-- This is a dummy type we need for string literals.
data Char

type TextLit = [Char]

-- A dummy type for Word.
data Word

data Bool = False | True

isTrue# :: Int# -> Bool
{-# INLINE isTrue# #-}
isTrue# x = tagToEnum# x

ifThenElse :: Bool -> a -> a -> a
ifThenElse c t f = case c of True -> t; False -> f

data Module = Module
                TrName   -- Package name
                TrName   -- Module name

data TrName
  = TrNameS Addr#  -- Static
  | TrNameD [Char] -- Dynamic

type KindBndr = Int

data RuntimeRep

data KindRep = KindRepTyConApp TyCon [KindRep]
             | KindRepVar !KindBndr
             | KindRepApp KindRep KindRep
             | KindRepFun KindRep KindRep
             | KindRepTYPE !RuntimeRep
             | KindRepTypeLitS TypeLitSort Addr#
             | KindRepTypeLitD TypeLitSort [Char]

data TypeLitSort = TypeLitSymbol
                 | TypeLitNat
                 | TypeLitChar

data TyCon = TyCon Word# Word#           -- Fingerprint
                   Module                -- Module in which this is defined
                   TrName                -- Type constructor name
                   Int#                  -- How many kind variables do we accept?
                   KindRep               -- A representation of the type's kind


<|start_filename|>examples/mini-hlint/src/Main.hs<|end_filename|>
-- Copyright (c) 2019 - 2021, Digital Asset (Switzerland) GmbH and/or
-- its affiliates. All rights reserved. SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)

{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}

module Main (main) where

-- We use 0.x for HEAD
#if !MIN_VERSION_ghc_lib_parser(1,0,0)
#  define GHC_MASTER
#elif MIN_VERSION_ghc_lib_parser(9,2,0)
#  define GHC_921
#elif MIN_VERSION_ghc_lib_parser(9,0,0)
#  define GHC_901
#elif MIN_VERSION_ghc_lib_parser(8,10,0)
#  define GHC_8101
#endif

#if defined (GHC_MASTER)
import "ghc-lib-parser" GHC.Driver.Config.Diagnostic
import "ghc-lib-parser" GHC.Utils.Logger
import "ghc-lib-parser" GHC.Driver.Errors
import "ghc-lib-parser" GHC.Driver.Errors.Types
import "ghc-lib-parser" GHC.Types.Error
#endif
#if defined (GHC_MASTER)
import "ghc-lib-parser" GHC.Driver.Config.Parser
#endif
#if defined (GHC_MASTER) || defined (GHC_921)
import "ghc-lib-parser" GHC.Driver.Ppr
import "ghc-lib-parser" GHC.Driver.Config
#endif
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
import "ghc-lib-parser" GHC.Hs
#else
import "ghc-lib-parser" HsSyn
#endif
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901)
import "ghc-lib-parser" GHC.Settings.Config
import "ghc-lib-parser" GHC.Driver.Session
import "ghc-lib-parser" GHC.Data.StringBuffer
import "ghc-lib-parser" GHC.Utils.Fingerprint
import "ghc-lib-parser" GHC.Parser.Lexer
import "ghc-lib-parser" GHC.Types.Name.Reader
import "ghc-lib-parser" GHC.Utils.Error
import qualified "ghc-lib-parser" GHC.Parser
import "ghc-lib-parser" GHC.Data.FastString
import "ghc-lib-parser" GHC.Utils.Outputable
#  if !defined (GHC_901)
import "ghc-lib-parser" GHC.Parser.Errors.Ppr
#  endif
import "ghc-lib-parser" GHC.Types.SrcLoc
import "ghc-lib-parser" GHC.Utils.Panic
#  if defined (GHC_MASTER) || defined (GHC_921)
import "ghc-lib-parser" GHC.Types.SourceError
#  else
import "ghc-lib-parser" GHC.Driver.Types
#  endif
import "ghc-lib-parser" GHC.Parser.Header
import "ghc-lib-parser" GHC.Parser.Annotation
#else
import "ghc-lib-parser" Config
import "ghc-lib-parser" DynFlags
import "ghc-lib-parser" StringBuffer
import "ghc-lib-parser" Fingerprint
import "ghc-lib-parser" Lexer
import "ghc-lib-parser" RdrName
import "ghc-lib-parser" ErrUtils
import qualified "ghc-lib-parser" Parser
import "ghc-lib-parser" FastString
import "ghc-lib-parser" Outputable
import "ghc-lib-parser" SrcLoc
import "ghc-lib-parser" Panic
import "ghc-lib-parser" HscTypes
import "ghc-lib-parser" HeaderInfo
import "ghc-lib-parser" ApiAnnotation
#endif
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901)
import "ghc-lib-parser" GHC.Settings
#elif defined (GHC_8101)
import "ghc-lib-parser" ToolSettings
#endif
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
import "ghc-lib-parser" GHC.Platform
#else
import "ghc-lib-parser" Bag
import "ghc-lib-parser" Platform
#endif

import Control.Monad.Extra
import System.Environment
import System.IO.Extra
import qualified Data.Map as Map
import Data.Generics.Uniplate.Operations
import Data.Generics.Uniplate.Data

fakeSettings :: Settings
fakeSettings = Settings
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
  { sGhcNameVersion=ghcNameVersion
  , sFileSettings=fileSettings
  , sTargetPlatform=platform
  , sPlatformMisc=platformMisc
#if !defined (GHC_MASTER) && !defined (GHC_921)
  , sPlatformConstants=platformConstants
#endif
  , sToolSettings=toolSettings
  }
#else
  { sTargetPlatform=platform
  , sPlatformConstants=platformConstants
  , sProjectVersion=cProjectVersion
  , sProgramName="ghc"
  , sOpt_P_fingerprint=fingerprint0
  }
#endif
  where
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
    toolSettings = ToolSettings {
      toolSettings_opt_P_fingerprint=fingerprint0
      }
    fileSettings = FileSettings {}
    platformMisc = PlatformMisc {}
    ghcNameVersion =
      GhcNameVersion{ghcNameVersion_programName="ghc"
                    ,ghcNameVersion_projectVersion=cProjectVersion
                    }
#endif

    platform =
#if defined (GHC_MASTER)
      genericPlatform
#else
      Platform{
#if defined (GHC_921) || defined (GHC_901)
    -- It doesn't matter what values we write here as these fields are
    -- not referenced for our purposes. However the fields are strict
    -- so we must say something.
        platformByteOrder=LittleEndian
      , platformHasGnuNonexecStack=True
      , platformHasIdentDirective=False
      , platformHasSubsectionsViaSymbols=False
      , platformIsCrossCompiling=False
      , platformLeadingUnderscore=False
      , platformTablesNextToCode=False
#if defined(GHC_921)
      , platform_constants = Nothing
#endif
#if !defined(GHC_921) && !defined (GHC_901)
      , platformConstants=platformConstants
#endif
      ,
#endif
#if defined (GHC_921)
        platformWordSize=PW8
      , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown}
#elif defined (GHC_8101) || defined (GHC_901)
        platformWordSize=PW8
      , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown}
#else
        platformWordSize=8
      , platformOS=OSUnknown
#endif
      , platformUnregisterised=True
      }
#if !defined(GHC_MASTER) && !defined(GHC_921)
    platformConstants =
      PlatformConstants{
          pc_DYNAMIC_BY_DEFAULT=False
        ,
          pc_WORD_SIZE=8
    }
#endif
#endif

#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
fakeLlvmConfig :: LlvmConfig
fakeLlvmConfig = LlvmConfig [] []
#else
fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
fakeLlvmConfig = ([], [])
#endif

#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901)
parse :: String -> DynFlags -> String -> ParseResult (Located HsModule)
#else
parse :: String -> DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
#endif
parse filename flags str =
#if defined (GHC_MASTER) || defined (GHC_921) || defined (GHC_901)
  unP GHC.Parser.parseModule parseState
#else
  unP Parser.parseModule parseState
#endif
  where
    location = mkRealSrcLoc (mkFastString filename) 1 1
    buffer = stringToStringBuffer str
    parseState =
#if defined (GHC_MASTER) || defined (GHC_921)
      initParserState (initParserOpts flags) buffer location
#else
      mkPState flags buffer location
#endif

parsePragmasIntoDynFlags :: DynFlags -> FilePath -> String -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags flags filepath str =
  catchErrors $ do
    let opts = getOptions
#if defined (GHC_MASTER)
                 (initParserOpts flags)
#else
                 flags
#endif
                 (stringToStringBuffer str) filepath
    (flags, _, _) <- parseDynamicFilePragma flags opts
    return $ Just flags
  where
    catchErrors :: IO (Maybe DynFlags) -> IO (Maybe DynFlags)
    catchErrors act = handleGhcException reportGhcException
                        (handleSourceError reportSourceErr act)

    reportGhcException e = do
      print e; return Nothing

    reportSourceErr msgs = do
      putStrLn $ head
             [ showSDoc flags msg
             | msg <-
#if defined (GHC_MASTER)
                      pprMsgEnvelopeBagWithLoc . getMessages
#elif defined (GHC_921)
                      pprMsgEnvelopeBagWithLoc
#else
                      pprErrMsgBagWithLoc
#endif
                      $ srcErrorMessages msgs
             ]
      return Nothing

idNot :: RdrName
idNot = mkVarUnqual (fsLit "not")

isNegated :: HsExpr GhcPs -> Bool
isNegated (HsApp _ (L _ (HsVar _ (L _ id))) _) = id == idNot
#if defined (GHC_MASTER)
isNegated (HsPar _ _ (L _ e) _) = isNegated e
#else
isNegated (HsPar _ (L _ e)) = isNegated e
#endif
isNegated _ = False

#if defined (GHC_MASTER) || defined (GHC_921)
analyzeExpr :: DynFlags -> LocatedA (HsExpr GhcPs) -> IO ()
#else
analyzeExpr :: DynFlags -> Located (HsExpr GhcPs) -> IO ()
#endif
analyzeExpr flags (L loc expr) = do
  case expr of
    HsApp _ (L _ (HsVar _ (L _ id))) (L _ e)
        | id == idNot, isNegated e ->
#if defined (GHC_MASTER) || defined (GHC_921)
            putStrLn (showSDoc flags (ppr (locA loc))
#else
            putStrLn (showSDoc flags (ppr loc)
#endif
                      ++ " : lint : double negation "
                      ++ "`" ++ showSDoc flags (ppr expr) ++ "'")
    _ -> return ()

#if defined (GHC_MASTER) || defined (GHC_921)
analyzeModule :: DynFlags -> Located HsModule -> IO ()
#elif defined (GHC_901)
analyzeModule :: DynFlags -> Located HsModule -> ApiAnns -> IO ()
#else
analyzeModule :: DynFlags -> Located (HsModule GhcPs) -> ApiAnns -> IO ()
#endif
analyzeModule flags (L _ modu)
#if !(defined (GHC_MASTER) || defined (GHC_921))
                                _ -- ApiAnns
#endif
 = sequence_ [analyzeExpr flags e | e <- universeBi modu]

main :: IO ()
main = do
  args <- getArgs
  case args of
    [file] -> do
      s <- readFile' file
      flags <-
        parsePragmasIntoDynFlags
          (defaultDynFlags fakeSettings fakeLlvmConfig) file s
      whenJust flags $ \flags ->
         case parse file (flags `gopt_set` Opt_KeepRawTokenStream)s of
#if defined (GHC_MASTER)
            PFailed s -> report flags $ GhcPsMessage <$> snd (getPsMessages s)
#elif defined (GHC_921)
            PFailed s -> report flags $ fmap pprError (snd (getMessages s))
#elif defined (GHC_901) || defined (GHC_8101)
            PFailed s -> report flags $ snd (getMessages s flags)
#else
            PFailed _ loc err -> report flags $ unitBag $ mkPlainErrMsg flags loc err
#endif
            POk s m -> do
#if defined (GHC_MASTER)
              let (wrns, errs) = getPsMessages s
              report flags $ GhcPsMessage <$> wrns
              report flags $ GhcPsMessage <$> errs
#elif defined (GHC_921)
              let (wrns, errs) = getMessages s
              report flags (fmap pprWarning wrns)
              report flags (fmap pprError errs)
#else
              let (wrns, errs) = getMessages s flags
              report flags wrns
              report flags errs
#endif
              when (null errs) $
                analyzeModule flags m
#if !(defined (GHC_MASTER) || defined (GHC_921))
                                      (harvestAnns s)
#endif
    _ -> fail "Exactly one file argument required"
  where

#if defined (GHC_MASTER)
    -- Nowdays, to print hints along with errors you need 'printMessages'.
    -- See
    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6087#note_365215
    -- for details.
    report flags msgs = do
      logger <- initLogger
      let opts = initDiagOpts flags
      printMessages logger opts msgs
#else
    report flags msgs =
      sequence_
        [ putStrLn $ showSDoc flags msg
        | msg <-
#  if defined (GHC_921)
                  pprMsgEnvelopeBagWithLoc msgs
#  else
                  pprErrMsgBagWithLoc msgs
#  endif
        ]
#endif
#if !(defined(GHC_MASTER) || defined (GHC_921))
    harvestAnns pst =
#  if defined (GHC_901)
        ApiAnns {
              apiAnnItems = Map.fromListWith (++) $ annotations pst
            , apiAnnEofPos = Nothing
            , apiAnnComments = Map.fromListWith (++) $ annotations_comments pst
            , apiAnnRogueComments = comment_q pst
            }
#  else
      ( Map.fromListWith (++) $ annotations pst
      , Map.fromList ((noSrcSpan, comment_q pst) : annotations_comments pst)
      )
#  endif
#endif


<|start_filename|>ghc-lib-gen/Setup.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: (Apache-2.0 OR BSD-3-Clause)

import Distribution.Simple
main = defaultMain


<|start_filename|>examples/mini-hlint/test/MiniHlintTest_non_fatal_error.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its
-- affiliates. All rights reserved.  SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)
{-# LANGUAGE NoImportQualifiedPost #-}

module MiniHlintTest_non_fatal_error where

import Data.List qualified

-- test/MiniHlintTest_non_fatal_error.hs:8:18: error:
--     Found `qualified' in postpositive position.
--     To allow this, enable language extension 'ImportQualifiedPost'


<|start_filename|>examples/mini-hlint/test/MiniHlintTest.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: (Apache-2.0 OR BSD-3-Clause)

module MiniHlintTest where

f :: Bool -> Int
f x = 1 + if id (not (not x)) || False then 1 else 2


<|start_filename|>examples/test-utils/src/TestUtils.hs<|end_filename|>
-- Copyright (c) 2021, Digital Asset (Switzerland) GmbH and/or
-- its affiliates. All rights reserved.  SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)
{-# OPTIONS_GHC -Werror=unused-imports -Werror=unused-local-binds -Werror=unused-top-binds -Werror=orphans #-}
{-# LANGUAGE LambdaCase #-}

module TestUtils where

import Test.Tasty.Options
import Data.Typeable (Typeable)
import Data.ByteString.Lazy.UTF8
import Data.Functor
import System.Process.Extra

newtype StackYaml = StackYaml (Maybe String)
  deriving (Eq, Ord, Typeable)
-- Give as a path relative to the directory containing
-- mini-hlint.cabal. e.g ../../stack.yaml

newtype Resolver = Resolver (Maybe String)
  deriving (Eq, Ord, Typeable)

data GhcVersion = DaGhc881
                | Ghc881
                | Ghc882
                | Ghc883
                | Ghc884
                | Ghc8101
                | Ghc8102
                | Ghc8103
                | Ghc8104
                | Ghc8105
                | Ghc8106
                | Ghc8107
                | Ghc901
                | Ghc921
                | GhcMaster
  deriving (Eq, Ord, Typeable)

instance Show GhcVersion where
  show = showGhcVersion

showGhcVersion :: GhcVersion -> String
showGhcVersion = \case
    Ghc921 -> "ghc-9.2.1"
    Ghc901 -> "ghc-9.0.1"
    Ghc8101 -> "ghc-8.10.1"
    Ghc8102 -> "ghc-8.10.2"
    Ghc8103 -> "ghc-8.10.3"
    Ghc8104 -> "ghc-8.10.4"
    Ghc8105 -> "ghc-8.10.5"
    Ghc8106 -> "ghc-8.10.6"
    Ghc8107 -> "ghc-8.10.7"
    Ghc881 -> "ghc-8.8.1"
    Ghc882 -> "ghc-8.8.2"
    Ghc883 -> "ghc-8.8.3"
    Ghc884 -> "ghc-8.8.4"
    DaGhc881 -> "da-ghc-8.8.1"
    GhcMaster -> "ghc-master"

newtype GhcFlavor = GhcFlavor GhcVersion
  deriving(Eq, Ord, Typeable)

readFlavor :: String -> Maybe GhcFlavor
readFlavor = (GhcFlavor <$>) . \case
    "ghc-9.2.1" -> Just Ghc921
    "ghc-9.0.1" -> Just Ghc901
    "ghc-8.10.1" -> Just Ghc8101
    "ghc-8.10.2" -> Just Ghc8102
    "ghc-8.10.3" -> Just Ghc8103
    "ghc-8.10.4" -> Just Ghc8104
    "ghc-8.10.5" -> Just Ghc8105
    "ghc-8.10.6" -> Just Ghc8106
    "ghc-8.10.7" -> Just Ghc8107
    "ghc-8.8.1" -> Just Ghc881
    "ghc-8.8.2" -> Just Ghc882
    "ghc-8.8.3" -> Just Ghc883
    "ghc-8.8.4" -> Just Ghc884
    "da-ghc-8.8.1" -> Just DaGhc881
    "ghc-master" -> Just GhcMaster
    _ -> Nothing

instance IsOption GhcFlavor where
  defaultValue = GhcFlavor GhcMaster
  parseValue = readFlavor
  optionName = return "ghc-flavor"
  optionHelp = return "GHC flavor"

instance IsOption StackYaml where
  defaultValue = StackYaml Nothing
  parseValue = Just . StackYaml . Just
  optionName = return "stack-yaml"
  optionHelp = return "Configuration file"

instance IsOption Resolver where
  defaultValue = Resolver Nothing
  parseValue = Just . Resolver . Just
  optionName = return "resolver"
  optionHelp = return "Resolver override"

stack :: StackYaml -> Resolver -> String -> IO ByteString
stack (StackYaml stackYaml) (Resolver resolver) action =
  systemOutput_ ("stack " ++
    concatMap (<> " ")
           [ stackYamlOpt stackYaml
           , resolverOpt resolver
           ] ++
    action) <&> fromString

stackYamlOpt :: Maybe String -> String
stackYamlOpt = maybe "" ("--stack-yaml " ++)

resolverOpt :: Maybe String -> String
resolverOpt = maybe "" ("--resolver " ++)


<|start_filename|>examples/mini-hlint/test/MiniHlintTest_fail_unknown_pragma.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its
-- affiliates. All rights reserved.  SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)

{-# LANGUAGE Foo #-}

module MiniHlintTest_fail_unknown_pragma where

-- Error : Unsupported extension: Foo


<|start_filename|>examples/mini-hlint/test/MiniHlintTest_respect_dynamic_pragma.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its
-- affiliates. All rights reserved.  SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)

-- Test 'parsePragmasIntoDynFlags'. This should parse.
{-# LANGUAGE ImportQualifiedPost #-}

module MiniHlintTest_respect_dynamic_pragma where

import Data.List qualified


<|start_filename|>ghc-lib-gen/src/GhclibgenOpts.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its
-- affiliates. All rights reserved.  SPDX-License-Identifier:
-- (Apache-2.0 OR BSD-3-Clause)

{-# LANGUAGE LambdaCase #-}
module GhclibgenOpts(
    GhclibgenTarget(..)
  , GhclibgenOpts(..)
  , GhcFlavor(..)
  , ghclibgenVersion
  , ghclibgenOpts
) where

import Control.Applicative
import Options.Applicative
import Data.Maybe
import Data.Version (showVersion)
import Paths_ghc_lib_gen (version)

-- | A ghc-lib-gen target.
data GhclibgenTarget = GhclibParser | Ghclib

-- | The type of ghc-lib-gen options.
data GhclibgenOpts = GhclibgenOpts {
    ghclibgenOpts_root :: !FilePath -- ^ Path to a GHC git repository.
  , ghclibgenOpts_target :: !GhclibgenTarget -- ^ What target?
  , ghclibgenOpts_ghcFlavor :: !GhcFlavor
 }

-- | A parser of the "--ghc-lib" target.
ghclib :: Parser GhclibgenTarget
ghclib = flag' Ghclib
  ( long "ghc-lib"
  <> help "Generate a ghc-lib.cabal"
  )

-- | A parser of the "--ghc-lib-parser" target.
ghclibParser :: Parser GhclibgenTarget
ghclibParser = flag' GhclibParser
  ( long "ghc-lib-parser"
  <> help "Generate a ghc-lib-parser.cabal"
  )

-- | A parser of "--version".
ghclibgenVersion :: Parser (a -> a)
ghclibgenVersion =
  infoOption
  (showVersion version)
  (long "version" <> help "Show version")

-- | A parser of a ghc-lib-gen target: `target := | "--ghc-lib-parser"
-- | "--ghc-lib" | /* nothing */`.
ghclibgenTarget :: Parser GhclibgenTarget
ghclibgenTarget =
  fromMaybe Ghclib Control.Applicative.<$> optional (ghclibParser <|> ghclib)

-- | A parser of ghc-lib-gen options: `opts := STRING target`.
ghclibgenOpts :: Parser GhclibgenOpts
ghclibgenOpts = GhclibgenOpts
  <$> argument str (metavar "GHC_ROOT")
  <*> ghclibgenTarget
  <*> ghcFlavorOpt

-- | We might want to factor this out so we can share it with CI.hs
-- but for now it doesn’t seem worth it and having CI.hs be
-- self-contained simplifies things.
data GhcFlavor = DaGhc881
               | Ghc881
               | Ghc882
               | Ghc883
               | Ghc884
               | Ghc8101
               | Ghc8102
               | Ghc8103
               | Ghc8104
               | Ghc8105
               | Ghc8106
               | Ghc8107
               | Ghc901
               | Ghc921
               | GhcMaster
    deriving (Show, Eq, Ord)

ghcFlavorOpt :: Parser GhcFlavor
ghcFlavorOpt = option readFlavor
    ( long "ghc-flavor"
   <> help "The ghc-flavor to test against"
    )

readFlavor :: ReadM GhcFlavor
readFlavor = eitherReader $ \case
    "ghc-9.2.1" -> Right Ghc921
    "ghc-9.0.1" -> Right Ghc901
    "ghc-8.10.1" -> Right Ghc8101
    "ghc-8.10.2" -> Right Ghc8102
    "ghc-8.10.3" -> Right Ghc8103
    "ghc-8.10.4" -> Right Ghc8104
    "ghc-8.10.5" -> Right Ghc8105
    "ghc-8.10.6" -> Right Ghc8106
    "ghc-8.10.7" -> Right Ghc8107
    "ghc-8.8.1" -> Right Ghc881
    "ghc-8.8.2" -> Right Ghc882
    "ghc-8.8.3" -> Right Ghc883
    "ghc-8.8.4" -> Right Ghc884
    "da-ghc-8.8.1" -> Right DaGhc881
    "ghc-master" -> Right GhcMaster
    flavor -> Left $ "Failed to parse ghc flavor " <> show flavor <> " expected ghc-master, ghc-9.0.1, ghc-8.8.1, ghc-8.8.2, ghc-8.8.3, ghc-8.8.4, da-ghc-8.8.1, ghc-8.10.1, ghc-8.10.2, ghc-8.10.3, ghc-8.10.4, ghc-8.10.5, ghc-8.10.6, ghc-8.10.7, ghc-9.0.1 or ghc-9.2.1"


<|start_filename|>examples/mini-compile/src/Main.hs<|end_filename|>
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: (Apache-2.0 OR BSD-3-Clause)

{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}

module Main (main) where

-- We use 0.x for HEAD
#if !MIN_VERSION_ghc_lib(1,0,0)
#  define GHC_MASTER
#elif MIN_VERSION_ghc_lib(9,2,1)
#  define GHC_921
#elif MIN_VERSION_ghc_lib(9,0,0)
#  define GHC_901
#elif MIN_VERSION_ghc_lib(8,10,1)
#  define GHC_8101
#endif

-- ghc-lib re-exports the modules of ghc-lib-parser. Before 9.2.1 we
-- couldn't refer to them as being in the ghc-lib package (and instead
-- had to refer to them as being in the ghc-lib-parser package). Now
-- it seems we can (and in fact, if we were refer to them in the
-- ghc-lib-parser package now, we would then be required to link that
-- library).
#if __GLASGOW_HASKELL__ >= 902
# define GHC_LIB_PARSER_PKG "ghc-lib"
#else
# define GHC_LIB_PARSER_PKG "ghc-lib-parser"
#endif

import "ghc-lib" GHC
import "ghc-lib" Paths_ghc_lib
#if defined (GHC_MASTER) ||  defined (GHC_921) || defined (GHC_901)
#  if defined (GHC_MASTER)
import GHC_LIB_PARSER_PKG GHC.Driver.Config.Parser
#  endif
import GHC_LIB_PARSER_PKG GHC.Parser.Header
import GHC_LIB_PARSER_PKG GHC.Unit.Module
import GHC_LIB_PARSER_PKG GHC.Driver.Session
import GHC_LIB_PARSER_PKG GHC.Data.StringBuffer
import GHC_LIB_PARSER_PKG GHC.Utils.Fingerprint
import GHC_LIB_PARSER_PKG GHC.Utils.Outputable
#  if !defined (GHC_901)
import GHC_LIB_PARSER_PKG GHC.Driver.Ppr
#  endif
#else
import GHC_LIB_PARSER_PKG HeaderInfo
import GHC_LIB_PARSER_PKG Module
import GHC_LIB_PARSER_PKG DynFlags
import GHC_LIB_PARSER_PKG StringBuffer
import GHC_LIB_PARSER_PKG Fingerprint
import GHC_LIB_PARSER_PKG Outputable
#endif
#if defined (GHC_MASTER)  || defined (GHC_921) || defined (GHC_901)
import GHC_LIB_PARSER_PKG GHC.Settings
import GHC_LIB_PARSER_PKG GHC.Settings.Config
#elif defined (GHC_8101)
import GHC_LIB_PARSER_PKG Config
import GHC_LIB_PARSER_PKG ToolSettings
#endif
#if defined (GHC_MASTER) ||  defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
import GHC_LIB_PARSER_PKG GHC.Platform
#else
import GHC_LIB_PARSER_PKG Config
import GHC_LIB_PARSER_PKG Platform
#endif

import System.Environment
import System.Directory
import System.IO.Extra
import qualified Data.Map.Strict as Map
import Data.IORef

main :: IO ()
main = do
  args <- getArgs
  case args of
    [file] -> do
      s <- readFile' file
      flags <- mkDynFlags file s
      dataDir <- getDataDir
      -- On mingw we avoid a "could not detect toolchain mingw"
      -- runtime error. The error originates from `findToolDir`
      -- indirectly invoked by `initGhcMonad` from `runGhc`). This
      -- line tricks `findToolDir`.
      createDirectoryIfMissing True $ dataDir ++ "/../mingw"
      cm <- runGhc (Just dataDir) $ do
              setSessionDynFlags flags
              compileToCoreSimplified file
      putStrLn $ showSDoc flags $ ppr cm
    _ -> fail "Exactly one file argument required"


-- | Create a DynFlags which is sufficiently filled in to work, but not complete
mkDynFlags :: String -> String -> IO DynFlags
mkDynFlags filename s = do
  dirs_to_clean <- newIORef Map.empty
#if defined (GHC_MASTER) || defined (GHC_921)
       -- Intentionally empty (temp file flags have moved to HscEnv).
#else
  files_to_clean <- newIORef emptyFilesToClean
#endif
  next_temp_suffix <- newIORef 0
  let baseFlags =
        (defaultDynFlags fakeSettings fakeLlvmConfig) {
          ghcLink = NoLink
#if defined (GHC_MASTER) || defined (GHC_921)
        , backend = NoBackend
#else
        , hscTarget = HscNothing
#endif
#if defined (GHC_MASTER) || defined (GHC_921)
        -- Intentionally empty (unit related flags have moved to
        -- HscEnv).
#elif defined (GHC_901)
        , unitDatabases = Just []
#else
        , pkgDatabase = Just []
#endif
#if defined (GHC_MASTER) || defined (GHC_921)
       -- Intentionally empty (temp file flags have moved to HscEnv).
#else
        , dirsToClean = dirs_to_clean
        , filesToClean = files_to_clean
        , nextTempSuffix = next_temp_suffix
#endif
#if defined(DAML_UNIT_IDS)
        , thisInstalledUnitId = toInstalledUnitId (stringToUnitId "daml-prim")
#else
#if defined (GHC_MASTER) || defined (GHC_921)
        , homeUnitId_ = toUnitId (stringToUnit "ghc-prim")
#elif defined (GHC_901)
        , homeUnitId = toUnitId (stringToUnit "ghc-prim")
#else
        , thisInstalledUnitId = toInstalledUnitId (stringToUnitId "ghc-prim")
#endif
#endif
        }
  parsePragmasIntoDynFlags filename s baseFlags
  where
    parsePragmasIntoDynFlags :: String -> String -> DynFlags -> IO DynFlags
    parsePragmasIntoDynFlags fp contents dflags0 = do
      let opts = getOptions
#if defined (GHC_MASTER)
                 (initParserOpts dflags0)
#else
                 dflags0
#endif
                 (stringToStringBuffer contents) fp
      (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
      return dflags

#if defined (GHC_MASTER)  || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
fakeLlvmConfig :: LlvmConfig
fakeLlvmConfig = LlvmConfig [] []
#else
fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
fakeLlvmConfig = ([], [])
#endif

fakeSettings :: Settings
fakeSettings = Settings
#if defined (GHC_MASTER) ||  defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
  { sGhcNameVersion=ghcNameVersion
  , sFileSettings=fileSettings
  , sTargetPlatform=platform
  , sPlatformMisc=platformMisc
#  if !defined (GHC_MASTER) && !defined (GHC_921)
  , sPlatformConstants=platformConstants
#  endif
  , sToolSettings=toolSettings
  }
#else
  { sTargetPlatform=platform
  , sPlatformConstants=platformConstants
  , sProjectVersion=cProjectVersion
  , sProgramName="ghc"
  , sOpt_P_fingerprint=fingerprint0
  , sTmpDir="."
  }
#endif
  where
#if defined (GHC_MASTER)  || defined (GHC_921) || defined (GHC_901) || defined (GHC_8101)
    fileSettings = FileSettings {
#if defined (GHC_8101)
        fileSettings_tmpDir="."
#else
#if !defined(GHC_MASTER)
        fileSettings_tmpDir=".",
#endif
       fileSettings_topDir=".",
       fileSettings_toolDir=Nothing,
       fileSettings_ghcUsagePath=".",
       fileSettings_ghciUsagePath=".",
       fileSettings_globalPackageDatabase="."
#endif
      }

    toolSettings = ToolSettings {
        toolSettings_opt_P_fingerprint=fingerprint0
      }
    platformMisc = PlatformMisc {
#if !defined (GHC_MASTER)  && !defined (GHC_921) && !defined (GHC_901)
        platformMisc_integerLibraryType=IntegerSimple
#endif
      }
    ghcNameVersion =
      GhcNameVersion{
        ghcNameVersion_programName="ghc"
      , ghcNameVersion_projectVersion=cProjectVersion
      }
#endif
    platform =
#if defined (GHC_MASTER)
      genericPlatform
#else
      Platform{
#if defined (GHC_921) || defined (GHC_901)
      -- It doesn't matter what values we write here as these fields are
      -- not referenced for our purposes. However the fields are strict
      -- so we must say something.
        platformByteOrder=LittleEndian
      , platformHasGnuNonexecStack=True
      , platformHasIdentDirective=False
      , platformHasSubsectionsViaSymbols=False
      , platformIsCrossCompiling=False
      , platformLeadingUnderscore=False
      , platformTablesNextToCode=False
#if defined(GHC_921)
      , platform_constants = Nothing
#endif
#if !defined(GHC_921) && !defined(GHC_901)
      , platformConstants=platformConstants
#endif
      ,
#endif
#if defined (GHC_921)
        platformWordSize=PW8
      , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown}
#elif defined (GHC_8101) || defined (GHC_901)
        platformWordSize=PW8
      , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown}
#else
        platformWordSize=8
      , platformOS=OSUnknown
#endif
      , platformUnregisterised=True
      }
#endif
#if !defined (GHC_MASTER) && !defined (GHC_921)
    platformConstants =
       PlatformConstants {
         pc_DYNAMIC_BY_DEFAULT=False
       ,
         pc_WORD_SIZE=8
       , pc_STD_HDR_SIZE=1
       , pc_TAG_BITS=3
       , pc_BLOCKS_PER_MBLOCK=252
       , pc_BLOCK_SIZE=4096
       , pc_MIN_PAYLOAD_SIZE=1
       , pc_MAX_Real_Vanilla_REG=6
       , pc_MAX_Vanilla_REG=10
       , pc_MAX_Real_Long_REG=0
       }
#endif
