{-
   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
-}
module Camfort.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 Camfort.Helpers
import Camfort.Traverse
import Camfort.Analysis.Annotations
import Camfort.Analysis.Syntax
import Camfort.Analysis.Types
import Camfort.Transformation.Syntax
import Camfort.Transformation.CommonBlockElim

import Debug.Trace

{- 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 = (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 = (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' = (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 
-}