content: module File.Load
      ( loadFile
      ) where
  
  import System.IO
  import System.FilePath
  import Control.Monad
  import Control.Monad.Trans
  import Control.Monad.State
  import Control.Exception
  import qualified Data.ByteString as B
  
  import Syntax
  import Syntax.Parser
  import Syntax.ErrorDoc
  import Syntax.PrettyPrinter()
  import TypeChecking.Expressions.Utils
  import TypeChecking.Definitions
  import TypeChecking.Monad
  
  loadFile :: MonadIO m => String -> ScopeT m [(Name,Fixity)]
  loadFile filename = do
      ((errs, _), (_, tab)) <- runStateT (runWarnT $ loadFile' [] filename) ([],[])
      liftIO $ mapM_ (\(fn, err) -> hPutStrLn stderr $ erenderWithFilename fn $ errorMsg err) errs
      return tab
  
  loadFile' :: MonadIO m => [String] -> String
      -> WarnT [(String,Error)] (StateT ([String],[(Name,Fixity)]) (ScopeT m)) ()
  loadFile' checking filename = do
      mcnt <- liftIO $ fmap Right (B.readFile filename)
                      `catch` \e -> return $ Left $ show (e :: SomeException)
      case mcnt of
          Right cnt -> parseDefs filename checking cnt
          Left err  -> warn [(filename, Error Other $ emsg err enull)]
  
  parseDefs :: MonadIO m => String -> [String] -> B.ByteString
      -> WarnT [(String,Error)] (StateT ([String],[(Name,Fixity)]) (ScopeT m)) ()
  parseDefs cur checking s = do
      defs <- mapWarnT (map $ \e -> (cur,e)) (pDefs s)
      defs' <- forM defs $ \def -> case def of
          DefImport moduleName -> do
              let filename = foldr1 combine moduleName <.> "hoq"
              if filename `elem` checking
                  then warn [(cur, Error Other $ emsg ("Modules " ++ cur ++ " and " ++ filename ++ " form a cycle") enull)]
                  else do
                      (checked,_) <- lift get
                      if filename `elem` checked then return () else loadFile' (cur:checking) filename
              return def
          DefFixity pos inf pr ops -> do
              forM_ ops $ \op -> do
                  (fns,tab) <- lift get
                  case lookup op tab of
                      Just ft ->
                          let msg = "Multiple fixity declarations for " ++ nameToInfix op ++ " [" ++ show ft ++ "]"
                          in warn [(cur, Error Other $ emsgLC pos msg enull)]
                      Nothing -> return ()
                  lift $ put (fns, (op, Infix inf pr):tab)
              return def
          _ -> lift get >>= \(_,tab) -> mapWarnT (map $ \e -> (cur,e)) (fixFixityDef tab def)
      lift $ modify $ \(fns,tab) -> (cur:fns,tab)
      (es,mr) <- lift $ lift $ runWarnT (typeCheckDefs defs')
      let es' = map (\e -> (cur,e)) es
      case mr of
          Nothing -> throwError es'
          Just r -> warn es' >> return r
  