ModGraph.hs

-- | Generate a module use-graph.
module Language.Fortran.Analysis.ModGraph
  (genModGraph, ModGraph(..), ModOrigin(..), modGraphToList, modGraphToDOT, takeNextMods, delModNodes)
where

import Language.Fortran.AST hiding (setName)
import qualified Language.Fortran.Parser as Parser
import Language.Fortran.Version
import Language.Fortran.Util.ModFile
import Language.Fortran.Util.Files

import Prelude hiding (mod)
import Control.Monad.State.Strict
import Control.Monad ( forM_ ) -- required for mtl-2.3 (GHC 9.6)
import Data.Data
import Data.Generics.Uniplate.Data
import Data.Graph.Inductive hiding (version)
import Data.Maybe
import qualified Data.Map as M

--------------------------------------------------

data ModOrigin = MOFile FilePath | MOFSMod FilePath
  deriving (Eq, Data, Show)

instance Ord ModOrigin where
  MOFSMod _ <= MOFSMod _ = True
  a <= b = a == b

data ModGraph = ModGraph { mgModNodeMap :: M.Map String (Node, Maybe ModOrigin)
                         , mgGraph      :: Gr String ()
                         , mgNumNodes   :: Int }
  deriving (Eq, Data)

modGraph0 :: ModGraph
modGraph0 = ModGraph M.empty empty 0

type ModGrapher a = StateT ModGraph IO a

maybeAddModName :: String -> Maybe ModOrigin -> ModGrapher Node
maybeAddModName modName org = do
  mg@ModGraph { mgModNodeMap = mnmap, mgGraph = gr, mgNumNodes = numNodes } <- get
  case M.lookup modName mnmap of
    Just (i, org') | org <= org' -> pure i
                   | otherwise   -> do
                       let mnmap' = M.insert modName (i, org) mnmap
                       put $ mg { mgModNodeMap = mnmap' }
                       pure i
    Nothing -> do
      let i = numNodes + 1
      let mnmap' = M.insert modName (i, org) mnmap
      let gr' = insNode (i, modName) gr
      put $ mg { mgModNodeMap = mnmap', mgGraph = gr', mgNumNodes = i }
      pure i

addModDep :: String -> String -> ModGrapher ()
addModDep modName depName = do
  i <- maybeAddModName modName Nothing
  j <- maybeAddModName depName Nothing
  mg@ModGraph { mgGraph = gr } <- get
  put $ mg { mgGraph = insEdge (i, j, ()) gr }

genModGraph :: Maybe FortranVersion -> [FilePath] -> Maybe String -> [FilePath] -> IO ModGraph
genModGraph mversion includeDirs cppOpts paths = do
  let perModule path pu@(PUModule _ _ modName _ _) = do
        _ <- maybeAddModName modName (Just $ MOFile path)
        let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <-
                                universeBi pu :: [Statement ()] ]
        forM_ uses $ \ usedName -> do
          _ <- maybeAddModName usedName Nothing
          addModDep modName usedName
      perModule path pu | Named puName <- getName pu = do
        _ <- maybeAddModName puName (Just $ MOFile path)
        let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <-
                                universeBi pu :: [Statement ()] ]
        forM_ uses $ \ usedName -> do
          _ <- maybeAddModName usedName Nothing
          addModDep puName usedName
      perModule _ _ = pure ()
  let iter :: FilePath -> ModGrapher ()
      iter path = do
        contents <- liftIO $ runCPP cppOpts path
        fileMods <- liftIO $ decodeModFiles includeDirs
        let version = fromMaybe (deduceFortranVersion path) mversion
            mods = map snd fileMods
            parserF0 = Parser.byVerWithMods mods version
            parserF fn bs =
              case parserF0 fn bs of
                Right x -> return x
                Left  err -> do
                  error $ show err
        forM_ fileMods $ \ (fileName, mod) -> do
          forM_ [ name | Named name <- M.keys (combinedModuleMap [mod]) ] $ \ name -> do
            _ <- maybeAddModName name . Just $ MOFSMod fileName
            pure ()
        pf <- parserF path contents
        mapM_ (perModule path) (childrenBi pf :: [ProgramUnit ()])
        pure ()
  execStateT (mapM_ iter paths) modGraph0

-- Remove duplicates from a list preserving the left most occurrence.
removeDuplicates :: Eq a => [a] -> [a]
removeDuplicates [] = []
removeDuplicates (x:xs) =
  if x `elem` xs
    then x : removeDuplicates (filter (/= x) xs)
    else x : removeDuplicates xs

modGraphToDOT :: ModGraph -> String
modGraphToDOT ModGraph { mgGraph = gr } = unlines dot
  where
    dot = [ "strict digraph {\n"
          , "node [shape=box,fontname=\"Courier New\"]\n" ] ++
          concatMap (\ (i, name) ->
                        [ "n" ++ show i ++ "[label=\"" ++ name ++ "\"]\n"
                        , "n" ++ show i ++ " -> {" ] ++
                        [ " n" ++ show j | j <- suc gr i ] ++
                        ["}\n"])
                    (labNodes gr) ++
          [ "}\n" ]

-- Provides a topological sort of the graph, giving a list of filenames
modGraphToList :: ModGraph -> [String]
modGraphToList m = removeDuplicates $ modGraphToList' m
  where
    modGraphToList' mg
      | nxt <- takeNextMods mg
      , not (null nxt) =
          let mg' = delModNodes (map fst nxt) mg
          in [ fn | (_, Just (MOFile fn)) <- nxt ] ++ modGraphToList' mg'
    modGraphToList' _ = []


takeNextMods :: ModGraph -> [(Node, Maybe ModOrigin)]
takeNextMods ModGraph { mgModNodeMap = mnmap, mgGraph = gr } = noDepFiles
  where
    noDeps = [ (i, modName) | (i, modName) <- labNodes gr, null (suc gr i) ]
    noDepFiles = [ (i, mo) | (i, modName) <- noDeps
                           , (_, mo) <- maybeToList (M.lookup modName mnmap) ]

delModNodes :: [Node] -> ModGraph -> ModGraph
delModNodes ns mg@ModGraph { mgGraph = gr } = mg'
  where
    mg' = mg { mgGraph = delNodes ns gr }