ModDeps.hs

module GF.Compile.ModDeps (mkSourceGrammar,
		moduleDeps,
		openInterfaces,
		requiredCanModules
	       ) where

import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Printer
import GF.Compile.Update
import GF.Grammar.Lookup
import GF.Infra.Modules

import GF.Data.Operations

import Control.Monad
import Data.List

-- | to check uniqueness of module names and import names, the
-- appropriateness of import and extend types,
-- to build a dependency graph of modules, and to sort them topologically
mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
mkSourceGrammar ms = do
  let ns = map fst ms
  checkUniqueErr ns
  mapM (checkUniqueImportNames ns . snd) ms
  deps    <- moduleDeps ms
  deplist <- either 
               return 
               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
               topoTest deps
  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]

checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
checkUniqueErr ms = do
  let msg = checkUnique ms
  if null msg then return () else Bad $ unlines msg

-- | check that import names don't clash with module names
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v]
 where
   test ms = testErr (all (`notElem` ns) ms)
                     ("import names clashing with module names among" +++ unwords (map prt ms))

type Dependencies = [(IdentM Ident,[IdentM Ident])]

-- | to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
moduleDeps :: [SourceModule] -> Err Dependencies
moduleDeps ms = mapM deps ms where
  deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
      MTConcrete a -> do
        am <- lookupModuleType gr a
        testErr (mtype am == MTAbstract) "the of-module is not an abstract syntax" 
        chDep (IdentM c (MTConcrete a)) 
              (extends m) (MTConcrete a) (opens m) MTResource
      t -> chDep (IdentM c t) (extends m) t (opens m) t

  chDep it es ety os oty = do
    ems <- mapM (lookupModuleType gr) es
    testErr (all (compatMType ety . mtype) ests) "inappropriate extension module type" 
    let ab = case it of
               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
               _ -> [] ---- 
    return (it, ab ++
                [IdentM e ety | e <- es] ++ 
                [IdentM (openedModule o) oty | o <- os])

  -- check for superficial compatibility, not submodule relation etc: what can be extended
  compatMType mt0 mt = case (mt0,mt) of
    (MTResource,   MTConcrete _) -> True
    (MTInstance _, MTConcrete _) -> True
    (MTInterface,  MTAbstract)   -> True
    (MTConcrete _, MTConcrete _) -> True
    (MTInstance _, MTInstance _) -> True
    (MTInstance _, MTResource) -> True
    (MTResource, MTInstance _) -> True
    ---- some more?
    _ -> mt0 == mt
  -- in the same way; this defines what can be opened
  compatOType mt0 mt = case mt0 of
    MTAbstract -> mt == MTAbstract
    _ -> case mt of
      MTResource -> True
      MTInterface -> True
      MTInstance _ -> True
      _ -> False      

  gr = MGrammar ms --- hack

openInterfaces :: Dependencies -> Ident -> Err [Ident]
openInterfaces ds m = do
  let deps = [(i,ds) | (IdentM i _,ds) <- ds]
  let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
  let mods = iterFix (concatMap more) (more (m,undefined))
  return $ [i | (i,MTInterface) <- mods]

-- | this function finds out what modules are really needed in the canonical gr.
-- its argument is typically a concrete module name
requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
  exts = allExtends gr c
  ops  = if isSingle 
         then map fst (modules gr)
         else iterFix (concatMap more) $ exts
  more i = errVal [] $ do
    m <- lookupModule gr i
    return $ extends m ++ [o | o <- map openedModule (opens m)]
  notReuse i = errVal True $ do
    m <- lookupModule gr i
    return $ isModRes m -- to exclude reused Cnc and Abs from required


{-
-- to test
exampleDeps = [
  (ir "Nat",[ii "Gen", ir "Adj"]),
  (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
  (ir "Nou",[ii "Cas"])
  ]

ii s = IdentM (IC s) MTInterface
ir s = IdentM (IC s) MTResource
-}