diff --git a/compiler/haskell-ide-core/src/Development/IDE/UtilGHC.hs b/compiler/haskell-ide-core/src/Development/IDE/UtilGHC.hs index 6ddebbcf62..95e9ac0cd8 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/UtilGHC.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/UtilGHC.hs @@ -11,25 +11,35 @@ -- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have. -- -- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages. -module Development.IDE.UtilGHC(module Development.IDE.UtilGHC) where +module Development.IDE.UtilGHC( + PackageState(..), + modifyDynFlags, + textToStringBuffer, + removeTypeableInfo, + setPackageImports, + setPackageDbs, + fakeSettings, + fakeLlvmConfig, + prettyPrint, + importGenerated, + mkImport, + runGhcFast, + Development.IDE.UtilGHC.RealLocated, + modIsInternal + ) where import Config -import qualified CmdLineParser as Cmd (warnMsg) -import DynFlags (parseDynamicFilePragma) import Fingerprint import GHC hiding (convertLit) -import GHC.LanguageExtensions.Type import GhcMonad import GhcPlugins as GHC hiding (PackageState, fst3, (<>)) import HscMain import qualified Packages -import Panic (throwGhcExceptionIO) import Platform import qualified StringBuffer as SB import qualified EnumSet import Control.DeepSeq -import Control.Monad import Data.IORef import Data.List import qualified Data.Text as T @@ -38,111 +48,6 @@ import GHC.Generics (Generic) ---------------------------------------------------------------------- -- GHC setup --- | Language options enabled in the DAML-1.2 compilation -xExtensionsSet :: [Extension] -xExtensionsSet = - [ -- syntactic convenience - RecordPuns, RecordWildCards, LambdaCase, TupleSections, BlockArguments, ViewPatterns, - NumericUnderscores - -- records - , DuplicateRecordFields, DisambiguateRecordFields - -- types and kinds - , ScopedTypeVariables, ExplicitForAll - , DataKinds, KindSignatures, RankNTypes, TypeApplications - , ConstraintKinds - -- type classes - , MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances - , DefaultSignatures, StandaloneDeriving, FunctionalDependencies, DeriveFunctor - -- replacing primitives - , RebindableSyntax, OverloadedStrings - -- strictness - , Strict, StrictData - -- avoiding letrec in list comp (see DEL-3841) - , MonadComprehensions - -- package imports - , PackageImports - -- our changes - , NewColonConvention - , DamlVersionRequired - , WithRecordSyntax - , DamlTemplate - ] - - --- | Language settings _disabled_ ($-XNo...$) in the DAML-1.2 compilation -xExtensionsUnset :: [Extension] -xExtensionsUnset = [ ] - --- | Flags set for DAML-1.2 compilation -xFlagsSet :: [ GeneralFlag ] -xFlagsSet = [ - Opt_Haddock - , Opt_Ticky - ] - --- | Warning options set for DAML compilation. Note that these can be modified --- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and --- '{-# OPTIONS -no-warn-... #-}'. -wOptsSet :: [ WarningFlag ] -wOptsSet = - [ Opt_WarnUnusedImports - , Opt_WarnPrepositiveQualifiedModule - , Opt_WarnOverlappingPatterns - , Opt_WarnIncompletePatterns - ] - --- | Warning options set for DAML compilation, which become errors. -wOptsSetFatal :: [ WarningFlag ] -wOptsSetFatal = - [ Opt_WarnMissingFields - ] - --- | Warning options unset for DAML compilation. Note that these can be modified --- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and --- '{-# OPTIONS -no-warn-... #-}'. -wOptsUnset :: [ WarningFlag ] -wOptsUnset = - [ Opt_WarnMissingMonadFailInstances -- failable pattern plus RebindableSyntax raises this error - , Opt_WarnOverflowedLiterals -- this does not play well with -ticky and the error message is misleading - ] - - -adjustDynFlags :: [FilePath] -> PackageState -> Maybe String -> DynFlags -> DynFlags -adjustDynFlags paths packageState mbPackageName dflags - = setImports paths - $ setPackageState packageState - $ setThisInstalledUnitId (maybe mainUnitId stringToUnitId mbPackageName) - -- once we have package imports working, we want to import the base package and set this to - -- the default instead of always compiling in the context of ghc-prim. - $ apply wopt_set wOptsSet - $ apply wopt_unset wOptsUnset - $ apply wopt_set_fatal wOptsSetFatal - $ apply xopt_set xExtensionsSet - $ apply xopt_unset xExtensionsUnset - $ apply gopt_set xFlagsSet - dflags{ - mainModIs = mkModule primUnitId (mkModuleName "NotAnExistingName"), -- avoid DEL-6770 - debugLevel = 1, - ghcLink = NoLink, hscTarget = HscNothing -- avoid generating .o or .hi files - {-, dumpFlags = Opt_D_ppr_debug `EnumSet.insert` dumpFlags dflags -- turn on debug output from GHC-} - } - where apply f xs d = foldl' f d xs - -setThisInstalledUnitId :: UnitId -> DynFlags -> DynFlags -setThisInstalledUnitId unitId dflags = - dflags {thisInstalledUnitId = toInstalledUnitId unitId} - -setImports :: [FilePath] -> DynFlags -> DynFlags -setImports paths dflags = dflags { importPaths = paths } - -setPackageState :: PackageState -> DynFlags -> DynFlags -setPackageState state dflags = - dflags - { pkgDatabase = pkgStateDb state - , pkgState = pkgStateState state - , thisUnitIdInsts_ = pkgThisUnitIdInsts state - } - setPackageDbs :: [FilePath] -> DynFlags -> DynFlags setPackageDbs paths dflags = dflags @@ -185,31 +90,6 @@ data PackageState = PackageState instance NFData PackageState where rnf (PackageState db state insts) = db `seq` state `seq` rnf insts --- | Configures the @DynFlags@ for this session to DAML-1.2 --- compilation: --- * Installs a custom log action; --- * Sets up the package databases; --- * Sets the import paths to the given list of 'FilePath'. --- * if present, parses and applies custom options for GHC --- (may fail if the custom options are inconsistent with std DAML ones) -setupDamlGHC :: GhcMonad m => [FilePath] -> Maybe String -> PackageState -> [String] -> m () -setupDamlGHC importPaths mbPackageName packageState [] = - modifyDynFlags $ adjustDynFlags importPaths packageState mbPackageName --- if custom options are given, add them after the standard DAML flag setup -setupDamlGHC importPaths mbPackageName packageState customOpts = do - setupDamlGHC importPaths mbPackageName packageState [] - damlDFlags <- getSessionDynFlags - (dflags', leftover, warns) <- parseDynamicFilePragma damlDFlags $ map noLoc customOpts - - let leftoverError = CmdLineError $ - (unlines . ("Unable to parse custom flags:":) . map unLoc) leftover - unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError - - unless (null warns) $ - liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . Cmd.warnMsg) warns - - modifySession $ \h -> - h { hsc_dflags = dflags', hsc_IC = (hsc_IC h) {ic_dflags = dflags' } } -- | A version of `showSDoc` that uses default flags (to avoid uses of -- `showSDocUnsafe`). diff --git a/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Config.hs b/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Config.hs new file mode 100644 index 0000000000..4ff3cb4a74 --- /dev/null +++ b/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Config.hs @@ -0,0 +1,156 @@ +-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Set up the GHC monad in a way that works for us +module DA.Daml.GHC.Compiler.Config(setupDamlGHC) where + +import Development.IDE.UtilGHC +import qualified CmdLineParser as Cmd (warnMsg) +import DynFlags (parseDynamicFilePragma) +import GHC hiding (convertLit) +import GHC.LanguageExtensions.Type +import GhcMonad +import GhcPlugins as GHC hiding (PackageState, fst3, (<>)) +import Panic (throwGhcExceptionIO) + +import Control.Monad +import Data.List + +---------------------------------------------------------------------- +-- GHC setup + +-- | Language options enabled in the DAML-1.2 compilation +xExtensionsSet :: [Extension] +xExtensionsSet = + [ -- syntactic convenience + RecordPuns, RecordWildCards, LambdaCase, TupleSections, BlockArguments, ViewPatterns, + NumericUnderscores + -- records + , DuplicateRecordFields, DisambiguateRecordFields + -- types and kinds + , ScopedTypeVariables, ExplicitForAll + , DataKinds, KindSignatures, RankNTypes, TypeApplications + , ConstraintKinds + -- type classes + , MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances + , DefaultSignatures, StandaloneDeriving, FunctionalDependencies, DeriveFunctor + -- replacing primitives + , RebindableSyntax, OverloadedStrings + -- strictness + , Strict, StrictData + -- avoiding letrec in list comp (see DEL-3841) + , MonadComprehensions + -- package imports + , PackageImports + -- our changes + , NewColonConvention + , DamlVersionRequired + , WithRecordSyntax + , DamlTemplate + ] + + +-- | Language settings _disabled_ ($-XNo...$) in the DAML-1.2 compilation +xExtensionsUnset :: [Extension] +xExtensionsUnset = [ ] + +-- | Flags set for DAML-1.2 compilation +xFlagsSet :: [ GeneralFlag ] +xFlagsSet = [ + Opt_Haddock + , Opt_Ticky + ] + +-- | Warning options set for DAML compilation. Note that these can be modified +-- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and +-- '{-# OPTIONS -no-warn-... #-}'. +wOptsSet :: [ WarningFlag ] +wOptsSet = + [ Opt_WarnUnusedImports + , Opt_WarnPrepositiveQualifiedModule + , Opt_WarnOverlappingPatterns + , Opt_WarnIncompletePatterns + ] + +-- | Warning options set for DAML compilation, which become errors. +wOptsSetFatal :: [ WarningFlag ] +wOptsSetFatal = + [ Opt_WarnMissingFields + ] + +-- | Warning options unset for DAML compilation. Note that these can be modified +-- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and +-- '{-# OPTIONS -no-warn-... #-}'. +wOptsUnset :: [ WarningFlag ] +wOptsUnset = + [ Opt_WarnMissingMonadFailInstances -- failable pattern plus RebindableSyntax raises this error + , Opt_WarnOverflowedLiterals -- this does not play well with -ticky and the error message is misleading + ] + + +adjustDynFlags :: [FilePath] -> PackageState -> Maybe String -> DynFlags -> DynFlags +adjustDynFlags paths packageState mbPackageName dflags + = setImports paths + $ setPackageState packageState + $ setThisInstalledUnitId (maybe mainUnitId stringToUnitId mbPackageName) + -- once we have package imports working, we want to import the base package and set this to + -- the default instead of always compiling in the context of ghc-prim. + $ apply wopt_set wOptsSet + $ apply wopt_unset wOptsUnset + $ apply wopt_set_fatal wOptsSetFatal + $ apply xopt_set xExtensionsSet + $ apply xopt_unset xExtensionsUnset + $ apply gopt_set xFlagsSet + dflags{ + mainModIs = mkModule primUnitId (mkModuleName "NotAnExistingName"), -- avoid DEL-6770 + debugLevel = 1, + ghcLink = NoLink, hscTarget = HscNothing -- avoid generating .o or .hi files + {-, dumpFlags = Opt_D_ppr_debug `EnumSet.insert` dumpFlags dflags -- turn on debug output from GHC-} + } + where apply f xs d = foldl' f d xs + +setThisInstalledUnitId :: UnitId -> DynFlags -> DynFlags +setThisInstalledUnitId unitId dflags = + dflags {thisInstalledUnitId = toInstalledUnitId unitId} + +setImports :: [FilePath] -> DynFlags -> DynFlags +setImports paths dflags = dflags { importPaths = paths } + +setPackageState :: PackageState -> DynFlags -> DynFlags +setPackageState state dflags = + dflags + { pkgDatabase = pkgStateDb state + , pkgState = pkgStateState state + , thisUnitIdInsts_ = pkgThisUnitIdInsts state + } + +-- | Configures the @DynFlags@ for this session to DAML-1.2 +-- compilation: +-- * Installs a custom log action; +-- * Sets up the package databases; +-- * Sets the import paths to the given list of 'FilePath'. +-- * if present, parses and applies custom options for GHC +-- (may fail if the custom options are inconsistent with std DAML ones) +setupDamlGHC :: GhcMonad m => [FilePath] -> Maybe String -> PackageState -> [String] -> m () +setupDamlGHC importPaths mbPackageName packageState [] = + modifyDynFlags $ adjustDynFlags importPaths packageState mbPackageName +-- if custom options are given, add them after the standard DAML flag setup +setupDamlGHC importPaths mbPackageName packageState customOpts = do + setupDamlGHC importPaths mbPackageName packageState [] + damlDFlags <- getSessionDynFlags + (dflags', leftover, warns) <- parseDynamicFilePragma damlDFlags $ map noLoc customOpts + + let leftoverError = CmdLineError $ + (unlines . ("Unable to parse custom flags:":) . map unLoc) leftover + unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError + + unless (null warns) $ + liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . Cmd.warnMsg) warns + + modifySession $ \h -> + h { hsc_dflags = dflags', hsc_IC = (hsc_IC h) {ic_dflags = dflags' } } diff --git a/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Options.hs b/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Options.hs index 794231adde..c3b512a694 100644 --- a/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Options.hs +++ b/daml-foundations/daml-ghc/src/DA/Daml/GHC/Compiler/Options.hs @@ -13,7 +13,8 @@ module DA.Daml.GHC.Compiler.Options ) where -import Development.IDE.UtilGHC (runGhcFast, setupDamlGHC) +import Development.IDE.UtilGHC (runGhcFast) +import DA.Daml.GHC.Compiler.Config (setupDamlGHC) import qualified Development.IDE.Functions.Compile as Compile import DA.Bazel.Runfiles