module DDC.Driver.Command.RewriteRules
        ( cmdTryReadRules )
where
import DDC.Driver.Interface.Source
import DDC.Build.Language
import DDC.Core.Fragment
import DDC.Core.Simplifier
import DDC.Core.Module
import DDC.Core.Lexer
import DDC.Core.Pretty
import DDC.Core.Exp
import DDC.Core.Transform.Reannotate
import DDC.Core.Transform.Rewrite.Rule  hiding (Error)
import DDC.Core.Transform.Rewrite.Parser
import System.Directory
import System.IO
import qualified DDC.Control.Parser     as BP
import qualified DDC.Core.Check         as C
import qualified DDC.Core.Parser        as C
import qualified DDC.Type.Env           as Env
import qualified DDC.Core.Env.EnvX      as EnvX


-- Read rewrite rules ---------------------------------------------------------
-- | Load and typecheck a module's rewrite rules, using exported and imported
--   definitions from module
cmdTryReadRules 
        :: (Ord n, Show n, Pretty n)
        => Fragment n err       -- ^ Language fragment.
        -> FilePath             -- ^ Path to the module.
        -> Module () n          -- ^ Module with types of imports and exports
        -> IO (NamedRewriteRules () n)

cmdTryReadRules frag filePath modu
 = do
        exists  <- doesFileExist filePath
        -- Silently return an empty list if there is no rules file
        case exists of
         False -> return []
         True  -> do
            -- Read the source file
            src        <- readFile filePath
            let source =  SourceFile filePath
            -- Parse and typecheck
            cmdReadRules_parse filePath frag modu source src


cmdReadRules_parse filePath frag modu source src
 = case parse frag modu source src of
    Left err -> do
        putStrLn $ "When reading " ++ filePath
        hPutStrLn stderr err
        return []
    Right rules -> return rules


parse fragment modu source str
 = case BP.runTokenParser describeToken source' 
        (pRuleMany (C.contextOfProfile (fragmentProfile fragment)))
          (fragmentLexExp fragment source' 0 str) of
                Left err -> Left $ renderIndent $ ppr err
                Right rules ->
                  case mapM check' rules of
                    Left err     -> Left  $ renderIndent $ ppr err
                    Right rules' -> Right $ rules'
 where
    -- Typecheck, then clear annotations
    check' (n,r)
     = do r' <- checkRewriteRule config env' r
          return (show n, reannotate (const ()) r')

    profile     = fragmentProfile fragment
    config      = C.configOfProfile   profile
    kinds       = profilePrimKinds    profile
    types       = profilePrimTypes    profile
    defs        = profilePrimDataDefs profile

    kindsImp    = moduleKindEnv modu
    typesImp    = moduleTypeEnv modu

    kindsExp    = Env.fromList 
                $ [BName n t | (n, Just t) <- map (liftSnd takeTypeOfExportSource)
                                           $  moduleExportTypes  modu ]
    
    typesExp    = Env.fromList
                $ [BName n t | (n, Just t) <- map (liftSnd takeTypeOfExportSource)
                                           $  moduleExportValues modu ]

    liftSnd f (x, y) = (x, f y)

    -- Final kind and type environments
    kinds'      = kinds `Env.union` kindsImp `Env.union` kindsExp
    types'      = types `Env.union` typesImp `Env.union` typesExp
    env'        = EnvX.fromPrimEnvs kinds' types' defs

    source'  = nameOfSource source