{-# OPTIONS_GHC -Wunused-imports #-}

module Mikan.TypeChecking.Monad.Imports
  ( addImport
  , checkForImportCycle
  , dropDecodedModule
  , getDecodedModule
  , getDecodedModules
  , getPrettyVisitedModules
  , getVisitedModule
  , getVisitedModules
  , setDecodedModules
  , setVisitedModules
  , storeDecodedModule
  , visitModule
  ) where

import Control.Monad   ( when )

import Data.Map qualified as Map
import Data.Set qualified as Set

import Mikan.Syntax.Common.Pretty
import Mikan.Syntax.TopLevelModuleName
import Mikan.TypeChecking.Monad.Diagnostic
import Mikan.TypeChecking.Monad.Base

import Mikan.Utils.List
import Mikan.Utils.List1 qualified as List1
import Mikan.Utils.List2 qualified as List2
import Mikan.Utils.Tuple ( (***) )

import Mikan.Utils.Impossible

-- | Register the given module as imported in the current state.
--   Also recursively add its imports to the cumulative imports.
addImport :: TopLevelModuleName -> TCM ()
addImport :: TopLevelModuleName -> TCM ()
addImport TopLevelModuleName
top = ASetter' TCState ImportedModules
-> (ImportedModules -> ImportedModules) -> TCM ()
forall (m :: * -> *) a.
MonadTCState m =>
ASetter' TCState a -> (a -> a) -> m ()
modifyingTC ASetter' TCState ImportedModules
Lens' TCState ImportedModules
stImportedModules ((ImportedModules -> ImportedModules) -> TCM ())
-> (ImportedModules -> ImportedModules) -> TCM ()
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> ImportedModules -> ImportedModules
forall a. Ord a => a -> Set a -> Set a
Set.insert TopLevelModuleName
top

visitModule :: ModuleInfo -> TCM ()
visitModule :: ModuleInfo -> TCM ()
visitModule ModuleInfo
mi = ASetter' TCState VisitedModules
-> (VisitedModules -> VisitedModules) -> TCM ()
forall (m :: * -> *) a.
MonadTCState m =>
ASetter' TCState a -> (a -> a) -> m ()
modifyingTC ASetter' TCState VisitedModules
Lens' TCState VisitedModules
stVisitedModules ((VisitedModules -> VisitedModules) -> TCM ())
-> (VisitedModules -> VisitedModules) -> TCM ()
forall a b. (a -> b) -> a -> b
$
  TopLevelModuleName
-> ModuleInfo -> VisitedModules -> VisitedModules
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Interface -> TopLevelModuleName
iTopLevelModuleName (Interface -> TopLevelModuleName)
-> Interface -> TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Interface
miInterface ModuleInfo
mi) ModuleInfo
mi

setVisitedModules :: VisitedModules -> TCM ()
setVisitedModules :: VisitedModules -> TCM ()
setVisitedModules VisitedModules
ms = ASetter' TCState VisitedModules -> VisitedModules -> TCM ()
forall (m :: * -> *) a.
MonadTCState m =>
ASetter' TCState a -> a -> m ()
setTCLens ASetter' TCState VisitedModules
Lens' TCState VisitedModules
stVisitedModules VisitedModules
ms

getVisitedModules :: ReadTCState m => m VisitedModules
getVisitedModules :: forall (m :: * -> *). ReadTCState m => m VisitedModules
getVisitedModules = Getter TCState VisitedModules -> m VisitedModules
forall (m :: * -> *) a. ReadTCState m => Getter TCState a -> m a
useTC (VisitedModules -> f VisitedModules) -> TCState -> f TCState
Lens' TCState VisitedModules
Getter TCState VisitedModules
stVisitedModules

getPrettyVisitedModules :: ReadTCState m => m Doc
getPrettyVisitedModules :: forall (m :: * -> *). ReadTCState m => m Doc
getPrettyVisitedModules = do
  visited <-  ((TopLevelModuleName, ModuleInfo) -> Doc)
