camfort-0.615: Transformation/CommonBlockElimToCalls.hs

module Transformation.CommonBlockElimToCalls where

import Control.Monad
import Control.Monad.State.Lazy

import Data.Generics.Uniplate.Operations

import Data.List

import Language.Fortran
import Language.Haskell.Syntax (SrcLoc(..))

import Helpers
import Traverse
import Analysis.Annotations
import Analysis.Syntax
import Analysis.Types
import Transformation.Syntax
import Transformation.CommonBlockElim

{- This is somewhat experimental and incomplete -}

-- Top-level functions for eliminating common blocks in a set of files
commonElimToCalls :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)])

-- Eliminates common blocks in a program directory (and convert to calls)
commonElimToCalls d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", [])
                             (r', ps'') = mapM (introduceCalls cg) ps'
                         in (r ++ r', ps'')

{-Extending calls version-}
introduceCalls :: [TLCommon A] -> (Filename, Program A) -> (Report, (Filename, Program A))
introduceCalls cenv (fname, ps) = do ps' <- mapM (transformBiM commonElim) ps
                                     -- ps'' <- mapM (transformBiM commonElim'') ps'
                                     return (fname, ps')

              where commonElim s@(Sub a sp mbt (SubName a' moduleName) (Arg p arg asp) b) = 
                        
                         let commons = lookups moduleName (lookups fname cenv) 
                             sortedC = sortBy cmpTConBNames commons
                             tArgs = extendArgs (nonNullArgs arg) asp (concatMap snd sortedC)
                             ra = p { refactored = Just (fst sp) }
                             arg' = Arg unitAnnotation (ASeq unitAnnotation arg tArgs) asp
                             a' = a -- { pRefactored = Just sp }
                             r = fname ++ (show $ srcLineCol $ snd asp) ++ ": changed common variables to parameters\n"
                         in do b' <- transformBiM (extendCalls fname moduleName cenv) b
                               (r, Sub a' sp mbt (SubName a' moduleName) arg' b')

                    commonElim s = --case (getSubName s) of
                                   --    Just n -> transformBiM (extendCalls fname n cenv) s
                                   --    Nothing -> 
                                                  transformBiM r s 
                                                    where r :: ProgUnit A -> (Report, ProgUnit A)
                                                          r p = case getSubName p of
                                                                  Just n -> transformBiM (extendCalls fname n cenv) p
                                                                  Nothing -> return p


extendCalls :: String -> String -> [TLCommon A] -> Fortran A -> (Report, Fortran A)
extendCalls fname localSub cenv f@(Call p sp v@(Var _ _ ((VarName _ n, _):_)) (ArgList ap arglist)) =
        let commons = lookups n (map snd cenv)
            targetCommonNames = map fst (sortBy cmpTConBNames commons)

            localCommons = lookups localSub (lookups fname cenv)
            localCommons' = sortBy cmpTConBNames localCommons

            p' = p { refactored = Just $ toCol0 $ fst sp }
            ap' = ap { refactored = Just $ fst sp } 

            arglist' = toArgList p' sp (select targetCommonNames localCommons')
            r = fname  ++ (show $ srcLineCol $ fst sp) ++ ": call, added common variables as parameters\n"
        in (r, Call p' sp v (ArgList ap' $ ESeq p' sp arglist arglist'))
        
      --       Nothing -> error "Source has less commons than the target!"
extendCalls _ _ _ f = return f
                                      

toArgList :: A -> SrcSpan -> [(Variable, Type A)] -> Expr A
toArgList p sp [] = NullExpr p sp
toArgList p sp ((v, _):xs) = ESeq p sp (Var p sp [(VarName p v, [])]) (toArgList p sp xs)

select :: [Maybe String] -> [TCommon A] -> [(Variable, Type A)]
select [] _ = []
select x [] = error $ "Source has less commons than the target!" ++ show x
select a@(x:xs) b@((y, e):yes) | x == y = e ++ select xs yes
                               | otherwise = select xs yes

nonNullArgs (ASeq _ _ _) = True
nonNullArgs (ArgName _ _) = True
nonNullArgs (NullArg _) = False


extendArgs nonNullArgs sp' args = if nonNullArgs then 
                                     let p' = unitAnnotation { refactored = Just $ snd sp' }
                                     in ASeq p' (ArgName p' "") (extendArgs' sp' args)
                                  else extendArgs' sp' args
                                 

extendArgs'  _ [] = NullArg unitAnnotation
extendArgs' sp' ((v, t):vts) = 
    let p' = unitAnnotation { refactored = Just $ fst sp' }
    in ASeq p' (ArgName p' v) (extendArgs' sp' vts)

{- blockExtendDecls (Block a s i sp ds f) ds' = Block a s i sp (DSeq unitAnnotation ds ds') f
              
 extendArgs _ [] = (NullDecl unitAnnotation, NullArg unitAnnotation)
 extendArgs sp' ((v, t):vts) = 
     let p' = unitAnnotation { refactored = Just $ toCol0 $ fst sp' }
         dec = Decl p' [(Var p' sp' [(VarName p' v, [])], NullExpr p' sp')] t
         arg = ArgName p' v
         (decs, args) = extendArgs sp' vts
     in (DSeq p' dec decs, ASeq p' arg args)
-}




{-
 collectTCommons :: [Program Annotation] -> State (TCommons Annotation) [Program Annotation]
 collectTCommons p = transformBiM collectTCommons' p    
(transformBiM collectTCommons)
-}


collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)
collectCommons fname pname b = 
    let tenv = typeEnv b
                    
        commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A)
        commons' f@(Common a sp cname exprs) = 
            do let r' = fname ++ (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n"
               (r, env) <- get
               put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env)
               return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp)
        commons' f = return f

        typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)]
        typeCommonExprs [] = []
        typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) = 
            case (tenvLookup v tenv) of
                 Just t -> (v, t) : (typeCommonExprs es)
                 Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp
        typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e)

    in transformBiM commons' b                           

{-
-- Turn common blocks into type defs

 commonToTypeDefs :: String -> [(String, [Program Annotation])] -> IO Report
 commonToTypeDefs d = 
     let name = d ++ "Types"
         unitSrcLoc = SrcLoc (name ++ ".f90") 0 0
         decls = undefined
         mod = Module () (unitSrcLoc, unitSrcLoc) (SubName () name) [] ImplicitNode decls []
     in let ?variant = DefaultPP in writeFile (d ++ "/" ++ name ++ ".f90") (outputF mod)

 
 commonToTypeDefs' :: String -> (String, [Program Annotation]) -> [Decls]
 commonToTypeDefs' = undefined -- DerivedTypeDef p 
-}