content: module Interactive(Interactive.interact, isInteractive) where
  
  import Control.Exception as CE
  import Control.Monad.Identity
  import Control.Monad.Reader
  import Data.Monoid
  import System.IO(stdout)
  import System.Environment
  import Data.List(sort,isPrefixOf)
  import Data.Maybe
  import Text.Regex
  import qualified Data.Map as Map
  
  import DataConstructors
  import Doc.DocLike
  import Doc.PPrint
  import Doc.Pretty
  import FrontEnd.Desugar(desugarHsStmt)
  import FrontEnd.HsParser(parseHsStmt)
  import FrontEnd.HsPretty()
  import FrontEnd.HsSyn
  import FrontEnd.KindInfer
  import FrontEnd.ParseMonad
  import FrontEnd.Rename
  import FrontEnd.Tc.Class
  import FrontEnd.Tc.Main
  import FrontEnd.Tc.Monad
  import FrontEnd.Tc.Type
  import FrontEnd.TypeSigs
  import FrontEnd.TypeSynonyms(showSynonym)
  import FrontEnd.TypeSyns
  import FrontEnd.Warning
  import GenUtil
  import Ho.Type
  import Name.Name
  import Options
  import Support.Compat
  import Util.Interact
  import Version.Version(versionString)
  import qualified FrontEnd.HsPretty as HsPretty
  import qualified FrontEnd.Infix
  import qualified Text.PrettyPrint.HughesPJ as PP
  
  printDoc doc = do
      displayIO stdout (renderPretty 0.9 80 doc)
      putStrLn ""
  
  grep_opts = [
   "f - match normal value",
   "C - match data constructor",
   "T - match type constructor",
   "L - match class"
   ]
  
  nameTag :: NameType -> Char
  nameTag TypeConstructor = 'T'
  nameTag DataConstructor = 'C'
  nameTag ClassName = 'L'
  nameTag Val = 'f'
  nameTag _ = '?'
  
  data InteractiveState = IS {
      stateHo :: HoTcInfo,
      stateInteract :: Interact,
      stateModule :: Module,
      stateImports :: [(Name,[Name])],
      stateOptions :: Opt
      }
  
  isInitial = IS {
      stateHo = mempty,
      stateInteract = emptyInteract,
      stateModule = mainModule,
      stateImports = [],
      stateOptions = options
      }
  
  newtype In a = MkIn (ReaderT InteractiveState IO a)
      deriving(MonadIO,Monad,Functor,MonadReader InteractiveState)
  
  runIn :: InteractiveState -> In a -> IO a
  runIn is (MkIn x) = runReaderT x is
  
  instance OptionMonad In where
      getOptions = asks stateOptions
  
  instance MonadWarn In where
      addWarning x = liftIO $ addWarning x
  
  interact :: CollectedHo -> IO ()
  interact cho = mre where
      hoE = hoTcInfo $ choHo cho
      hoB = hoBuild $ choHo cho
  
      mre = case optStmts options of
          [] -> go
          xs -> runInteractions initialInteract (concatMap lines $ reverse xs) >> exitSuccess
      go = do
          putStrLn "--------------------------------------------------------------"
          putStrLn "Welcome to the Ajhc interactive experience. use :help for help."
          putStrLn versionString
          putStrLn "(This is not a full interpreter, but rather is used to"
          putStrLn "help debug the compiler internals)"
          putStrLn "--------------------------------------------------------------"
          runInteraction initialInteract ":execfile ajhci.rc"
          beginInteraction initialInteract
      initialInteract = emptyInteract {
          interactSettables = ["prog", "args"],
          interactVersion = versionString,
          interactCommands = commands,
          interactWords = map (show . fst ) $ stateImports isStart,
          interactHistFile = Just ".ajhci-hist",
          interactComment = Just "--",
          interactExpr = do_expr
          }
      dataTable = hoDataTable hoB
      commands = [cmd_mods,cmd_grep]
      cmd_mods = InteractCommand { commandName = ":mods", commandHelp = "mods currently loaded modules", commandAction = do_mods }
      do_mods act _ _ = do
          printDoc $ fillSep (map tshow $ Map.keys $  hoExports hoE)
          return act
      cmd_grep = InteractCommand { commandName = ":grep", commandHelp = "show names matching a regex", commandAction = do_grep }
      do_grep act _ "" = do
          putStrLn ":grep [options] <regex>"
          putStrLn "Valid options:"
          putStr $ unlines grep_opts
          return act
      do_grep act _ arg = do
          let (opt,reg) = case simpleUnquote arg of
                  [x] -> ("TCLf",x)
                  xs -> f "" xs where
              f opt [x] = (opt,x)
              f opt ~(x:xs) = f (x ++ opt) xs
          rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException') -> return Nothing)
          case rx of
              Nothing -> putStrLn $ "Invalid regex: " ++ arg
              --Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
              Just rx -> mapM_ putStrLn $ sort [ pshow opt v  | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
          return act
      ptype x | Just r <- pprintTypeOfCons dataTable x = r
      ptype k | Just r <- Map.lookup k (hoAssumps hoE) = show (pprint r:: PP.Doc)
      ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoE))
      ptype x = "UNKNOWN: " ++ show (nameType x,x)
      isStart =  isInitial { stateHo = hoE, stateImports = runIdentity $ calcImports hoE False preludeModule }
      do_expr :: Interact -> String -> IO Interact
      do_expr act s = case parseStmt (s ++ "\n") of
          Left m -> putStrLn m >> return act
          Right e -> do
              CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException'))
              return act
      pshow _opt v
          | Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoE) = nameTag (nameType v):' ':d
          | otherwise = nameTag (nameType v):' ':show v <+> "::" <+> ptype v
  
  kindShow (KBase b) = pprint b
  kindShow x = parens (pprint x)
  
  parseStmt ::  Monad m => String -> m HsStmt
  parseStmt s = case snd $ runParserWithMode (parseModeOptions options) { parseFilename = "(jhci)" } parseHsStmt  s  of
                        ParseOk e -> return e
                        ParseFailed sl err -> fail $ show sl ++ ": " ++ err
  
  printStatement stmt = do
          liftIO $ putStrLn $ HsPretty.render $ HsPretty.ppHsStmt $  stmt
  
  procErrors :: In a -> In ()
  procErrors act = do
      b <- liftIO $ printIOErrors
      if b then return () else act >> return ()
  
  executeStatement :: HsStmt -> In ()
  executeStatement stmt = do
      is@IS { stateHo = hoE } <- ask
      stmt <- desugarHsStmt stmt
      stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt
      procErrors $ do
      --printStatement stmt'
      stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoE) (stateModule is) stmt'
      stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoE) stmt''
      procErrors $ do
      printStatement stmt'''
      tcStatementTc stmt'''
  
  {-
  tcStatement :: HsStmt -> In ()
  tcStatement HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"
  tcStatement HsGenerator {} = liftIO $ putStrLn "generators not yet supported"
  tcStatement (HsQualifier e) = do
      tcStatementTc (HsQualifier e)
      when False $ do
      is@IS { stateHo = ho } <- ask
      let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == Val ]
          importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x ==  DataConstructor ]
          ansName = Qual (stateModule is) (HsIdent "ans")
          ansName' = toName Val ansName
      opt <- getOptions
      localVarEnv <- liftIO $ TI.tiProgram
                  opt                            -- options
                  (stateModule is)               -- name of the module
                  mempty                         -- environment of type signatures
                  (hoKinds ho)                   -- kind information about classes and type constructors
                  (hoClassHierarchy ho)          -- class hierarchy with instances
                  importDConsEnv                 -- data constructor type environment
                  importVarEnv                   -- type environment
                  [([],[HsPatBind bogusASrcLoc (HsPVar ansName) (HsUnGuardedRhs e) []])]                        -- binding groups
                  []
      procErrors $ do
      vv <- Map.lookup ansName' localVarEnv
      liftIO $ putStrLn $ show (text "::" <+> pprint vv :: P.Doc)
      -}
  
  tcStatementTc :: HsStmt -> In ()
  tcStatementTc HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"
  tcStatementTc HsGenerator {} = liftIO $ putStrLn "generators not yet supported"
  tcStatementTc (HsQualifier e) = do
      is@IS { stateHo = ho } <- ask
      let tcInfo = tcInfoEmpty {
          tcInfoEnv = (hoAssumps ho),
          tcInfoSigEnv =  collectSigEnv (hoKinds ho) (HsQualifier e),
          tcInfoModName =  (stateModule is),
          tcInfoKindInfo = (hoKinds ho),
          tcInfoClassHierarchy = (hoClassHierarchy ho)
          }
      runTc tcInfo $ do
      box <- newBox kindFunRet
      (_,ps') <- listenPreds $ tiExpr e box
      ps' <- flattenType ps'
      let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'
      (ps :=> vv) <- flattenType (ps :=> box)
      TForAll vs (ps :=> t) <- generalize ps vv -- quantify (tv vv) qt
      --liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)
      liftIO $ putStrLn $   "::" <+> prettyPrintType (TForAll vs (ps :=> t))
      ce <- getCollectedEnv
      liftIO $ mapM_ putStrLn [ pprint n <+>  "::" <+> prettyPrintType s |  (n,s) <- Map.toList ce]
  
  calcImports :: Monad m => HoTcInfo -> Bool -> Module -> m [(Name,[Name])]
  calcImports ho qual mod = case Map.lookup mod (hoExports ho) of
      Nothing -> fail $ "calcImports: module not known " ++ show mod
      Just es -> do
          let ls = sortGroupUnderFG fst snd
                  [ (n,if qual then [setModule mod n] else [setModule mod n,toUnqualified n]) | n <- es]
              ls' = concat [ zip (concat nns) (repeat [n]) | (n,nns) <- ls ]
          return $ Map.toList $ Map.map snub $ Map.fromListWith (++) ls'
  
  isInteractive :: IO Bool
  isInteractive = do
      pn <- getProgName
      return $ (optMode options == Interactive)
            || "ichj" `isPrefixOf` reverse pn
            || not (null $ optStmts options)
  