content: module E.Program where
  
  import Control.Monad.Identity
  import Data.Monoid
  import Data.List
  import Data.Maybe
  import qualified Data.Map as Map
  
  import DataConstructors
  import Doc.DocLike
  import Doc.PPrint
  import Doc.Pretty
  import E.E
  import E.Show
  import E.TypeCheck
  import Name.Id
  import Name.Name
  import Options
  import System.IO
  import Util.ContextMonad
  import Util.SetLike
  import qualified FlagDump as FD
  import qualified Stats
  
  data ProgramType = SubProgram Bool | MainProgram | MainComponent
  
  data Program = Program {
      progExternalNames :: IdSet,
      progCombinators   :: [Comb],
      progDataTable     :: DataTable,
      progEntry         :: IdSet,
      progMain          :: Id,
      progModule        :: Module,
      progPasses        :: [String],    -- ^ record of passes the program goes through
      progUsedIds       :: IdSet,       -- ^ filled in by occurance info collection
      progFreeIds       :: IdSet,       -- ^ filled in by occurance info collection
      progSeasoning     :: IdSet,       -- ^ these ids are depended on by external names via RULES
      progType          :: ProgramType,
      progCombMap       :: IdMap Comb,  -- progCombMap is always (fromList . progCombinators)
      progStats         :: !Stats.Stat
      }
  
  program = Program {
      progExternalNames = mempty,
      progCombinators   = mempty,
      progDataTable     = mempty,
      progEntry         = mempty,
      progMain          = emptyId,
      progModule        = mainModule,
      progPasses        = [],
      progUsedIds       = mempty,
      progFreeIds       = mempty,
      progSeasoning     = mempty,
      progType          = MainProgram,
      progCombMap       = mempty,
      progStats         = mempty
      }
  
  progEntryPoints prog = map combHead $ concatMap (progComb prog) (toList $ progEntry prog)
  progMainEntry prog = combHead . runIdentity $ progComb prog (progMain prog)
  
  progComb :: Monad m => Program -> Id -> m Comb
  progComb prog x = case x `mlookup`  progCombMap prog of
      Nothing -> fail $ "progComb: can't find '" ++ show (tvrShowName tvr { tvrIdent = x }) ++  "'"
      Just c -> return c
  
  programDs :: Program -> [(TVr,E)]
  programDs prog = [ (t,e)  | Comb { combHead = t,
                                     combBody = e } <- progCombinators prog]
  
  progCombinators_u f prog =
      programUpdate prog { progCombinators = f $ progCombinators prog }
  progCombinators_s cs prog = programUpdate prog { progCombinators = cs }
  
  programUpdate ::  Program -> Program
  programUpdate prog = ucache prog where
      ucache prog = prog { progCombMap =
          fromList [ (combIdent c,c) | c <- progCombinators prog ] }
  
  programSetDs' :: [(TVr,E)] -> Program -> Program
  programSetDs' ds prog = progCombinators_s newDs prog where
      newDs = [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ]
      lupRules t = case mlookup t (progCombMap prog) of
          Just c -> combRules c
          Nothing -> mempty
  
  programSetDs :: [(TVr,E)] -> Program -> Program
  programSetDs ds prog = progCombinators_s [ bindComb (t,e) | (t,e) <- ds ] prog
  
  programE :: Program -> E
  programE prog = ELetRec (programDs prog) (EVar (progMainEntry prog))
  
  programEsMap :: Monad m => Program -> m (Map.Map Name (TVr,E))
  programEsMap prog = do
      let f d@(v,_) = case fromId (tvrIdent v) of
              Just n -> return (n,d)
              Nothing -> fail $ "Program.programEsMap: top level var with temporary name " ++ show v
      xs <- mapM f (programDs prog)
      return (Map.fromList xs)
  
  programMapBodies :: Monad m => (E -> m E) -> Program -> m Program
  programMapBodies f prog = do
      let f' (t,e) = f e >>= \e' -> return (t,e')
      programMapDs f' prog
  
  programMapDs :: Monad m => ((TVr, E) -> m (TVr, E)) -> Program -> m Program
  programMapDs f prog = do
      cs <- forM (progCombinators prog) $ \comb -> do
          (t,e) <- f (combHead comb,combBody comb)
          return . combHead_s t . combBody_s e $ comb
      return $ progCombinators_s cs prog
  
  programMapDs_ :: Monad m => ((TVr,E) -> m ()) -> Program -> m ()
  programMapDs_ f prog = mapM_ f (programDs prog)
  
  hPrintProgram fh prog@Program {progCombinators = cs, progDataTable = dataTable } = do
      sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e |
                                                  Comb { combHead = v, combBody = e } <- cs]
      when (progMain prog /= emptyId) $
          hPutStrLn fh $ "MainEntry: " ++ pprint (progMainEntry prog)
      when (progEntry prog /= singleton (progMain prog)) $
          hPutStrLn fh $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog))
  
  printProgram prog = hPrintProgram stderr prog
  
  printCheckName'' = hPrintCheckName stderr
  
  hPrintCheckName :: Handle -> DataTable -> TVr -> E -> IO ()
  hPrintCheckName fh dataTable tvr e = do
      let (ty,pty) = case runContextEither (inferType dataTable [] e) of
              Left err -> (Unknown,vcat $ map text (intersperse "---" $ tail err))
              Right ty -> (ty,pprint ty)
          tmatch = isJust $ match (const Nothing) [] ty (tvrType tvr)
      when (dump FD.EInfo || verbose2) $ hPutStrLn fh (show $ tvrInfo tvr)
      hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> (pprint $ tvrType tvr)))
      when (ty /= Unknown && (not tmatch || dump FD.EVerbose)) $
          hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> pty))
      hPutStrLn fh (render $ hang 4 (pprint tvr <+> equals <+> pprint e))
      when (ty == Unknown) $
          hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "TypeError:" </> pty))
  