-> [(TopLevelModuleName, ModuleInfo)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Doc -> Doc -> Doc) -> (Doc, Doc) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>) ((Doc, Doc) -> Doc)
-> ((TopLevelModuleName, ModuleInfo) -> (Doc, Doc))
-> (TopLevelModuleName, ModuleInfo)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TopLevelModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty (TopLevelModuleName -> Doc)
-> (ModuleInfo -> Doc)
-> (TopLevelModuleName, ModuleInfo)
-> (Doc, Doc)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (ModuleCheckMode -> Doc
prettyCheckMode (ModuleCheckMode -> Doc)
-> (ModuleInfo -> ModuleCheckMode) -> ModuleInfo -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> ModuleCheckMode
miMode))) ([(TopLevelModuleName, ModuleInfo)] -> [Doc])
-> (VisitedModules -> [(TopLevelModuleName, ModuleInfo)])
-> VisitedModules
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VisitedModules -> [(TopLevelModuleName, ModuleInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList
          (VisitedModules -> [Doc]) -> m VisitedModules -> m [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VisitedModules
forall (m :: * -> *). ReadTCState m => m VisitedModules
getVisitedModules
  return $ hcat $ punctuate ", " visited
  where
  prettyCheckMode :: ModuleCheckMode -> Doc
  prettyCheckMode :: ModuleCheckMode -> Doc
prettyCheckMode ModuleCheckMode
ModuleTypeChecked                  = Doc
""
  prettyCheckMode ModuleCheckMode
ModuleScopeChecked                 = Doc
" (scope only)"

getVisitedModule :: ReadTCState m
                 => TopLevelModuleName
                 -> m (Maybe ModuleInfo)
getVisitedModule :: forall (m :: * -> *).
ReadTCState m =>
TopLevelModuleName -> m (Maybe ModuleInfo)
getVisitedModule TopLevelModuleName
x = TopLevelModuleName -> VisitedModules -> Maybe ModuleInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TopLevelModuleName
x (VisitedModules -> Maybe ModuleInfo)
-> m VisitedModules -> m (Maybe ModuleInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getter TCState VisitedModules -> m VisitedModules
forall (m :: * -> *) a. ReadTCState m => Getter TCState a -> m a
useTC (VisitedModules -> f VisitedModules) -> TCState -> f TCState
Lens' TCState VisitedModules
Getter TCState VisitedModules
stVisitedModules

getDecodedModules :: TCM DecodedModules
getDecodedModules :: TCM VisitedModules
getDecodedModules = PersistentTCState -> VisitedModules
stDecodedModules (PersistentTCState -> VisitedModules)
-> (TCState -> PersistentTCState) -> TCState -> VisitedModules
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCState -> PersistentTCState
stPersistentState (TCState -> VisitedModules)
-> TCMT IO TCState -> TCM VisitedModules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO TCState
forall (m :: * -> *). MonadTCState m => m TCState
getTC

setDecodedModules :: DecodedModules -> TCM ()
setDecodedModules :: VisitedModules -> TCM ()
setDecodedModules VisitedModules
ms = (TCState -> TCState) -> TCM ()
forall (m :: * -> *).
MonadTCState m =>
(TCState -> TCState) -> m ()
modifyTC ((TCState -> TCState) -> TCM ()) -> (TCState -> TCState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \TCState
s ->
  TCState
s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } }

getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)
getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)
getDecodedModule TopLevelModuleName
x = TopLevelModuleName -> VisitedModules -> Maybe ModuleInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TopLevelModuleName
x (VisitedModules -> Maybe ModuleInfo)
-> (TCState -> VisitedModules) -> TCState -> Maybe ModuleInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentTCState -> VisitedModules
stDecodedModules (PersistentTCState -> VisitedModules)
-> (TCState -> PersistentTCState) -> TCState -> VisitedModules
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCState -> PersistentTCState
stPersistentState (TCState -> Maybe ModuleInfo)
-> TCMT IO TCState -> TCM (Maybe ModuleInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO TCState
forall (m :: * -> *). MonadTCState m => m TCState
getTC

storeDecodedModule :: ModuleInfo -> TCM ()
storeDecodedModule :: ModuleInfo -> TCM ()
storeDecodedModule ModuleInfo
mi = (TCState -> TCState) -> TCM ()
forall (m :: * -> *).
MonadTCState m =>
(TCState -> TCState) -> m ()
modifyTC ((TCState -> TCState) -> TCM ()) -> (TCState -> TCState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \TCState
s ->
  TCState
s { stPersistentState =
        (stPersistentState s) { stDecodedModules =
          Map.insert (iTopLevelModuleName $ miInterface mi) mi $
            stDecodedModules (stPersistentState s)
        }
  }

dropDecodedModule :: TopLevelModuleName -> TCM ()
dropDecodedModule :: TopLevelModuleName -> TCM ()
dropDecodedModule TopLevelModuleName
x = (TCState -> TCState) -> TCM ()
forall (m :: * -> *).
MonadTCState m =>
(TCState -> TCState) -> m ()
modifyTC ((TCState -> TCState) -> TCM ()) -> (TCState -> TCState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \TCState
s ->
  TCState
s { stPersistentState =
        (stPersistentState s) { stDecodedModules =
                                  Map.delete x $ stDecodedModules $ stPersistentState s
                              }
  }


-- | Assumes that the first module in the import path is the module we are
--   worried about.
checkForImportCycle :: TCM ()
checkForImportCycle :: TCM ()
checkForImportCycle = do
  TCMT IO [TopLevelModuleName]
-> TCM ()
-> (TopLevelModuleName -> [TopLevelModuleName] -> TCM ())
-> TCM ()
forall (m :: * -> *) a b.
Monad m =>
m [a] -> m b -> (a -> [a] -> m b) -> m b
caseListM (Lens' TCEnv [TopLevelModuleName] -> TCMT IO [TopLevelModuleName]
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC ([TopLevelModuleName] -> f [TopLevelModuleName])
-> TCEnv -> f TCEnv
Lens' TCEnv [TopLevelModuleName]
eImportStack) TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__ \TopLevelModuleName
m [TopLevelModuleName]
ms -> do
    Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TopLevelModuleName
m TopLevelModuleName -> [TopLevelModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TopLevelModuleName]
ms) (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
$ List2 TopLevelModuleName -> TypeError
CyclicModuleDependency (List2 TopLevelModuleName -> TypeError)
-> List2 TopLevelModuleName -> TypeError
forall a b. (a -> b) -> a -> b
$
      List1 TopLevelModuleName
-> TopLevelModuleName -> List2 TopLevelModuleName
forall a. List1 a -> a -> List2 a
List2.snoc (List1 TopLevelModuleName
-> [TopLevelModuleName] -> List1 TopLevelModuleName
forall a. List1 a -> [a] -> List1 a
List1.fromListSafe List1 TopLevelModuleName
forall a. HasCallStack => a
__IMPOSSIBLE__ ([TopLevelModuleName] -> List1 TopLevelModuleName)
-> [TopLevelModuleName] -> List1 TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ (TopLevelModuleName -> Bool)
-> [TopLevelModuleName] -> [TopLevelModuleName]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TopLevelModuleName -> TopLevelModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= TopLevelModuleName
m) ([TopLevelModuleName] -> [TopLevelModuleName])
-> [TopLevelModuleName] -> [TopLevelModuleName]
forall a b. (a -> b) -> a -> b
$ [TopLevelModuleName] -> [TopLevelModuleName]
forall a. [a] -> [a]
reverse [TopLevelModuleName]
ms) TopLevelModuleName
m
        -- NB: we know that ms contains m, so even after dropWhile the list is not empty.