module Mikan.TypeChecking.Monad.Options where
import Prelude hiding (null, (||), not)
import Control.Monad ( unless, when )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Graph qualified as Graph
import Data.List (sort)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set qualified as Set
import System.Directory
import System.FilePath
import Mikan.Syntax.Common
import Mikan.Syntax.TopLevelModuleName
import Mikan.TypeChecking.Monad.Debug (reportSDoc, reportS)
import Mikan.TypeChecking.Warnings
import Mikan.TypeChecking.Monad.Base
import Mikan.TypeChecking.Monad.Imports
import Mikan.TypeChecking.Monad.State
import Mikan.TypeChecking.Monad.Benchmark
import Mikan.TypeChecking.Monad.Diagnostic
import Mikan.TypeChecking.Monad.Trace
import Mikan.Interaction.FindFile
import Mikan.Interaction.Options hiding (setPragmaOptions)
import Mikan.Interaction.Options.Lenses qualified as Lens
import Mikan.Interaction.Library
import Mikan.Interaction.Library.Base (LibCache(LibCache), libAbove, libFile, runLibM)
import Mikan.Utils.Boolean
import Mikan.Utils.FileName
import Mikan.Utils.Graph.AdjacencyMap.Unidirectional qualified as G
import Mikan.Utils.Lens
import Mikan.Utils.List
import Mikan.Utils.List1 (List1)
import Mikan.Utils.List1 qualified as List1
import Mikan.Utils.Maybe (isJust, fromMaybe)
import Mikan.Utils.Null
import Mikan.Syntax.Common.Pretty
import Mikan.Utils.Size
import Mikan.Utils.WithDefault
import Mikan.Utils.Impossible
setPragmaOptions :: PragmaOptions -> TCM ()
setPragmaOptions :: PragmaOptions -> TCM ()
setPragmaOptions PragmaOptions
opts = do
Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PragmaOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode PragmaOptions
opts) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$
[FilePath] -> ([FilePath] -> TCM ()) -> TCM ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull (PragmaOptions -> [FilePath]
unsafePragmaOptions PragmaOptions
opts) (([FilePath] -> TCM ()) -> TCM ())
-> ([FilePath] -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \ [FilePath]
unsafe ->
Warning -> TCM ()
forall (m :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
e -> m ()
warning (Warning -> TCM ()) -> Warning -> TCM ()
forall a b. (a -> b) -> a -> b
$ Set FilePath -> Warning
SafeFlagPragma (Set FilePath -> Warning) -> Set FilePath -> Warning
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
unsafe
(PragmaOptions -> Identity PragmaOptions)
-> TCState -> Identity TCState
Lens' TCState PragmaOptions
stPragmaOptions ((PragmaOptions -> Identity PragmaOptions)
-> TCState -> Identity TCState)
-> PragmaOptions -> TCM ()
forall (m :: * -> *) a.
MonadTCState m =>
ASetter' TCState a -> a -> m ()
`setTCLens` PragmaOptions
opts
TCM ()
updateBenchmarkingStatus
checkPragmaOptionConsistency :: PragmaOptions -> PragmaOptions -> TCM ()
checkPragmaOptionConsistency :: PragmaOptions -> PragmaOptions -> TCM ()
checkPragmaOptionConsistency PragmaOptions
oldOpts PragmaOptions
newOpts = do
(ImpliedPragmaOption -> TCM ()) -> [ImpliedPragmaOption] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ImpliedPragmaOption -> TCM ()
check [ImpliedPragmaOption]
impliedPragmaOptions
where
check :: ImpliedPragmaOption -> TCM ()
check (ImpliesPragmaOption FilePath
nameA Bool
valA PragmaOptions -> WithDefault a
flagA FilePath
nameB Bool
valB PragmaOptions -> WithDefault b
flagB)
| PragmaOptions -> WithDefault a
flagA PragmaOptions
newOpts WithDefault a -> WithDefault a -> Bool
forall a. Eq a => a -> a -> Bool
== PragmaOptions -> WithDefault a
flagA PragmaOptions
oldOpts
, PragmaOptions -> WithDefault b
flagB PragmaOptions
newOpts WithDefault b -> WithDefault b -> Bool
forall a. Eq a => a -> a -> Bool
== PragmaOptions -> WithDefault b
flagB PragmaOptions
oldOpts = () -> TCM ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Value Bool
vA <- PragmaOptions -> WithDefault a
flagA PragmaOptions
newOpts, Bool
vA Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
valA
, Value Bool
vB <- PragmaOptions -> WithDefault b
flagB PragmaOptions
newOpts, Bool
vB Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
valB = Warning -> TCM ()
forall (m :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
e -> m ()
warning (Warning -> TCM ()) -> Warning -> TCM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Warning
ConflictingPragmaOptions (FilePath
nameA FilePath -> Bool -> FilePath
.= Bool
valA) (FilePath
nameB FilePath -> Bool -> FilePath
.= Bool
valB)
| Bool
otherwise = () -> TCM ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
FilePath
name .= :: FilePath -> Bool -> FilePath
.= Bool
True = FilePath
name
FilePath
name .= Bool
False = FilePath
"no-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
setCommandLineOptions :: CommandLineOptions -> TCM ()
setCommandLineOptions :: CommandLineOptions -> TCM ()
setCommandLineOptions CommandLineOptions
opts = do
root <- case CommandLineOptions -> [AbsolutePath]
optAbsoluteIncludePaths CommandLineOptions
opts of
[] -> AbsolutePath -> Maybe AbsolutePath
forall a. a -> Maybe a
Just (AbsolutePath -> Maybe AbsolutePath)
-> TCMT IO AbsolutePath -> TCMT IO (Maybe AbsolutePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO AbsolutePath -> TCMT IO AbsolutePath
forall a. IO a -> TCMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO AbsolutePath
absolute (FilePath -> IO AbsolutePath) -> IO FilePath -> IO AbsolutePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getCurrentDirectory)
[AbsolutePath]
_ -> Maybe AbsolutePath -> TCMT IO (Maybe AbsolutePath)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AbsolutePath
forall a. Maybe a
Nothing
setCommandLineOptions' root opts
setCommandLineOptions'
:: Maybe AbsolutePath
-> CommandLineOptions
-> TCM ()
setCommandLineOptions' :: Maybe AbsolutePath -> CommandLineOptions -> TCM ()
setCommandLineOptions' Maybe AbsolutePath
mroot CommandLineOptions
opts = do
(TCState -> TCState) -> TCM ()
forall (m :: * -> *).
MonadTCState m =>
(TCState -> TCState) -> m ()
modifyTC ((TCState -> TCState) -> TCM ()) -> (TCState -> TCState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (CommandLineOptions -> CommandLineOptions) -> TCState -> TCState
forall a.
LensCommandLineOptions a =>
(CommandLineOptions -> CommandLineOptions) -> a -> a
Lens.mapCommandLineOptions \ CommandLineOptions
o -> CommandLineOptions
o{ optDiagnosticsColour = optDiagnosticsColour opts }
incs <- case CommandLineOptions -> [AbsolutePath]
optAbsoluteIncludePaths CommandLineOptions
opts of
[] -> do
let !root :: AbsolutePath
root = AbsolutePath -> Maybe AbsolutePath -> AbsolutePath
forall a. a -> Maybe a -> a
fromMaybe AbsolutePath
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe AbsolutePath
mroot
opts' <- AbsolutePath -> CommandLineOptions -> TCM CommandLineOptions
setLibraryPaths AbsolutePath
root CommandLineOptions
opts
let incs = CommandLineOptions -> [FilePath]
optIncludePaths CommandLineOptions
opts'
setIncludeDirs incs root
List1.toList <$> getIncludeDirs
[AbsolutePath]
incs -> [AbsolutePath] -> TCMT IO [AbsolutePath]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [AbsolutePath]
incs
modifyTC $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs }
setPragmaOptions (optPragmaOptions opts)
libToTCM :: LibM a -> TCM a
libToTCM :: forall a. LibM a -> TCM a
libToTCM LibM a
m = do
(z, warns) <- Lens' SessionState LibState
-> (LibState
-> TCMT IO ((Either LibErrors a, [LibWarning]), LibState))
-> TCMT IO (Either LibErrors a, [LibWarning])
forall a r.
Lens' SessionState a -> (a -> TCMT IO (r, a)) -> TCMT IO r
forall (m :: * -> *) a r.
ModifySession m =>
Lens' SessionState a -> (a -> m (r, a)) -> m r
stateSessionLensM (LibState -> f LibState) -> SessionState -> f SessionState
Lens' SessionState LibState
lensLibCache \LibState
cache -> do
IO ((Either LibErrors a, [LibWarning]), LibState)
-> TCMT IO ((Either LibErrors a, [LibWarning]), LibState)
forall a. IO a -> TCMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((Either LibErrors a, [LibWarning]), LibState)
-> TCMT IO ((Either LibErrors a, [LibWarning]), LibState))
-> IO ((Either LibErrors a, [LibWarning]), LibState)
-> TCMT IO ((Either LibErrors a, [LibWarning]), LibState)
forall a b. (a -> b) -> a -> b
$ LibM a
-> LibState -> IO ((Either LibErrors a, [LibWarning]), LibState)
forall a.
LibM a
-> LibState -> IO ((Either LibErrors a, [LibWarning]), LibState)
runLibM LibM a
m LibState
cache
List1.unlessNull warns \ List1 LibWarning
warns -> List1 (Ranged SomeDiagnostic) -> TCM ()
forall (m :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
List1 (Ranged e) -> m ()
warnings (List1 (Ranged SomeDiagnostic) -> TCM ())
-> List1 (Ranged SomeDiagnostic) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (LibWarning -> Ranged SomeDiagnostic)
-> List1 LibWarning -> List1 (Ranged SomeDiagnostic)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LibWarning -> SomeDiagnostic)
-> Ranged LibWarning -> Ranged SomeDiagnostic
forall a b. (a -> b) -> Ranged a -> Ranged b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Warning -> SomeDiagnostic
forall a. Diagnostic a => a -> SomeDiagnostic
toSomeDiagnostic (Warning -> SomeDiagnostic)
-> (LibWarning -> Warning) -> LibWarning -> SomeDiagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibWarning -> Warning
LibraryWarning) (Ranged LibWarning -> Ranged SomeDiagnostic)
-> (LibWarning -> Ranged LibWarning)
-> LibWarning
-> Ranged SomeDiagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibWarning -> Ranged LibWarning
forall a. a -> Ranged a
unranged) List1 LibWarning
warns
case z of
Left LibErrors
s -> TypeError -> TCMT IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCMT IO a) -> TypeError -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ LibErrors -> TypeError
LibraryError LibErrors
s
Right a
x -> a -> TCMT IO a
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
getAgdaLibFiles
:: AbsolutePath
-> TopLevelModuleName
-> TCM [AgdaLibFile]
getAgdaLibFiles :: AbsolutePath -> TopLevelModuleName -> TCM [AgdaLibFile]
getAgdaLibFiles AbsolutePath
f TopLevelModuleName
m = do
ls <- AbsolutePath -> TCM [AgdaLibFile]
getAgdaLibFilesWithoutTopLevelModuleName AbsolutePath
f
mapM_ (checkLibraryFileNotTooFarDown m) ls
return ls
getAgdaLibFilesWithoutTopLevelModuleName
:: AbsolutePath
-> TCM [AgdaLibFile]
getAgdaLibFilesWithoutTopLevelModuleName :: AbsolutePath -> TCM [AgdaLibFile]
getAgdaLibFilesWithoutTopLevelModuleName AbsolutePath
f = do
useLibs <- CommandLineOptions -> Bool
optUseLibs (CommandLineOptions -> Bool)
-> TCM CommandLineOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions
if | useLibs -> libToTCM $ getAgdaLibFile root
| otherwise -> return []
where
root :: FilePath
root = FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> FilePath
filePath AbsolutePath
f
checkLibraryFileNotTooFarDown ::
TopLevelModuleName ->
AgdaLibFile ->
TCM ()
checkLibraryFileNotTooFarDown :: TopLevelModuleName -> AgdaLibFile -> TCM ()
checkLibraryFileNotTooFarDown TopLevelModuleName
m AgdaLibFile
lib =
Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AgdaLibFile
lib AgdaLibFile -> Getting Int AgdaLibFile Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AgdaLibFile Int
Lens' AgdaLibFile Int
libAbove Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TopLevelModuleName -> Int
forall a. Sized a => a -> Int
size TopLevelModuleName
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCM ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> AgdaLibFile -> TypeError
LibTooFarDown TopLevelModuleName
m AgdaLibFile
lib
getLibraryOptions
:: AbsolutePath
-> TopLevelModuleName
-> TCM [OptionsPragma]
getLibraryOptions :: AbsolutePath -> TopLevelModuleName -> TCM [OptionsPragma]
getLibraryOptions AbsolutePath
f TopLevelModuleName
m = (AgdaLibFile -> OptionsPragma) -> [AgdaLibFile] -> [OptionsPragma]
forall a b. (a -> b) -> [a] -> [b]
map AgdaLibFile -> OptionsPragma
_libPragmas ([AgdaLibFile] -> [OptionsPragma])
-> TCM [AgdaLibFile] -> TCM [OptionsPragma]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsolutePath -> TopLevelModuleName -> TCM [AgdaLibFile]
getAgdaLibFiles AbsolutePath
f TopLevelModuleName
m
setLibraryPaths
:: AbsolutePath
-> CommandLineOptions
-> TCM CommandLineOptions
setLibraryPaths :: AbsolutePath -> CommandLineOptions -> TCM CommandLineOptions
setLibraryPaths AbsolutePath
root CommandLineOptions
o =
CommandLineOptions -> TCM CommandLineOptions
setLibraryIncludes (CommandLineOptions -> TCM CommandLineOptions)
-> TCM CommandLineOptions -> TCM CommandLineOptions
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AbsolutePath -> CommandLineOptions -> TCM CommandLineOptions
addDefaultLibraries AbsolutePath
root CommandLineOptions
o
setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions
setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions
setLibraryIncludes CommandLineOptions
o
| Bool -> Bool
forall a. Boolean a => a -> a
not (CommandLineOptions -> Bool
optUseLibs CommandLineOptions
o) = CommandLineOptions -> TCM CommandLineOptions
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions
o
| Bool
otherwise = do
let libs :: [LibName]
libs = CommandLineOptions -> [LibName]
optLibraries CommandLineOptions
o
installed <- LibM [AgdaLibFile] -> TCM [AgdaLibFile]
forall a. LibM a -> TCM a
libToTCM (LibM [AgdaLibFile] -> TCM [AgdaLibFile])
-> LibM [AgdaLibFile] -> TCM [AgdaLibFile]
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> LibM [AgdaLibFile]
getInstalledLibraries (CommandLineOptions -> Maybe FilePath
optOverrideLibrariesFile CommandLineOptions
o)
paths <- libToTCM $ libraryIncludePaths (optOverrideLibrariesFile o) installed libs
return o{ optIncludePaths = paths ++ optIncludePaths o }
addDefaultLibraries
:: AbsolutePath
-> CommandLineOptions
-> TCM CommandLineOptions
addDefaultLibraries :: AbsolutePath -> CommandLineOptions -> TCM CommandLineOptions
addDefaultLibraries AbsolutePath
root CommandLineOptions
o
| Bool -> Bool
forall a. Boolean a => a -> a
not ([LibName] -> Bool
forall a. Null a => a -> Bool
null ([LibName] -> Bool) -> [LibName] -> Bool
forall a b. (a -> b) -> a -> b
$ CommandLineOptions -> [LibName]
optLibraries CommandLineOptions
o) Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Bool -> Bool
forall a. Boolean a => a -> a
not (CommandLineOptions -> Bool
optUseLibs CommandLineOptions
o) = CommandLineOptions -> TCM CommandLineOptions
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions
o
| Bool
otherwise = do
(libs, incs) <- LibM ([LibName], [FilePath]) -> TCM ([LibName], [FilePath])
forall a. LibM a -> TCM a
libToTCM (LibM ([LibName], [FilePath]) -> TCM ([LibName], [FilePath]))
-> LibM ([LibName], [FilePath]) -> TCM ([LibName], [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> Bool -> LibM ([LibName], [FilePath])
getDefaultLibraries (AbsolutePath -> FilePath
filePath AbsolutePath
root) (CommandLineOptions -> Maybe FilePath
optOverrideDefaultsFile CommandLineOptions
o) (CommandLineOptions -> Bool
optDefaultLibs CommandLineOptions
o)
return o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs }
addTrustedExecutables
:: CommandLineOptions
-> TCM CommandLineOptions
addTrustedExecutables :: CommandLineOptions -> TCM CommandLineOptions
addTrustedExecutables CommandLineOptions
o = do
trustedExes <- LibM (Map ExeName FilePath) -> TCM (Map ExeName FilePath)
forall a. LibM a -> TCM a
libToTCM (LibM (Map ExeName FilePath) -> TCM (Map ExeName FilePath))
-> LibM (Map ExeName FilePath) -> TCM (Map ExeName FilePath)
forall a b. (a -> b) -> a -> b
$ LibM (Map ExeName FilePath)
getTrustedExecutables
return o{ optTrustedExecutables = trustedExes }
setOptionsFromPragma :: OptionsPragma -> TCM ()
setOptionsFromPragma :: OptionsPragma -> TCM ()
setOptionsFromPragma = Bool -> OptionsPragma -> TCM ()
setOptionsFromPragma' Bool
False
checkAndSetOptionsFromPragma :: OptionsPragma -> TCM ()
checkAndSetOptionsFromPragma :: OptionsPragma -> TCM ()
checkAndSetOptionsFromPragma = Bool -> OptionsPragma -> TCM ()
setOptionsFromPragma' Bool
True
setOptionsFromPragma' :: Bool -> OptionsPragma -> TCM ()
setOptionsFromPragma' :: Bool -> OptionsPragma -> TCM ()
setOptionsFromPragma' Bool
checkConsistency OptionsPragma
ps = Range -> TCM () -> TCM ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange (OptionsPragma -> Range
pragmaRange OptionsPragma
ps) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
opts <- TCM CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions
let (z, warns) = runOptM (parsePragmaOptions ps opts)
mapM_ (warning . OptionWarning) warns
case z of
Left FilePath
err -> TypeError -> TCM ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> TypeError
OptionError FilePath
err
Right PragmaOptions
opts' -> do
Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkConsistency (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
oldOpts <- TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
checkPragmaOptionConsistency oldOpts opts'
PragmaOptions -> TCM ()
setPragmaOptions PragmaOptions
opts'
enableDisplayForms :: MonadTCEnv m => m a -> m a
enableDisplayForms :: forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
enableDisplayForms = (TCEnv -> TCEnv) -> m a -> m a
forall a. (TCEnv -> TCEnv) -> m a -> m a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC (ASetter TCEnv TCEnv Bool Bool -> Bool -> TCEnv -> TCEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter TCEnv TCEnv Bool Bool
Lens' TCEnv Bool
eDisplayFormsEnabled Bool
True)
disableDisplayForms :: MonadTCEnv m => m a -> m a
disableDisplayForms :: forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
disableDisplayForms = (TCEnv -> TCEnv) -> m a -> m a
forall a. (TCEnv -> TCEnv) -> m a -> m a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC (ASetter TCEnv TCEnv Bool Bool -> Bool -> TCEnv -> TCEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter TCEnv TCEnv Bool Bool
Lens' TCEnv Bool
eDisplayFormsEnabled Bool
False)
displayFormsEnabled :: MonadTCEnv m => m Bool
displayFormsEnabled :: forall (m :: * -> *). MonadTCEnv m => m Bool
displayFormsEnabled = Lens' TCEnv Bool -> m Bool
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' TCEnv Bool
eDisplayFormsEnabled
getIncludeDirs :: TCM (List1 AbsolutePath)
getIncludeDirs :: TCMT IO (NonEmpty AbsolutePath)
getIncludeDirs = do
NonEmpty AbsolutePath -> [AbsolutePath] -> NonEmpty AbsolutePath
forall a. List1 a -> [a] -> List1 a
List1.fromListSafe NonEmpty AbsolutePath
forall a. HasCallStack => a
__IMPOSSIBLE__ ([AbsolutePath] -> NonEmpty AbsolutePath)
-> (CommandLineOptions -> [AbsolutePath])
-> CommandLineOptions
-> NonEmpty AbsolutePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOptions -> [AbsolutePath]
optAbsoluteIncludePaths (CommandLineOptions -> NonEmpty AbsolutePath)
-> TCM CommandLineOptions -> TCMT IO (NonEmpty AbsolutePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions
setIncludeDirs :: [FilePath]
-> AbsolutePath
-> TCM ()
setIncludeDirs :: [FilePath] -> AbsolutePath -> TCM ()
setIncludeDirs [FilePath]
incs AbsolutePath
root = do
oldIncs <- (TCState -> [AbsolutePath]) -> TCMT IO [AbsolutePath]
forall (m :: * -> *) a. ReadTCState m => (TCState -> a) -> m a
getsTC TCState -> [AbsolutePath]
forall a. LensIncludePaths a => a -> [AbsolutePath]
Lens.getAbsoluteIncludePaths
incs <- return $ List1.fromListSafe (List1.singleton ".") incs
incs <- return $ fmap (mkAbsolute . (filePath root </>)) incs
primdir <- useSession lensPrimitiveLibDir
incs <- return $ List1.fromListSafe __IMPOSSIBLE__ $ nubOn id $ List1.toList $ incs <> List1.singleton primdir
reportS "setIncludeDirs" 10 $ vcat
[ "Old include directories:"
, nest 2 $ vcat $ map pretty oldIncs
, "New include directories:"
, nest 2 $ vcat $ fmap pretty incs
]
when (sort oldIncs /= sort (List1.toList incs)) $ do
tcWarnings <- useTC stTCWarnings
decodedModules <- getDecodedModules
(keptDecodedModules, modFile) <- modulesToKeep incs decodedModules
resetAllState
setTCLens stTCWarnings tcWarnings
setDecodedModules keptDecodedModules
setSession lensModuleToSourceId modFile
Lens.putAbsoluteIncludePaths $ List1.toList incs
where
modulesToKeep
:: List1 AbsolutePath
-> DecodedModules
-> TCM (DecodedModules, ModuleToSourceId)
modulesToKeep :: NonEmpty AbsolutePath
-> DecodedModules -> TCM (DecodedModules, ModuleToSourceId)
modulesToKeep NonEmpty AbsolutePath
incs DecodedModules
old = DecodedModules
-> ModuleToSourceId
-> [ModuleInfo]
-> TCM (DecodedModules, ModuleToSourceId)
process DecodedModules
forall k a. Map k a
Map.empty ModuleToSourceId
forall k a. Map k a
Map.empty [ModuleInfo]
modules
where
dependencyGraph :: G.Graph TopLevelModuleName ()
dependencyGraph :: Graph TopLevelModuleName ()
dependencyGraph =
[TopLevelModuleName] -> Graph TopLevelModuleName ()
forall n e. Ord n => [n] -> Graph n e
G.fromNodes
[ Interface -> TopLevelModuleName
iTopLevelModuleName (Interface -> TopLevelModuleName)
-> Interface -> TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
m
| ModuleInfo
m <- DecodedModules -> [ModuleInfo]
forall k a. Map k a -> [a]
Map.elems DecodedModules
old
]
Graph TopLevelModuleName ()
-> Graph TopLevelModuleName () -> Graph TopLevelModuleName ()
forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
`G.union`
[Edge TopLevelModuleName ()] -> Graph TopLevelModuleName ()
forall n e. Ord n => [Edge n e] -> Graph n e
G.fromEdges
[ G.Edge
{ source :: TopLevelModuleName
source = Interface -> TopLevelModuleName
iTopLevelModuleName (Interface -> TopLevelModuleName)
-> Interface -> TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
m
, target :: TopLevelModuleName
target = TopLevelModuleName
d
, label :: ()
label = ()
}
| ModuleInfo
m <- DecodedModules -> [ModuleInfo]
forall k a. Map k a -> [a]
Map.elems DecodedModules
old
, (TopLevelModuleName
d, Hash
_) <- Interface -> [(TopLevelModuleName, Hash)]
iImportedModules (Interface -> [(TopLevelModuleName, Hash)])
-> Interface -> [(TopLevelModuleName, Hash)]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
m
]
modules :: [ModuleInfo]
modules :: [ModuleInfo]
modules =
(SCC TopLevelModuleName -> ModuleInfo)
-> [SCC TopLevelModuleName] -> [ModuleInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\case
Graph.CyclicSCC{} ->
ModuleInfo
forall a. HasCallStack => a
__IMPOSSIBLE__
Graph.AcyclicSCC TopLevelModuleName
m ->
case TopLevelModuleName -> DecodedModules -> Maybe ModuleInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TopLevelModuleName
m DecodedModules
old of
Just ModuleInfo
m -> ModuleInfo
m
Maybe ModuleInfo
Nothing -> ModuleInfo
forall a. HasCallStack => a
__IMPOSSIBLE__) ([SCC TopLevelModuleName] -> [ModuleInfo])
-> [SCC TopLevelModuleName] -> [ModuleInfo]
forall a b. (a -> b) -> a -> b
$
Graph TopLevelModuleName () -> [SCC TopLevelModuleName]
forall n e. Ord n => Graph n e -> [SCC n]
G.sccs' Graph TopLevelModuleName ()
dependencyGraph
process ::
Map TopLevelModuleName ModuleInfo -> ModuleToSourceId ->
[ModuleInfo] -> TCM (DecodedModules, ModuleToSourceId)
process :: DecodedModules
-> ModuleToSourceId
-> [ModuleInfo]
-> TCM (DecodedModules, ModuleToSourceId)
process !DecodedModules
keep !ModuleToSourceId
modFile [] = (DecodedModules, ModuleToSourceId)
-> TCM (DecodedModules, ModuleToSourceId)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
( [(TopLevelModuleName, ModuleInfo)] -> DecodedModules
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TopLevelModuleName, ModuleInfo)] -> DecodedModules)
-> [(TopLevelModuleName, ModuleInfo)] -> DecodedModules
forall a b. (a -> b) -> a -> b
$
DecodedModules -> [(TopLevelModuleName, ModuleInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList DecodedModules
keep
, ModuleToSourceId
modFile
)
process DecodedModules
keep ModuleToSourceId
modFile (ModuleInfo
m : [ModuleInfo]
ms) = do
let deps :: [TopLevelModuleName]
deps = ((TopLevelModuleName, Hash) -> TopLevelModuleName)
-> [(TopLevelModuleName, Hash)] -> [TopLevelModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (TopLevelModuleName, Hash) -> TopLevelModuleName
forall a b. (a, b) -> a
fst ([(TopLevelModuleName, Hash)] -> [TopLevelModuleName])
-> [(TopLevelModuleName, Hash)] -> [TopLevelModuleName]
forall a b. (a -> b) -> a -> b
$ Interface -> [(TopLevelModuleName, Hash)]
iImportedModules (Interface -> [(TopLevelModuleName, Hash)])
-> Interface -> [(TopLevelModuleName, Hash)]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
m
depsKept :: Bool
depsKept = (TopLevelModuleName -> Bool) -> [TopLevelModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TopLevelModuleName -> DecodedModules -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` DecodedModules
keep) [TopLevelModuleName]
deps
(keep, modFile) <-
if Bool -> Bool
forall a. Boolean a => a -> a
not Bool
depsKept then (DecodedModules, ModuleToSourceId)
-> TCM (DecodedModules, ModuleToSourceId)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodedModules
keep, ModuleToSourceId
modFile) else do
let t :: TopLevelModuleName
t = Interface -> TopLevelModuleName
iTopLevelModuleName (Interface -> TopLevelModuleName)
-> Interface -> TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
m
oldF <- TopLevelModuleName -> TCM (Either FindError SourceFile)
findFile' TopLevelModuleName
t
(newF, modFile) <- runStateT (findFile'_ incs t) modFile
return $ case (oldF, newF) of
(Right SourceFile
f1, Right SourceFile
f2) | SourceFile
f1 SourceFile -> SourceFile -> Bool
forall a. Eq a => a -> a -> Bool
== SourceFile
f2 ->
(TopLevelModuleName
-> ModuleInfo -> DecodedModules -> DecodedModules
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TopLevelModuleName
t ModuleInfo
m DecodedModules
keep, ModuleToSourceId
modFile)
(Either FindError SourceFile, Either FindError SourceFile)
_ -> (DecodedModules
keep, ModuleToSourceId
modFile)
process keep modFile ms
{-# SPECIALIZE NOINLINE isPropEnabled :: TCM Bool #-}
isPropEnabled :: HasOptions m => m Bool
isPropEnabled :: forall (m :: * -> *). HasOptions m => m Bool
isPropEnabled = PragmaOptions -> Bool
optProp (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
isLevelUniverseEnabled :: HasOptions m => m Bool
isLevelUniverseEnabled :: forall (m :: * -> *). HasOptions m => m Bool
isLevelUniverseEnabled = PragmaOptions -> Bool
optLevelUniverse (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
showImplicitArguments :: HasOptions m => m Bool
showImplicitArguments :: forall (m :: * -> *). HasOptions m => m Bool
showImplicitArguments = PragmaOptions -> Bool
optShowImplicit (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
showGeneralizedArguments :: HasOptions m => m Bool
showGeneralizedArguments :: forall (m :: * -> *). HasOptions m => m Bool
showGeneralizedArguments = PragmaOptions -> Bool
optShowGeneralized (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
showIrrelevantArguments :: HasOptions m => m Bool
showIrrelevantArguments :: forall (m :: * -> *). HasOptions m => m Bool
showIrrelevantArguments = PragmaOptions -> Bool
optShowIrrelevant (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
showIdentitySubstitutions :: HasOptions m => m Bool
showIdentitySubstitutions :: forall (m :: * -> *). HasOptions m => m Bool
showIdentitySubstitutions = PragmaOptions -> Bool
optShowIdentitySubstitutions (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
withShowAllArguments :: ReadTCState m => m a -> m a
withShowAllArguments :: forall (m :: * -> *) a. ReadTCState m => m a -> m a
withShowAllArguments = Bool -> m a -> m a
forall (m :: * -> *) a. ReadTCState m => Bool -> m a -> m a
withShowAllArguments' Bool
True
withShowAllArguments' :: ReadTCState m => Bool -> m a -> m a
withShowAllArguments' :: forall (m :: * -> *) a. ReadTCState m => Bool -> m a -> m a
withShowAllArguments' Bool
yes = (PragmaOptions -> PragmaOptions) -> m a -> m a
forall (m :: * -> *) a.
ReadTCState m =>
(PragmaOptions -> PragmaOptions) -> m a -> m a
withPragmaOptions ((PragmaOptions -> PragmaOptions) -> m a -> m a)
-> (PragmaOptions -> PragmaOptions) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \ PragmaOptions
opts ->
PragmaOptions
opts { _optShowImplicit = Value yes, _optShowIrrelevant = Value yes }
withoutPrintingGeneralization :: ReadTCState m => m a -> m a
withoutPrintingGeneralization :: forall (m :: * -> *) a. ReadTCState m => m a -> m a
withoutPrintingGeneralization = (PragmaOptions -> PragmaOptions) -> m a -> m a
forall (m :: * -> *) a.
ReadTCState m =>
(PragmaOptions -> PragmaOptions) -> m a -> m a
withPragmaOptions ((PragmaOptions -> PragmaOptions) -> m a -> m a)
-> (PragmaOptions -> PragmaOptions) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \ PragmaOptions
opts ->
PragmaOptions
opts { _optShowGeneralized = Value False }
withPragmaOptions :: ReadTCState m => (PragmaOptions -> PragmaOptions) -> m a -> m a
withPragmaOptions :: forall (m :: * -> *) a.
ReadTCState m =>
(PragmaOptions -> PragmaOptions) -> m a -> m a
withPragmaOptions = Lens' TCState PragmaOptions
-> (PragmaOptions -> PragmaOptions) -> m a -> m a
forall a b. Lens' TCState a -> (a -> a) -> m b -> m b
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' TCState a -> (a -> a) -> m b -> m b
locallyTCState (PragmaOptions -> f PragmaOptions) -> TCState -> f TCState
Lens' TCState PragmaOptions
stPragmaOptions
positivityCheckEnabled :: HasOptions m => m Bool
positivityCheckEnabled :: forall (m :: * -> *). HasOptions m => m Bool
positivityCheckEnabled = PragmaOptions -> Bool
optPositivityCheck (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
etaEnabled :: HasOptions m => m Bool
etaEnabled :: forall (m :: * -> *). HasOptions m => m Bool
etaEnabled = PragmaOptions -> Bool
optEta (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
maxInstanceSearchDepth :: HasOptions m => m Int
maxInstanceSearchDepth :: forall (m :: * -> *). HasOptions m => m Int
maxInstanceSearchDepth = PragmaOptions -> Int
optInstanceSearchDepth (PragmaOptions -> Int) -> m PragmaOptions -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
maxInversionDepth :: HasOptions m => m Int
maxInversionDepth :: forall (m :: * -> *). HasOptions m => m Int
maxInversionDepth = PragmaOptions -> Int
optInversionMaxDepth (PragmaOptions -> Int) -> m PragmaOptions -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions