content: {-# LANGUAGE DoAndIfThenElse #-}
  
  module Language.PureScript.Erl.Interactive
    ( handleCommand
    , module Interactive
  
  
    , make
    , runMake
    , modulesDir
    ) where
  
  import           Prelude ()
  import           Prelude.Compat
  import           Protolude (ordNub)
  
  import           Data.List (sort, find, foldl')
  import           Data.Maybe (fromMaybe, mapMaybe)
  import qualified Data.Map as M
  import qualified Data.Set as S
  import           Data.Text (Text)
  import qualified Data.Text as T
  
  import           Control.Monad.IO.Class (MonadIO, liftIO)
  import           Control.Monad.State.Class
  import           Control.Monad.Reader.Class
  import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
  import           Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT)
  import           Control.Monad.Writer.Strict (Writer(), runWriter)
  
  import qualified Language.PureScript as P
  import qualified Language.PureScript.CST as CST
  import qualified Language.PureScript.Names as N
  import qualified Language.PureScript.Constants.Prim as C
  
  import           Language.PureScript.Interactive.Completion   as Interactive
  import           Language.PureScript.Interactive.IO           as Interactive
  import           Language.PureScript.Interactive.Message      as Interactive
  import           Language.PureScript.Interactive.Module       as Interactive hiding (modulesDir)
  import           Language.PureScript.Interactive.Parser       as Interactive
  import           Language.PureScript.Interactive.Printer      as Interactive
  import           Language.PureScript.Interactive.Types        as Interactive
  
  import           System.Directory (getCurrentDirectory)
  import           System.FilePath.Glob (glob)
  
  -- | Pretty-print errors
  printErrors :: MonadIO m => P.MultipleErrors -> m ()
  printErrors errs = liftIO $ do
    pwd <- getCurrentDirectory
    putStrLn $ P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs
  
  -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
  -- options and ignores the warning messages.
  runMake :: P.Make a -> IO (Either P.MultipleErrors a)
  runMake mk = fst <$> P.runMake (P.defaultOptions { P.optionsCodegenTargets = S.singleton P.CoreFn }) mk
  
  modulesDir :: FilePath
  modulesDir = ".purerl_repl/"
  
  -- | Rebuild a module, using the cached externs data for dependencies.
  rebuild
    :: [P.ExternsFile]
    -> P.Module
    -> P.Make (P.ExternsFile, P.Environment)
  rebuild loadedExterns m = do
      externs <- P.rebuildModule buildActions loadedExterns m
      return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
    where
      buildActions :: P.MakeActions P.Make
      buildActions =
        (P.buildMakeActions modulesDir
                            filePathMap
                            M.empty
                            False) { P.progress = const (return ()) }
  
      filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
      filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
  
  -- | Build the collection of modules from scratch. This is usually done on startup.
  make
    :: [(FilePath, CST.PartialResult P.Module)]
    -> P.Make ([P.ExternsFile], P.Environment)
  make ms = do
      foreignFiles <- P.inferForeignModules filePathMap
      externs <- P.make (buildActions foreignFiles) (map snd ms)
      return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
    where
      buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
      buildActions foreignFiles =
        P.buildMakeActions modulesDir
                           filePathMap
                           foreignFiles
                           False
  
      filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
      filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName $ CST.resPartial m, Right fp)) ms
  
  -- | Performs a PSCi command
  handleCommand
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => m () -- ^ evaluate
    -> m () -- ^ reload
    -> (String -> m ()) -- ^ print into console
    -> Command
    -> m ()
  handleCommand _ _ p ShowHelp                  = p helpMessage
  handleCommand _ r _ ReloadState               = handleReloadState r
  handleCommand _ r _ ClearState                = handleClearState r
  handleCommand e _ _ (Expression val)          = handleExpression e val
  handleCommand _ _ _ (Import im)               = handleImport im
  handleCommand _ _ _ (Decls l)                 = handleDecls l
  handleCommand _ _ p (TypeOf val)              = handleTypeOf p val
  handleCommand _ _ p (KindOf typ)              = handleKindOf p typ
  handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName
  handleCommand _ _ p (ShowInfo QueryLoaded)    = handleShowLoadedModules p
  handleCommand _ _ p (ShowInfo QueryImport)    = handleShowImportedModules p
  handleCommand _ _ p (ShowInfo QueryPrint)     = handleShowPrint p
  handleCommand _ _ p (CompleteStr prefix)      = handleComplete p prefix
  handleCommand _ _ p (SetInteractivePrint ip)  = handleSetInteractivePrint p ip
  handleCommand _ _ _ _                         = P.internalError "handleCommand: unexpected command"
  
  -- | Reload the application state
  handleReloadState
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => m ()
    -> m ()
  handleReloadState reload = do
    modify $ updateLets (const [])
    globs <- asks psciFileGlobs
    files <- liftIO $ concat <$> traverse glob globs
    e <- runExceptT $ do
      modules <- ExceptT . liftIO $ loadAllModules files
      (externs, _) <- ExceptT . liftIO . runMake . make $ fmap CST.pureResult <$> modules
      return (map snd modules, externs)
    case e of
      Left errs -> printErrors errs
      Right (modules, externs) -> do
        modify (updateLoadedExterns (const (zip modules externs)))
        reload
  
  -- | Clear the application state
  handleClearState
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => m ()
    -> m ()
  handleClearState reload = do
    modify $ updateImportedModules (const [])
    handleReloadState reload
  
  -- | Takes a value expression and evaluates it with the current state.
  handleExpression
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => m ()
    -> P.Expr
    -> m ()
  handleExpression evaluate val = do
    st <- get
    let m = createTemporaryModule True st val 
    e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
    case e of
      Left errs -> printErrors errs
      Right _ -> do
        -- js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")
        evaluate
        pure ()
  
  -- |
  -- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
  -- restore the original environment.
  --
  handleDecls
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => [P.Declaration]
    -> m ()
  handleDecls ds = do
    st <- gets (updateLets (++ ds))
    let m = createTemporaryModule False st (P.Literal P.nullSourceSpan (P.ObjectLiteral []))
    e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
    case e of
      Left err -> printErrors err
      Right _ -> put st
  
  -- | Show actual loaded modules in psci.
  handleShowLoadedModules
    :: (MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> m ()
  handleShowLoadedModules print' = do
      loadedModules <- gets psciLoadedExterns
      print' $ readModules loadedModules
    where
      readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst)
  
  -- | Show the imported modules in psci.
  handleShowImportedModules
    :: (MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> m ()
  handleShowImportedModules print' = do
    importedModules <- psciImportedModules <$> get
    print' $ showModules importedModules
    where
    showModules = unlines . sort . map (T.unpack . showModule)
    showModule (mn, declType, asQ) =
      "import " <> N.runModuleName mn <> showDeclType declType <>
      foldMap (\mn' -> " as " <> N.runModuleName mn') asQ
  
    showDeclType P.Implicit = ""
    showDeclType (P.Explicit refs) = refsList refs
    showDeclType (P.Hiding refs) = " hiding " <> refsList refs
    refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")"
  
    showRef :: P.DeclarationRef -> Maybe Text
    showRef (P.TypeRef _ pn dctors) =
      Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")"
    showRef (P.TypeOpRef _ op) =
      Just $ "type " <> N.showOp op
    showRef (P.ValueRef _ ident) =
      Just $ N.runIdent ident
    showRef (P.ValueOpRef _ op) =
      Just $ N.showOp op
    showRef (P.TypeClassRef _ pn) =
      Just $ "class " <> N.runProperName pn
    showRef (P.TypeInstanceRef _ ident _) =
      Just $ N.runIdent ident
    showRef (P.ModuleRef _ name) =
      Just $ "module " <> N.runModuleName name
    showRef (P.ReExportRef _ _ _) =
      Nothing
  
  
    commaList :: [Text] -> Text
    commaList = T.intercalate ", "
  
  handleShowPrint
    :: (MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> m ()
  handleShowPrint print' = do
    current <- psciInteractivePrint <$> get
    if current == initialInteractivePrint
      then
        print' $
          "The interactive print function is currently set to the default (`" ++ showPrint current ++ "`)"
      else
        print' $
          "The interactive print function is currently set to `" ++ showPrint current ++ "`\n" ++
          "The default can be restored with `:print " ++ showPrint initialInteractivePrint ++ "`"
  
    where
    showPrint (mn, ident) = T.unpack (N.runModuleName mn <> "." <> N.runIdent ident)
  
  -- | Imports a module, preserving the initial state on failure.
  handleImport
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => ImportedModule
    -> m ()
  handleImport im = do
     st <- gets (updateImportedModules (im :))
     let m = createTemporaryModuleForImports st
     e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
     case e of
       Left errs -> printErrors errs
       Right _  -> put st
  
  -- | Takes a value and prints its type
  handleTypeOf
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> P.Expr
    -> m ()
  handleTypeOf print' val = do
    st <- get
    let m = createTemporaryModule False st val
    e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
    case e of
      Left errs -> printErrors errs
      Right (_, env') ->
        case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName "$PSCI")) (P.names env') of
          Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty
          Nothing -> print' "Could not find type"
  
  -- | Takes a type and prints its kind
  handleKindOf
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> P.SourceType
    -> m ()
  handleKindOf print' typ = do
    st <- get
    let m = createTemporaryModuleForKind st typ
        mName = P.ModuleName "$PSCI"
    e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
    case e of
      Left errs -> printErrors errs
      Right (_, env') ->
        case M.lookup (P.Qualified (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of
          Just (_, typ') -> do
            let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
                k   = check (snd <$> P.kindOf typ') chk
  
                check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
                check sew = fst . runWriter . runExceptT . runStateT sew
            case k of
              Left err        -> printErrors err
              Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind
          Nothing -> print' "Could not find kind"
  
  -- | Browse a module and displays its signature
  handleBrowse
    :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> P.ModuleName
    -> m ()
  handleBrowse print' moduleName = do
    st <- get
    let env = psciEnvironment st
    case findMod moduleName (psciLoadedExterns st) (psciImportedModules st) of
      Just qualName -> print' $ printModuleSignatures qualName env
      Nothing       -> failNotInEnv moduleName
    where
      findMod needle externs imports =
        let qualMod = fromMaybe needle (lookupUnQualifiedModName needle imports)
            modules = S.fromList (C.primModules <> (P.getModuleName . fst <$> externs))
        in if qualMod `S.member` modules
             then Just qualMod
             else Nothing
  
      failNotInEnv modName = print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
      lookupUnQualifiedModName needle imports =
          (\(modName,_,_) -> modName) <$> find (\(_,_,mayQuaName) -> mayQuaName == Just needle) imports
  
  -- | Return output as would be returned by tab completion, for tools integration etc.
  handleComplete
    :: (MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> String
    -> m ()
  handleComplete print' prefix = do
    st <- get
    let act = liftCompletionM (completion' (reverse prefix, ""))
    results <- evalStateT act st
    print' $ unlines (formatCompletions results)
  
  -- | Attempt to set the interactive print function. Note that the state will
  -- only be updated if the interactive print function exists and appears to
  -- work; we test it by attempting to evaluate '0'.
  handleSetInteractivePrint
    :: (MonadState PSCiState m, MonadIO m)
    => (String -> m ())
    -> (P.ModuleName, P.Ident)
    -> m ()
  handleSetInteractivePrint print' new = do
    current <- gets psciInteractivePrint
    modify (setInteractivePrint new)
    st <- get
    let expr = P.Literal internalSpan (P.NumericLiteral (Left 0))
    let m = createTemporaryModule True st expr
    e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
    case e of
      Left errs -> do
        modify (setInteractivePrint current)
        print' "Unable to set the repl's printing function:"
        printErrors errs
      Right _ ->
        pure ()