module E.Program where import Prelude hiding(putStrLn, putStr,print) import Control.Monad.Identity import Data.Monoid import List import Maybe import qualified Data.Map as Map import StringTable.Atom import DataConstructors import Doc.DocLike import Doc.PPrint import CharIO import Doc.Pretty import E.E import E.Show import E.TypeCheck import FrontEnd.Class import Util.Gen hiding(putErrLn) import Name.Id import Name.Name import Options import Util.SetLike import qualified IO import qualified FlagDump as FD import qualified Stats data ProgramType = SubProgram Bool | MainProgram | MainComponent data Program = Program { progExternalNames :: IdSet, progClassHierarchy :: ClassHierarchy, 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, progStats :: !Stats.Stat } program = Program { progExternalNames = mempty, progClassHierarchy = 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 = check $ ucache prog where ds = progCombinators prog ucache prog = prog { progCombMap = fromList [ (combIdent c,c) | c <- ds ] } check x | not flint = x | hasRepeatUnder combIdent ds = error $ "programSetDs: program has redundant definitions: \n" ++ names | any (not . isValidAtom) (map combIdent ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ names | otherwise = x names = intercalate "\n" (sort $ map (show . tvrShowName . combHead) ds) programSetDs' :: [(TVr,E)] -> Program -> Program programSetDs' ds prog = progCombinators_s [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ] prog where lupRules t = concat [ combRules c | c <- progCombinators prog, combIdent c == t] 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 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_ 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 IO.stderr prog printCheckName'' = hPrintCheckName IO.stderr hPrintCheckName :: IO.Handle -> DataTable -> TVr -> E -> IO () hPrintCheckName fh dataTable tvr e = do let (ty,pty) = case 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 (not tmatch || dump FD.EVerbose) $ hPutStrLn fh (render $ hang 4 (pprint tvr <+> text "::" <+> pty)) hPutStrLn fh (render $ hang 4 (pprint tvr <+> equals <+> pprint e))