{-
   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.
-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MonoLocalBinds #-}

module Camfort.Transformation.CommonBlockElim
  ( commonElimToModules
  ) where

import           Camfort.Analysis
import           Camfort.Analysis.Annotations
import           Camfort.Helpers
import           Camfort.Helpers.Syntax
import           Control.Monad hiding (ap)
import           Control.Monad.State.Lazy hiding (ap)
import           Control.Monad.Writer.Lazy (execWriter, tell)
import           Data.Data
import           Data.Function (on)
import           Data.Generics.Uniplate.Operations
import           Data.List hiding (init)
import qualified Data.Map as M
import           Data.Maybe (fromMaybe)
import           Data.Void
import qualified Language.Fortran.AST as F
import qualified Language.Fortran.Analysis as FA
import qualified Language.Fortran.Analysis.Renaming as FAR
import qualified Language.Fortran.Analysis.Types as FAT
import qualified Language.Fortran.ParserMonad as PM
import qualified Language.Fortran.PrettyPrint as PP
import qualified Language.Fortran.Util.Position as FU
import           Prelude hiding (mod, init)

-- Typed common-block representation
-- Tuple of:
--     * a (possible) common block name
--     * map from names to their types
type TypeInfo = (F.BaseType, FA.ConstructType)
type TCommon p = (Maybe F.Name, [(F.Name, TypeInfo)])

-- Typed and "located" common block representation
-- Right associated pairs tuple of:
--     * current filename
--     * current program unit name
--     * Typed common-block representation
-- TODO: include column + line information
type TLCommon p = (Filename, (F.Name, TCommon p))

type A1 = FA.Analysis Annotation
type CommonState = State (String, [TLCommon A])

-- | Type for type-level annotations giving documentation
type (:?) a (b :: k) = a

-- Top-level functions for eliminating common blocks in a set of files
commonElimToModules ::
       Directory
    -> [F.ProgramFile A]
    -> PureAnalysis Void Void ([F.ProgramFile A], [F.ProgramFile A])

-- Eliminates common blocks in a program directory (and convert to modules)
commonElimToModules :: Directory
-> [ProgramFile A]
-> PureAnalysis Void Void ([ProgramFile A], [ProgramFile A])
commonElimToModules Directory
d [ProgramFile A]
pfs = do
  let ([ProgramFile A]
pfs', (Directory
r, [TLCommon A]
cg)) = State (Directory, [TLCommon A]) [ProgramFile A]
-> (Directory, [TLCommon A])
-> ([ProgramFile A], (Directory, [TLCommon A]))
forall s a. State s a -> s -> (a, s)
runState ([ProgramFile A] -> State (Directory, [TLCommon A]) [ProgramFile A]
analyseAndRmCommons [ProgramFile A]
pfs) (Directory
"", [])
      (Directory
r', [ProgramFile A]
pfM)       = MetaInfo
-> Directory -> [TLCommon A] -> (Directory, [ProgramFile A])
introduceModules MetaInfo
meta Directory
d [TLCommon A]
cg
      pfs'' :: [ProgramFile A]
pfs''           = [ProgramFile A] -> [TLCommon A] -> [ProgramFile A]
updateUseDecls [ProgramFile A]
pfs' [TLCommon A]
cg
  [ProgramFile A] -> Text -> AnalysisT Void Void Identity ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' [ProgramFile A]
pfs (Text -> AnalysisT Void Void Identity ())
-> Text -> AnalysisT Void Void Identity ()
forall a b. (a -> b) -> a -> b
$ Directory -> Text
forall a. Describe a => a -> Text
describe (Directory -> Text) -> Directory -> Text
forall a b. (a -> b) -> a -> b
$ Directory
r Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
r'
  ([ProgramFile A], [ProgramFile A])
-> PureAnalysis Void Void ([ProgramFile A], [ProgramFile A])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ProgramFile A]
pfs'', [ProgramFile A]
pfM)
  where
    meta :: MetaInfo
meta = FortranVersion -> Directory -> MetaInfo
F.MetaInfo FortranVersion
PM.Fortran90 Directory
""

analyseAndRmCommons :: [F.ProgramFile A]
               -> CommonState [F.ProgramFile A]
analyseAndRmCommons :: [ProgramFile A] -> State (Directory, [TLCommon A]) [ProgramFile A]
analyseAndRmCommons = (ProgramFile A
 -> StateT (Directory, [TLCommon A]) Identity (ProgramFile A))
-> [ProgramFile A]
-> State (Directory, [TLCommon A]) [ProgramFile A]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ProgramFile A
-> StateT (Directory, [TLCommon A]) Identity (ProgramFile A)
analysePerPF

analysePerPF :: F.ProgramFile A -> CommonState (F.ProgramFile A)
analysePerPF :: ProgramFile A
-> StateT (Directory, [TLCommon A]) Identity (ProgramFile A)
analysePerPF ProgramFile A
pf = do
   let pf' :: ProgramFile (Analysis A)
pf' = ProgramFile (Analysis A) -> ProgramFile (Analysis A)
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAR.analyseRenames (ProgramFile (Analysis A) -> ProgramFile (Analysis A))
-> (ProgramFile A -> ProgramFile (Analysis A))
-> ProgramFile A
-> ProgramFile (Analysis A)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile A -> ProgramFile (Analysis A)
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
FA.initAnalysis (ProgramFile A -> ProgramFile (Analysis A))
-> ProgramFile A -> ProgramFile (Analysis A)
forall a b. (a -> b) -> a -> b
$ ProgramFile A
pf
   let (ProgramFile (Analysis A)
pf'', TypeEnv
tenv) = ProgramFile (Analysis A) -> (ProgramFile (Analysis A), TypeEnv)
forall a.
Data a =>
ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
FAT.analyseTypes ProgramFile (Analysis A)
pf'
   ProgramFile (Analysis A)
pf''' <- (ProgramUnit (Analysis A)
 -> StateT
      (Directory, [TLCommon A]) Identity (ProgramUnit (Analysis A)))
-> ProgramFile (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (ProgramFile (Analysis A))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (TypeEnv
-> Directory
-> ProgramUnit (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (ProgramUnit (Analysis A))
analysePerPU TypeEnv
tenv (ProgramFile A -> Directory
forall a. ProgramFile a -> Directory
F.pfGetFilename ProgramFile A
pf)) ProgramFile (Analysis A)
pf''
   ProgramFile A
-> StateT (Directory, [TLCommon A]) Identity (ProgramFile A)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Analysis A -> A) -> ProgramFile (Analysis A) -> ProgramFile A
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis A -> A
forall a. Analysis a -> a
FA.prevAnnotation ProgramFile (Analysis A)
pf''')

analysePerPU ::
    FAT.TypeEnv -> Filename -> F.ProgramUnit A1 -> CommonState (F.ProgramUnit A1)
analysePerPU :: TypeEnv
-> Directory
-> ProgramUnit (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (ProgramUnit (Analysis A))
analysePerPU TypeEnv
tenv Directory
fname ProgramUnit (Analysis A)
p =
    (Block (Analysis A)
 -> StateT (Directory, [TLCommon A]) Identity (Block (Analysis A)))
-> ProgramUnit (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (ProgramUnit (Analysis A))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (TypeEnv
-> Directory
-> ProgramUnitName
-> Block (Analysis A)
-> StateT (Directory, [TLCommon A]) Identity (Block (Analysis A))
collectAndRmCommons TypeEnv
tenv Directory
fname (ProgramUnit (Analysis A) -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit (Analysis A)
p)) ProgramUnit (Analysis A)
p

collectAndRmCommons :: FAT.TypeEnv -> Filename -> F.ProgramUnitName
               -> F.Block A1 -> CommonState (F.Block A1)
collectAndRmCommons :: TypeEnv
-> Directory
-> ProgramUnitName
-> Block (Analysis A)
-> StateT (Directory, [TLCommon A]) Identity (Block (Analysis A))
collectAndRmCommons TypeEnv
tenv Directory
fname ProgramUnitName
pname = (Statement (Analysis A)
 -> StateT
      (Directory, [TLCommon A]) Identity (Statement (Analysis A)))
-> Block (Analysis A)
-> StateT (Directory, [TLCommon A]) Identity (Block (Analysis A))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Statement (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (Statement (Analysis A))
commons
  where
    commons :: F.Statement A1 -> CommonState (F.Statement A1)
    commons :: Statement (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (Statement (Analysis A))
commons (F.StCommon Analysis A
a s :: SrcSpan
s@(FU.SrcSpan Position
p1 Position
_) AList CommonGroup (Analysis A)
cgrps) = do
        (CommonGroup (Analysis A)
 -> StateT (Directory, [TLCommon A]) Identity ())
-> [CommonGroup (Analysis A)]
-> StateT (Directory, [TLCommon A]) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CommonGroup (Analysis A)
-> StateT (Directory, [TLCommon A]) Identity ()
commonGroups (AList CommonGroup (Analysis A) -> [CommonGroup (Analysis A)]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList CommonGroup (Analysis A)
cgrps)
        let a' :: Analysis A
a' = (A -> A) -> Analysis A -> Analysis A
forall a. (a -> a) -> Analysis a -> Analysis a
onPrev (\A
ap -> A
ap {refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
p1, deleteNode :: Bool
deleteNode = Bool
True}) Analysis A
a
        Statement (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (Statement (Analysis A))
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement (Analysis A)
 -> StateT
      (Directory, [TLCommon A]) Identity (Statement (Analysis A)))
-> Statement (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (Statement (Analysis A))
forall a b. (a -> b) -> a -> b
$ Analysis A
-> SrcSpan
-> AList CommonGroup (Analysis A)
-> Statement (Analysis A)
forall a. a -> SrcSpan -> AList CommonGroup a -> Statement a
F.StCommon Analysis A
a' (SrcSpan -> SrcSpan
deleteLine SrcSpan
s) (Analysis A
-> SrcSpan
-> [CommonGroup (Analysis A)]
-> AList CommonGroup (Analysis A)
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList Analysis A
a SrcSpan
s [])
    commons Statement (Analysis A)
f = Statement (Analysis A)
-> StateT
     (Directory, [TLCommon A]) Identity (Statement (Analysis A))
forall (m :: * -> *) a. Monad m => a -> m a
return Statement (Analysis A)
f

    punitName :: ProgramUnitName -> Directory
punitName (F.Named Directory
s) = Directory
s
    punitName ProgramUnitName
_ = Directory
""

    -- Process a common group, adding blocks to the common state
    commonGroups :: F.CommonGroup A1 -> CommonState ()
    commonGroups :: CommonGroup (Analysis A)
-> StateT (Directory, [TLCommon A]) Identity ()
commonGroups (F.CommonGroup Analysis A
_ (FU.SrcSpan Position
p1 Position
_) Maybe (Expression (Analysis A))
cname AList Expression (Analysis A)
exprs) = do
      let r' :: Directory
r' = Position -> Directory
forall a. Show a => a -> Directory
show Position
p1 Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
": removed common declaration\n"
      let tcommon :: [(Directory, TypeInfo)]
tcommon = (Expression (Analysis A) -> (Directory, TypeInfo))
-> [Expression (Analysis A)] -> [(Directory, TypeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map Expression (Analysis A) -> (Directory, TypeInfo)
typeCommonExprs (AList Expression (Analysis A) -> [Expression (Analysis A)]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression (Analysis A)
exprs)
      let info :: TLCommon A
info = (Directory
fname, (ProgramUnitName -> Directory
punitName ProgramUnitName
pname, (Maybe (Expression (Analysis A)) -> Maybe Directory
forall a. Maybe (Expression a) -> Maybe Directory
commonNameFromAST Maybe (Expression (Analysis A))
cname, [(Directory, TypeInfo)]
tcommon)))
      ((Directory, [TLCommon A]) -> (Directory, [TLCommon A]))
-> StateT (Directory, [TLCommon A]) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\(Directory
r, [TLCommon A]
infos) -> (Directory
r Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
r', TLCommon A
info TLCommon A -> [TLCommon A] -> [TLCommon A]
forall a. a -> [a] -> [a]
: [TLCommon A]
infos))

    typeCommonExprs :: F.Expression A1 -> (F.Name, TypeInfo)
    typeCommonExprs :: Expression (Analysis A) -> (Directory, TypeInfo)
typeCommonExprs e :: Expression (Analysis A)
e@(F.ExpValue Analysis A
_ SrcSpan
sp (F.ValVariable Directory
_)) =
      case Directory -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Directory
var TypeEnv
tenv of
        Just (FA.IDType (Just BaseType
t) (Just ct :: ConstructType
ct@ConstructType
FA.CTVariable)) -> (Directory
src, (BaseType
t, ConstructType
ct))
        Just (FA.IDType (Just BaseType
t) (Just ct :: ConstructType
ct@FA.CTArray{}))  -> (Directory
src, (BaseType
t, ConstructType
ct))
        Maybe IDType
_ -> Directory -> (Directory, TypeInfo)
forall a. HasCallStack => Directory -> a
error (Directory -> (Directory, TypeInfo))
-> Directory -> (Directory, TypeInfo)
forall a b. (a -> b) -> a -> b
$ Directory
"Variable '" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
src
                  Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"' is of an unknown or higher-order type at: " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Directory
forall a. Show a => a -> Directory
show SrcSpan
sp Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
" "
                  Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Maybe IDType -> Directory
forall a. Show a => a -> Directory
show (Directory -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Directory
var TypeEnv
tenv)
      where
        var :: Directory
var = Expression (Analysis A) -> Directory
forall a. Expression (Analysis a) -> Directory
FA.varName Expression (Analysis A)
e
        src :: Directory
src = Expression (Analysis A) -> Directory
forall a. Expression (Analysis a) -> Directory
FA.srcName Expression (Analysis A)
e
    typeCommonExprs Expression (Analysis A)
e = Directory -> (Directory, TypeInfo)
forall a. HasCallStack => Directory -> a
error (Directory -> (Directory, TypeInfo))
-> Directory -> (Directory, TypeInfo)
forall a b. (a -> b) -> a -> b
$ Directory
"Not expecting a non-variable expression \
                                \in expression at: " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Directory
forall a. Show a => a -> Directory
show (Expression (Analysis A) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Expression (Analysis A)
e)


{- Comparison functions for common block names and variables -}
cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering
cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering
cmpTLConFName (Directory
f1, (Directory
_, TCommon a
_)) (Directory
f2, (Directory
_, TCommon a
_)) = Directory -> Directory -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Directory
f1 Directory
f2

cmpTLConPName :: TLCommon a -> TLCommon a -> Ordering
cmpTLConPName :: TLCommon A -> TLCommon A -> Ordering
cmpTLConPName (Directory
_, (Directory
p1, TCommon a
_)) (Directory
_, (Directory
p2, TCommon a
_)) = Directory -> Directory -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Directory
p1 Directory
p2

cmpTLConBNames :: TLCommon a -> TLCommon a -> Ordering
cmpTLConBNames :: TLCommon A -> TLCommon A -> Ordering
cmpTLConBNames (Directory
_, (Directory
_, TCommon a
c1)) (Directory
_, (Directory
_, TCommon a
c2)) = TCommon a -> TCommon a -> Ordering
forall k (a :: k). TCommon a -> TCommon a -> Ordering
cmpTConBNames TCommon a
c1 TCommon a
c2

cmpTConBNames :: TCommon a -> TCommon a -> Ordering
cmpTConBNames :: TCommon a -> TCommon a -> Ordering
cmpTConBNames (Maybe Directory
Nothing, [(Directory, TypeInfo)]
_) (Maybe Directory
Nothing, [(Directory, TypeInfo)]
_) = Ordering
EQ
cmpTConBNames (Maybe Directory
Nothing, [(Directory, TypeInfo)]
_) (Just Directory
_, [(Directory, TypeInfo)]
_)  = Ordering
LT
cmpTConBNames (Just Directory
_, [(Directory, TypeInfo)]
_) (Maybe Directory
Nothing, [(Directory, TypeInfo)]
_)  = Ordering
GT
cmpTConBNames (Just Directory
n, [(Directory, TypeInfo)]
_) (Just Directory
n', [(Directory, TypeInfo)]
_)
    | Directory
n Directory -> Directory -> Bool
forall a. Ord a => a -> a -> Bool
< Directory
n' = Ordering
LT
    | Directory
n Directory -> Directory -> Bool
forall a. Ord a => a -> a -> Bool
> Directory
n' = Ordering
GT
    | Bool
otherwise = Ordering
EQ

cmpVarName :: TLCommon a -> TLCommon a -> Ordering
cmpVarName :: TLCommon A -> TLCommon A -> Ordering
cmpVarName (Directory
_, (Directory
_, (Maybe Directory
_, [(Directory, TypeInfo)]
vtys1))) (Directory
_, (Directory
_, (Maybe Directory
_, [(Directory, TypeInfo)]
vtys2))) =
  ((Directory, TypeInfo) -> Directory)
-> [(Directory, TypeInfo)] -> [Directory]
forall a b. (a -> b) -> [a] -> [b]
map (Directory, TypeInfo) -> Directory
forall a b. (a, b) -> a
fst [(Directory, TypeInfo)]
vtys1 [Directory] -> [Directory] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ((Directory, TypeInfo) -> Directory)
-> [(Directory, TypeInfo)] -> [Directory]
forall a b. (a -> b) -> [a] -> [b]
map (Directory, TypeInfo) -> Directory
forall a b. (a, b) -> a
fst [(Directory, TypeInfo)]
vtys2

-- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)],
-- [(Filename, F.ProgramFile A)]) How to decide which gets to be the
-- "head" perhaps the one which triggers the *least* renaming (ooh!)
-- (this is calculated by looking for the mode of the TLCommon (for a
-- particular Common) (need to do gorouping, but sortBy is used
-- already so... (IS THIS STABLE- does this matter?))

commonName :: Maybe String -> String
commonName :: Maybe Directory -> Directory
commonName = Directory -> Maybe Directory -> Directory
forall a. a -> Maybe a -> a
fromMaybe Directory
"Common"

commonNameFromAST :: Maybe (F.Expression a) -> Maybe F.Name
commonNameFromAST :: Maybe (Expression a) -> Maybe Directory
commonNameFromAST (Just (F.ExpValue a
_ SrcSpan
_ (F.ValVariable Directory
v))) = Directory -> Maybe Directory
forall a. a -> Maybe a
Just Directory
v
commonNameFromAST Maybe (Expression a)
_ = Maybe Directory
forall a. Maybe a
Nothing

-- Freshen the names for a common block and generate a renamer from
-- the old block to this
freshenCommonNames :: TLCommon A -> (TLCommon A, RenamerCoercer)
freshenCommonNames :: TLCommon A -> (TLCommon A, RenamerCoercer)
freshenCommonNames (Directory
fname, (Directory
pname, (Maybe Directory
cname, [(Directory, TypeInfo)]
fields))) =
        let mkRenamerAndCommon :: (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
 [(Directory, TypeInfo)])
-> (Directory, TypeInfo)
-> (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
    [(Directory, TypeInfo)])
mkRenamerAndCommon (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
r, [(Directory, TypeInfo)]
tc) (Directory
v, TypeInfo
t) =
                           let v' :: Directory
v' = Directory -> Directory
caml (Maybe Directory -> Directory
commonName Maybe Directory
cname) Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"_" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
v
                           in (Directory
-> (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Directory
v (Directory -> Maybe Directory
forall a. a -> Maybe a
Just Directory
v', Maybe (TypeInfo, TypeInfo)
forall a. Maybe a
Nothing) Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
r, (Directory
v', TypeInfo
t) (Directory, TypeInfo)
-> [(Directory, TypeInfo)] -> [(Directory, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Directory, TypeInfo)]
tc)
            (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
rmap, [(Directory, TypeInfo)]
fields') = ((Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
  [(Directory, TypeInfo)])
 -> (Directory, TypeInfo)
 -> (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
     [(Directory, TypeInfo)]))
-> (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
    [(Directory, TypeInfo)])
-> [(Directory, TypeInfo)]
-> (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
    [(Directory, TypeInfo)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
 [(Directory, TypeInfo)])
-> (Directory, TypeInfo)
-> (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo)),
    [(Directory, TypeInfo)])
mkRenamerAndCommon (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
forall k a. Map k a
M.empty, []) [(Directory, TypeInfo)]
fields
        in ((Directory
fname, (Directory
pname, (Maybe Directory
cname, [(Directory, TypeInfo)]
fields'))), Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> RenamerCoercer
forall a. a -> Maybe a
Just Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
rmap)

-- From a list of typed and located common blocks group by the common
-- block name, and then group/sort within such that the "mode" block
-- is first
groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]]
groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]]
groupSortCommonBlock [TLCommon A]
commons = [[[TLCommon A]]]
gccs
  where
    -- Group by names of the common blocks
    gcs :: [[TLCommon A]]
gcs = (TLCommon A -> TLCommon A -> Bool)
-> [TLCommon A] -> [[TLCommon A]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\TLCommon A
x TLCommon A
y -> Ordering -> Bool
cmpEq (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ TLCommon A -> TLCommon A -> Ordering
forall k (a :: k). TLCommon A -> TLCommon A -> Ordering
cmpTLConBNames TLCommon A
x TLCommon A
y) [TLCommon A]
commons
    -- Group within by the different common block variable-type fields
    gccs :: [[[TLCommon A]]]
gccs = ([TLCommon A] -> [[TLCommon A]])
-> [[TLCommon A]] -> [[[TLCommon A]]]
forall a b. (a -> b) -> [a] -> [b]
map (([TLCommon A] -> [TLCommon A] -> Ordering)
-> [[TLCommon A]] -> [[TLCommon A]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\[TLCommon A]
y [TLCommon A]
x -> [TLCommon A] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TLCommon A]
x Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [TLCommon A] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TLCommon A]
y) ([[TLCommon A]] -> [[TLCommon A]])
-> ([TLCommon A] -> [[TLCommon A]])
-> [TLCommon A]
-> [[TLCommon A]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TLCommon A] -> [[TLCommon A]]
forall a. Eq a => [a] -> [[a]]
group ([TLCommon A] -> [[TLCommon A]])
-> ([TLCommon A] -> [TLCommon A]) -> [TLCommon A] -> [[TLCommon A]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TLCommon A -> TLCommon A -> Ordering)
-> [TLCommon A] -> [TLCommon A]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy TLCommon A -> TLCommon A -> Ordering
forall k (a :: k). TLCommon A -> TLCommon A -> Ordering
cmpVarName) [[TLCommon A]]
gcs
    cmpEq :: Ordering -> Bool
cmpEq = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ)

mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
mkTLCommonRenamers [TLCommon A]
commons =
    case [TLCommon A] -> (Directory, Bool)
allCoherentCommons [TLCommon A]
commons of
      (Directory
r, Bool
False) -> Directory -> [(TLCommon A, RenamerCoercer)]
forall a. HasCallStack => Directory -> a
error (Directory -> [(TLCommon A, RenamerCoercer)])
-> Directory -> [(TLCommon A, RenamerCoercer)]
forall a b. (a -> b) -> a -> b
$ Directory
"Common blocks are incoherent!\n" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
r
      (Directory
_, Bool
True) -> [(TLCommon A, RenamerCoercer)]
commons'
  where
    gccs :: [[[TLCommon A]]]
gccs = [TLCommon A] -> [[[TLCommon A]]]
groupSortCommonBlock [TLCommon A]
commons
    -- Find the "mode" common block and freshen the names for
    -- this, creating a renamer between this and every module
    gcrcs :: [[(TLCommon A, RenamerCoercer)]]
gcrcs = ([[TLCommon A]] -> [(TLCommon A, RenamerCoercer)])
-> [[[TLCommon A]]] -> [[(TLCommon A, RenamerCoercer)]]
forall a b. (a -> b) -> [a] -> [b]
map (\[[TLCommon A]]
grp -> -- grp are block decls all for the same block
             let (TLCommon A
com, RenamerCoercer
r) = TLCommon A -> (TLCommon A, RenamerCoercer)
freshenCommonNames ([TLCommon A] -> TLCommon A
forall a. [a] -> a
head ([[TLCommon A]] -> [TLCommon A]
forall a. [a] -> a
head [[TLCommon A]]
grp))
             in  (TLCommon A -> (TLCommon A, RenamerCoercer))
-> [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
forall a b. (a -> b) -> [a] -> [b]
map (\TLCommon A
c -> (TLCommon A
c, RenamerCoercer
r)) ([[TLCommon A]] -> [TLCommon A]
forall a. [a] -> a
head [[TLCommon A]]
grp) [(TLCommon A, RenamerCoercer)]
-> [(TLCommon A, RenamerCoercer)] -> [(TLCommon A, RenamerCoercer)]
forall a. [a] -> [a] -> [a]
++
                  (TLCommon A -> (TLCommon A, RenamerCoercer))
-> [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
forall a b. (a -> b) -> [a] -> [b]
map (\TLCommon A
c -> (TLCommon A
c, TLCommon A -> TLCommon A -> RenamerCoercer
forall k k (source :: k) (target :: k).
TLCommon A -> TLCommon A -> RenamerCoercer
mkRenamerCoercerTLC TLCommon A
c TLCommon A
com)) ([[TLCommon A]] -> [TLCommon A]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TLCommon A]] -> [TLCommon A]) -> [[TLCommon A]] -> [TLCommon A]
forall a b. (a -> b) -> a -> b
$ [[TLCommon A]] -> [[TLCommon A]]
forall a. [a] -> [a]
tail [[TLCommon A]]
grp)) [[[TLCommon A]]]
gccs
    -- Now re-sort based on the file and program unit
    commons' :: [(TLCommon A, RenamerCoercer)]
commons' = ((TLCommon A, RenamerCoercer)
 -> (TLCommon A, RenamerCoercer) -> Ordering)
-> [(TLCommon A, RenamerCoercer)] -> [(TLCommon A, RenamerCoercer)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TLCommon A -> TLCommon A -> Ordering)
-> (TLCommon A, RenamerCoercer)
-> (TLCommon A, RenamerCoercer)
-> Ordering
forall b c b. (b -> b -> c) -> (b, b) -> (b, b) -> c
cmpFst TLCommon A -> TLCommon A -> Ordering
forall k (a :: k). TLCommon A -> TLCommon A -> Ordering
cmpTLConFName) (((TLCommon A, RenamerCoercer)
 -> (TLCommon A, RenamerCoercer) -> Ordering)
-> [(TLCommon A, RenamerCoercer)] -> [(TLCommon A, RenamerCoercer)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TLCommon A -> TLCommon A -> Ordering)
-> (TLCommon A, RenamerCoercer)
-> (TLCommon A, RenamerCoercer)
-> Ordering
forall b c b. (b -> b -> c) -> (b, b) -> (b, b) -> c
cmpFst TLCommon A -> TLCommon A -> Ordering
forall k (a :: k). TLCommon A -> TLCommon A -> Ordering
cmpTLConPName) ([[(TLCommon A, RenamerCoercer)]] -> [(TLCommon A, RenamerCoercer)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(TLCommon A, RenamerCoercer)]]
gcrcs))
    cmpFst :: (b -> b -> c) -> (b, b) -> (b, b) -> c
cmpFst = ((b -> b -> c) -> ((b, b) -> b) -> (b, b) -> (b, b) -> c
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (b, b) -> b
forall a b. (a, b) -> a
fst)


-- Nothing represents an overall identity renamer/coercer for efficiency
-- a Nothing for a variable represent a variable-level (renamer) identity
-- a Nothing for a type represents a type-level (coercer) identity
type RenamerCoercer =
    Maybe (M.Map F.Name (Maybe F.Name, Maybe (TypeInfo, TypeInfo)))

class Renaming r where
    hasRenaming :: F.Name -> r -> Bool

instance Renaming RenamerCoercer where
    hasRenaming :: Directory -> RenamerCoercer -> Bool
hasRenaming Directory
_ RenamerCoercer
Nothing   = Bool
False
    hasRenaming Directory
v (Just Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
rc) = Directory
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Directory
v Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
rc

-- sometimes we have a number of renamer coercers together
instance Renaming [RenamerCoercer] where
    hasRenaming :: Directory -> [RenamerCoercer] -> Bool
hasRenaming Directory
v = (RenamerCoercer -> Bool) -> [RenamerCoercer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Directory -> RenamerCoercer -> Bool
forall r. Renaming r => Directory -> r -> Bool
hasRenaming Directory
v)

updateUseDecls ::
  [F.ProgramFile A] -> [TLCommon A] -> [F.ProgramFile A]
updateUseDecls :: [ProgramFile A] -> [TLCommon A] -> [ProgramFile A]
updateUseDecls [ProgramFile A]
fps [TLCommon A]
tcs = (ProgramFile A -> ProgramFile A)
-> [ProgramFile A] -> [ProgramFile A]
forall a b. (a -> b) -> [a] -> [b]
map ProgramFile A -> ProgramFile A
forall a. Data a => ProgramFile a -> ProgramFile a
perPF [ProgramFile A]
fps
  where
    perPF :: ProgramFile a -> ProgramFile a
perPF p :: ProgramFile a
p@(F.ProgramFile (F.MetaInfo FortranVersion
v Directory
_) [ProgramUnit a]
_) =
      (ProgramUnit A -> ProgramUnit A) -> ProgramFile a -> ProgramFile a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (FortranVersion -> ProgramUnit A -> ProgramUnit A
importIncludeCommons FortranVersion
v)
      (ProgramFile a -> ProgramFile a) -> ProgramFile a -> ProgramFile a
forall a b. (a -> b) -> a -> b
$ (ProgramUnit A -> ProgramUnit A) -> ProgramFile a -> ProgramFile a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (FortranVersion -> Directory -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v (ProgramFile a -> Directory
forall a. ProgramFile a -> Directory
F.pfGetFilename ProgramFile a
p)) ProgramFile a
p
    tcrs :: [(TLCommon A, RenamerCoercer)]
tcrs = [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
mkTLCommonRenamers [TLCommon A]
tcs

    inames :: F.Statement A -> Maybe String
    inames :: Statement A -> Maybe Directory
inames (F.StInclude A
_ SrcSpan
_ (F.ExpValue A
_ SrcSpan
_ (F.ValString Directory
fname)) Maybe [Block A]
_) = Directory -> Maybe Directory
forall a. a -> Maybe a
Just Directory
fname
    inames Statement A
_ = Maybe Directory
forall a. Maybe a
Nothing

    importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A
    importIncludeCommons :: FortranVersion -> ProgramUnit A -> ProgramUnit A
importIncludeCommons FortranVersion
v ProgramUnit A
p =
        (ProgramUnit A -> Directory -> ProgramUnit A)
-> ProgramUnit A -> [Directory] -> ProgramUnit A
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Directory -> ProgramUnit A -> ProgramUnit A)
-> ProgramUnit A -> Directory -> ProgramUnit A
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FortranVersion -> Directory -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v)) ProgramUnit A
p ((Statement A -> Maybe Directory) -> ProgramUnit A -> [Directory]
forall s t a.
(Data s, Data t, Uniplate t, Biplate t s) =>
(s -> Maybe a) -> t -> [a]
reduceCollect Statement A -> Maybe Directory
inames ProgramUnit A
p)

    -- Data-type generic reduce traversal
    reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]
    reduceCollect :: (s -> Maybe a) -> t -> [a]
reduceCollect s -> Maybe a
k t
x = Writer [a] t -> [a]
forall w a. Writer w a -> w
execWriter ((s -> WriterT [a] Identity s) -> t -> Writer [a] t
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (\s
y -> do case s -> Maybe a
k s
y of
                                                            Just a
x' -> [a] -> WriterT [a] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [a
x']
                                                            Maybe a
Nothing -> () -> WriterT [a] Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                                           s -> WriterT [a] Identity s
forall (m :: * -> *) a. Monad m => a -> m a
return s
y) t
x)


    insertUses :: [F.Block A] -> F.ProgramUnit A -> F.ProgramUnit A
    insertUses :: [Block A] -> ProgramUnit A -> ProgramUnit A
insertUses [Block A]
uses = ([Block A] -> [Block A]) -> ProgramUnit A -> ProgramUnit A
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi [Block A] -> [Block A]
insertUses'
      where insertUses' :: [F.Block A] -> [F.Block A]
            insertUses' :: [Block A] -> [Block A]
insertUses' [Block A]
bs = [Block A]
uses [Block A] -> [Block A] -> [Block A]
forall a. [a] -> [a] -> [a]
++ [Block A]
bs

    matchPUnit :: PM.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A
    matchPUnit :: FortranVersion -> Directory -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v Directory
fname ProgramUnit A
p =
        FortranVersion
-> [RenamerCoercer] -> ProgramUnit A -> ProgramUnit A
removeDecls FortranVersion
v (((TCommon a, RenamerCoercer) -> RenamerCoercer)
-> [(TCommon a, RenamerCoercer)] -> [RenamerCoercer]
forall a b. (a -> b) -> [a] -> [b]
map (TCommon a, RenamerCoercer) -> RenamerCoercer
forall a b. (a, b) -> b
snd [(TCommon a, RenamerCoercer)]
tcrs') ProgramUnit A
p'
      where
        pname :: Directory
pname = case ProgramUnit A -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit A
p of
                  F.Named Directory
n -> Directory
n
                   -- If no subname is available, use the filename
                  ProgramUnitName
_         -> Directory
fname
        tcrs' :: [(TCommon a, RenamerCoercer)]
tcrs' = Directory
-> [((Directory, TCommon a), RenamerCoercer)]
-> [(TCommon a, RenamerCoercer)]
forall a b c. Eq a => a -> [((a, b), c)] -> [(b, c)]
lookups Directory
pname (Directory
-> [(TLCommon A, RenamerCoercer)]
-> [((Directory, TCommon a), RenamerCoercer)]
forall a b c. Eq a => a -> [((a, b), c)] -> [(b, c)]
lookups Directory
fname [(TLCommon A, RenamerCoercer)]
tcrs)
        pos :: SrcSpan
pos = ProgramUnit A -> SrcSpan
getUnitStartPosition ProgramUnit A
p
        uses :: [Block A]
uses = SrcSpan -> [(TCommon a, RenamerCoercer)] -> [Block A]
mkUseStatementBlocks SrcSpan
pos [(TCommon a, RenamerCoercer)]
tcrs'
        p' :: ProgramUnit A
p' = [Block A] -> ProgramUnit A -> ProgramUnit A
insertUses [Block A]
uses ProgramUnit A
p
        -- Lookup functions over relation s

        lookups :: Eq a => a -> [((a, b), c)] -> [(b, c)]
        lookups :: a -> [((a, b), c)] -> [(b, c)]
lookups a
x = (((a, b), c) -> (b, c)) -> [((a, b), c)] -> [(b, c)]
forall a b. (a -> b) -> [a] -> [b]
map (\((a
_,b
b),c
c) -> (b
b, c
c))
          ([((a, b), c)] -> [(b, c)])
-> ([((a, b), c)] -> [((a, b), c)]) -> [((a, b), c)] -> [(b, c)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, b), c) -> Bool) -> [((a, b), c)] -> [((a, b), c)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) (a -> Bool) -> (((a, b), c) -> a) -> ((a, b), c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (((a, b), c) -> (a, b)) -> ((a, b), c) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b), c) -> (a, b)
forall a b. (a, b) -> a
fst)


    -- Given the list of renamed/coercerd variables form common blocks,
    -- remove any declaration sites
    removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A
    removeDecls :: FortranVersion
-> [RenamerCoercer] -> ProgramUnit A -> ProgramUnit A
removeDecls FortranVersion
v [RenamerCoercer]
rcs ProgramUnit A
p = FortranVersion -> ProgramUnit A -> [Statement A] -> ProgramUnit A
addToProgramUnit FortranVersion
v ProgramUnit A
p' [Statement A]
remainingAssignments
        where
     (ProgramUnit A
p', [Statement A]
remainingAssignments) = State [Statement A] (ProgramUnit A)
-> [Statement A] -> (ProgramUnit A, [Statement A])
forall s a. State s a -> s -> (a, s)
runState ((Block A -> StateT [Statement A] Identity (Block A))
-> ProgramUnit A -> State [Statement A] (ProgramUnit A)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ([RenamerCoercer]
-> Block A -> StateT [Statement A] Identity (Block A)
removeDecl [RenamerCoercer]
rcs) ProgramUnit A
p) []

    -- Removes a declaration and collects a list of any default values given at
    -- declaration time (which then need to be turned into separate assignment
    -- statements)
    removeDecl :: [RenamerCoercer]
               -> F.Block A -> State [F.Statement A] (F.Block A)
    removeDecl :: [RenamerCoercer]
-> Block A -> StateT [Statement A] Identity (Block A)
removeDecl [RenamerCoercer]
rcs (F.BlStatement A
a s :: SrcSpan
s@(FU.SrcSpan Position
p1 Position
_) Maybe (Expression A)
mlab (F.StDeclaration A
stA SrcSpan
stS TypeSpec A
typ Maybe (AList Attribute A)
attr AList Declarator A
decls)) = do
        ([Statement A] -> [Statement A])
-> StateT [Statement A] Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([Statement A] -> [Statement A] -> [Statement A]
forall a. [a] -> [a] -> [a]
++ [Statement A]
assgns)
        Block A -> StateT [Statement A] Identity (Block A)
forall (m :: * -> *) a. Monad m => a -> m a
return (Block A -> StateT [Statement A] Identity (Block A))
-> (Statement A -> Block A)
-> Statement A
-> StateT [Statement A] Identity (Block A)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. A -> SrcSpan -> Maybe (Expression A) -> Statement A -> Block A
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement A
a' SrcSpan
s' Maybe (Expression A)
mlab (Statement A -> StateT [Statement A] Identity (Block A))
-> Statement A -> StateT [Statement A] Identity (Block A)
forall a b. (a -> b) -> a -> b
$ A
-> SrcSpan
-> TypeSpec A
-> Maybe (AList Attribute A)
-> AList Declarator A
-> Statement A
forall a.
a
-> SrcSpan
-> TypeSpec a
-> Maybe (AList Attribute a)
-> AList Declarator a
-> Statement a
F.StDeclaration A
stA SrcSpan
stS TypeSpec A
typ Maybe (AList Attribute A)
attr AList Declarator A
decls'
      where
        (F.AList A
al SrcSpan
sl [Declarator A]
declsA) = AList Declarator A
decls
        decls' :: AList Declarator A
decls' = A -> SrcSpan -> [Declarator A] -> AList Declarator A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
al' SrcSpan
sl [Declarator A]
declsA'
        ([Statement A]
assgns, [Declarator A]
declsA') = (([Statement A], [Declarator A])
 -> Declarator A -> ([Statement A], [Declarator A]))
-> ([Statement A], [Declarator A])
-> [Declarator A]
-> ([Statement A], [Declarator A])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Statement A], [Declarator A])
-> Declarator A -> ([Statement A], [Declarator A])
matchVar ([],[]) [Declarator A]
declsA
        -- Update annotation if declarations are being added
        ((A
a', SrcSpan
s'), A
al')
          | [Declarator A] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Declarator A]
declsA'                     = ((A
a {refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
p1, deleteNode :: Bool
deleteNode = Bool
True}, SrcSpan -> SrcSpan
deleteLine SrcSpan
s),
                                                A
al {refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pl1})
          | [Declarator A] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Declarator A]
declsA' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Declarator A] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Declarator A]
declsA  = ((A
a {refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
p1}, SrcSpan
s), A
al {refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pl1})
          | Bool
otherwise                        = ((A
a, SrcSpan
s), A
al)
          where FU.SrcSpan Position
pl1 Position
_ = SrcSpan
sl

        matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A
                 -> ([F.Statement A], [F.Declarator A])
        -- match on variable or array declaration
        matchVar :: ([Statement A], [Declarator A])
-> Declarator A -> ([Statement A], [Declarator A])
matchVar ([Statement A]
assgnsNew, [Declarator A]
declsNew) Declarator A
dec = case Declarator A
dec of
          F.DeclVariable A
_ SrcSpan
_ lvar :: Expression A
lvar@(F.ExpValue A
_ SrcSpan
_ (F.ValVariable Directory
v)) Maybe (Expression A)
_ Maybe (Expression A)
init -> Expression A
-> Directory
-> Maybe (Expression A)
-> ([Statement A], [Declarator A])
doMatchVar Expression A
lvar Directory
v Maybe (Expression A)
init
          F.DeclArray A
_ SrcSpan
_ lvar :: Expression A
lvar@(F.ExpValue A
_ SrcSpan
_ (F.ValVariable Directory
v)) AList DimensionDeclarator A
_ Maybe (Expression A)
_ Maybe (Expression A)
init  -> Expression A
-> Directory
-> Maybe (Expression A)
-> ([Statement A], [Declarator A])
doMatchVar Expression A
lvar Directory
v Maybe (Expression A)
init
          Declarator A
_                                                                 -> ([Statement A]
assgnsNew, [Declarator A]
declsNew)
          where
            doMatchVar :: Expression A
-> Directory
-> Maybe (Expression A)
-> ([Statement A], [Declarator A])
doMatchVar Expression A
lvar Directory
v Maybe (Expression A)
init
              | Directory -> [RenamerCoercer] -> Bool
forall r. Renaming r => Directory -> r -> Bool
hasRenaming Directory
v [RenamerCoercer]
rcs = case Maybe (Expression A)
init of
                  -- Renaming exists and no default, then remove
                  Maybe (Expression A)
Nothing -> ([Statement A]
assgnsNew, [Declarator A]
declsNew)
                    -- Renaming exists but has default, so create an
                    -- assignment for this
                  Just Expression A
initExpr -> ((A -> SrcSpan -> Expression A -> Expression A -> Statement A
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
F.StExpressionAssign A
a' (Declarator A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Declarator A
dec) Expression A
lvar Expression A
initExpr) Statement A -> [Statement A] -> [Statement A]
forall a. a -> [a] -> [a]
: [Statement A]
assgnsNew, [Declarator A]
declsNew)
              | Bool
otherwise = ([Statement A]
assgnsNew, Declarator A
dec Declarator A -> [Declarator A] -> [Declarator A]
forall a. a -> [a] -> [a]
: [Declarator A]
declsNew)  -- no renaming, preserve declaration

    removeDecl [RenamerCoercer]
_ Block A
d = Block A -> StateT [Statement A] Identity (Block A)
forall (m :: * -> *) a. Monad m => a -> m a
return Block A
d


-- Adds additional statements to the start of the statement block in a program unit
addToProgramUnit ::
   PM.FortranVersion -> F.ProgramUnit A -> [F.Statement A] -> F.ProgramUnit A
addToProgramUnit :: FortranVersion -> ProgramUnit A -> [Statement A] -> ProgramUnit A
addToProgramUnit FortranVersion
v ProgramUnit A
pu [Statement A]
stmnts = ([Block A] -> [Block A]) -> ProgramUnit A -> ProgramUnit A
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi ([Block A] -> [Block A] -> [Block A]
addAfterDecls ((Statement A -> Block A) -> [Statement A] -> [Block A]
forall a b. (a -> b) -> [a] -> [b]
map Statement A -> Block A
toBlock [Statement A]
stmnts)) ProgramUnit A
pu
  where
    -- Find the point where blocks are non-executable statements
    -- and become executable statements/blocks
    addAfterDecls :: [F.Block A] -> [F.Block A] -> [F.Block A]
    addAfterDecls :: [Block A] -> [Block A] -> [Block A]
addAfterDecls []          [Block A]
ys = [Block A]
ys
    addAfterDecls [Block A
x]         [Block A]
ys = Block A
x Block A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
: [Block A]
ys
    addAfterDecls (Block A
x:(Block A
x':[Block A]
xs)) [Block A]
ys
      | FortranVersion -> Block A -> Bool
forall a. FortranVersion -> Block a -> Bool
F.nonExecutableStatementBlock FortranVersion
v Block A
x Bool -> Bool -> Bool
&& FortranVersion -> Block A -> Bool
forall a. FortranVersion -> Block a -> Bool
F.executableStatementBlock FortranVersion
v Block A
x'
                                 = Block A
x Block A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
: ([Block A]
ys [Block A] -> [Block A] -> [Block A]
forall a. [a] -> [a] -> [a]
++ (Block A
x' Block A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
: [Block A]
xs))
      | FortranVersion -> Block A -> Bool
forall a. FortranVersion -> Block a -> Bool
F.executableStatementBlock FortranVersion
v Block A
x = [Block A]
ys [Block A] -> [Block A] -> [Block A]
forall a. [a] -> [a] -> [a]
++ (Block A
xBlock A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
:(Block A
x'Block A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
:[Block A]
xs))

    addAfterDecls (Block A
x:[Block A]
xs) [Block A]
ys      = Block A
x Block A -> [Block A] -> [Block A]
forall a. a -> [a] -> [a]
: [Block A] -> [Block A] -> [Block A]
addAfterDecls [Block A]
xs [Block A]
ys

    -- Convert a statement to a simple 'Statement' block
    toBlock :: F.Statement A -> F.Block A
    toBlock :: Statement A -> Block A
toBlock Statement A
stmnt =
      A -> SrcSpan -> Maybe (Expression A) -> Statement A -> Block A
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement (Statement A -> A
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Statement A
stmnt) (Statement A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Statement A
stmnt) Maybe (Expression A)
forall a. Maybe a
Nothing Statement A
stmnt

getUnitStartPosition :: F.ProgramUnit A -> FU.SrcSpan
getUnitStartPosition :: ProgramUnit A -> SrcSpan
getUnitStartPosition (F.PUMain A
_ SrcSpan
s Maybe Directory
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUMain A
_ SrcSpan
_ Maybe Directory
_ [Block A]
bs Maybe [ProgramUnit A]
_) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUSubroutine A
_ SrcSpan
s PrefixSuffix A
_ Directory
_ Maybe (AList Expression A)
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUSubroutine A
_ SrcSpan
_ PrefixSuffix A
_ Directory
_ Maybe (AList Expression A)
_ [Block A]
bs Maybe [ProgramUnit A]
_) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUFunction A
_ SrcSpan
s Maybe (TypeSpec A)
_ PrefixSuffix A
_ Directory
_ Maybe (AList Expression A)
_ Maybe (Expression A)
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUFunction A
_ SrcSpan
_ Maybe (TypeSpec A)
_ PrefixSuffix A
_ Directory
_ Maybe (AList Expression A)
_ Maybe (Expression A)
_ [Block A]
bs Maybe [ProgramUnit A]
_) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUBlockData A
_ SrcSpan
s Maybe Directory
_ []) = SrcSpan
s
getUnitStartPosition (F.PUBlockData A
_ SrcSpan
_ Maybe Directory
_ [Block A]
bs) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUComment A
_ SrcSpan
s Comment A
_) = SrcSpan
s
getUnitStartPosition (F.PUModule A
_ SrcSpan
s Directory
_ [Block A]
_ Maybe [ProgramUnit A]
_) = SrcSpan
s

renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)]
renamerToUse :: RenamerCoercer -> [(Directory, Directory)]
renamerToUse RenamerCoercer
Nothing = []
renamerToUse (Just Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
m) = let entryToPair :: a -> (Maybe b, b) -> [(a, b)]
entryToPair a
_ (Maybe b
Nothing, b
_) = []
                            entryToPair a
v (Just b
v', b
_) = [(a
v, b
v')]
                        in ([(Directory, Directory)]
 -> Directory
 -> (Maybe Directory, Maybe (TypeInfo, TypeInfo))
 -> [(Directory, Directory)])
-> [(Directory, Directory)]
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> [(Directory, Directory)]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' (\[(Directory, Directory)]
xs Directory
v (Maybe Directory, Maybe (TypeInfo, TypeInfo))
e -> Directory
-> (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> [(Directory, Directory)]
forall a b b. a -> (Maybe b, b) -> [(a, b)]
entryToPair Directory
v (Maybe Directory, Maybe (TypeInfo, TypeInfo))
e [(Directory, Directory)]
-> [(Directory, Directory)] -> [(Directory, Directory)]
forall a. [a] -> [a] -> [a]
++ [(Directory, Directory)]
xs) [] Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
m

-- make the use statements for a particular program unit's common blocks
mkUseStatementBlocks :: FU.SrcSpan -> [(TCommon A, RenamerCoercer)] -> [F.Block A]
mkUseStatementBlocks :: SrcSpan -> [(TCommon a, RenamerCoercer)] -> [Block A]
mkUseStatementBlocks SrcSpan
s = ((TCommon a, RenamerCoercer) -> Block A)
-> [(TCommon a, RenamerCoercer)] -> [Block A]
forall a b. (a -> b) -> [a] -> [b]
map (TCommon a, RenamerCoercer) -> Block A
mkUseStmnt
  where
    a :: A
a = A
unitAnnotation { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pos, newNode :: Bool
newNode = Bool
True }
    (FU.SrcSpan Position
pos Position
pos') = SrcSpan
s
    s' :: SrcSpan
s' = Position -> Position -> SrcSpan
FU.SrcSpan (Position -> Position
toCol0 Position
pos) Position
pos'
    mkUseStmnt :: (TCommon a, RenamerCoercer) -> Block A
mkUseStmnt x :: (TCommon a, RenamerCoercer)
x@((Maybe Directory
name, [(Directory, TypeInfo)]
_), RenamerCoercer
_) = A -> SrcSpan -> Maybe (Expression A) -> Statement A -> Block A
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement A
a SrcSpan
s' Maybe (Expression A)
forall a. Maybe a
Nothing (Statement A -> Block A) -> Statement A -> Block A
forall a b. (a -> b) -> a -> b
$
       A
-> SrcSpan
-> Expression A
-> Maybe ModuleNature
-> Only
-> Maybe (AList Use A)
-> Statement A
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe ModuleNature
-> Only
-> Maybe (AList Use a)
-> Statement a
F.StUse A
a SrcSpan
s' Expression A
useName Maybe ModuleNature
forall a. Maybe a
Nothing Only
F.Permissive Maybe (AList Use A)
useListA
     where useName :: Expression A
useName = A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
s' (Directory -> Value A
forall a. Directory -> Value a
F.ValVariable (Directory -> Directory
caml (Maybe Directory -> Directory
commonName Maybe Directory
name)))
           useListA :: Maybe (AList Use A)
useListA = case [Use A]
useList of [] -> Maybe (AList Use A)
forall a. Maybe a
Nothing
                                      [Use A]
us -> AList Use A -> Maybe (AList Use A)
forall a. a -> Maybe a
Just (A -> SrcSpan -> [Use A] -> AList Use A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
a SrcSpan
s' ([Use A] -> [Use A]
forall a. [a] -> [a]
reverse [Use A]
us))
           useList :: [Use A]
useList = Position -> (TCommon a, RenamerCoercer) -> [Use A]
mkUses Position
pos (TCommon a, RenamerCoercer)
x

    mkUses :: FU.Position -> (TCommon A, RenamerCoercer) -> [F.Use A]
    mkUses :: Position -> (TCommon a, RenamerCoercer) -> [Use A]
mkUses Position
_ ((Maybe Directory
_, [(Directory, TypeInfo)]
_), RenamerCoercer
r) = ((Directory, Directory) -> Use A)
-> [(Directory, Directory)] -> [Use A]
forall a b. (a -> b) -> [a] -> [b]
map (Directory, Directory) -> Use A
useRenamer (RenamerCoercer -> [(Directory, Directory)]
renamerToUse RenamerCoercer
r)

    useRenamer :: (Directory, Directory) -> Use A
useRenamer (Directory
v, Directory
vR) = A -> SrcSpan -> Expression A -> Expression A -> Use A
forall a. a -> SrcSpan -> Expression a -> Expression a -> Use a
F.UseRename A
a SrcSpan
s' (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
s' (Directory -> Value A
forall a. Directory -> Value a
F.ValVariable Directory
v))
                                          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
s' (Directory -> Value A
forall a. Directory -> Value a
F.ValVariable Directory
vR))

mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer
mkRenamerCoercerTLC :: TLCommon A -> TLCommon A -> RenamerCoercer
mkRenamerCoercerTLC (Directory
_, (Directory
_, TCommon a
common1)) (Directory
_, (Directory
_, TCommon a
common2)) =
    TCommon a -> TCommon a -> RenamerCoercer
forall k k (source :: k) (target :: k).
TCommon a -> TCommon a -> RenamerCoercer
mkRenamerCoercer TCommon a
common1 TCommon a
common2

mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer
mkRenamerCoercer :: TCommon a -> TCommon a -> RenamerCoercer
mkRenamerCoercer (Maybe Directory
name1, [(Directory, TypeInfo)]
vtys1) (Maybe Directory
name2, [(Directory, TypeInfo)]
vtys2)
  | Maybe Directory
name1 Maybe Directory -> Maybe Directory -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Directory
name2 = if [(Directory, TypeInfo)]
vtys1 [(Directory, TypeInfo)] -> [(Directory, TypeInfo)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Directory, TypeInfo)]
vtys2 then RenamerCoercer
forall a. Maybe a
Nothing
                     else Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> RenamerCoercer
forall a. a -> Maybe a
Just (Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
 -> RenamerCoercer)
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> RenamerCoercer
forall a b. (a -> b) -> a -> b
$ [(Directory, TypeInfo)]
-> [(Directory, TypeInfo)]
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
-> Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
forall b k.
(Eq b, Ord k) =>
[(k, b)]
-> [(k, b)]
-> Map k (Maybe k, Maybe (b, b))
-> Map k (Maybe k, Maybe (b, b))
generate [(Directory, TypeInfo)]
vtys1 [(Directory, TypeInfo)]
vtys2 Map Directory (Maybe Directory, Maybe (TypeInfo, TypeInfo))
forall k a. Map k a
M.empty
  | Bool
otherwise      =
        Directory -> RenamerCoercer
forall a. HasCallStack => Directory -> a
error Directory
"Can't generate renamer between different common blocks\n"
      where
        generate :: [(k, b)]
-> [(k, b)]
-> Map k (Maybe k, Maybe (b, b))
-> Map k (Maybe k, Maybe (b, b))
generate [] [] Map k (Maybe k, Maybe (b, b))
theta = Map k (Maybe k, Maybe (b, b))
theta
        generate ((k
var1, b
ty1):[(k, b)]
vtys1') ((k
var2, b
ty2):[(k, b)]
vtys2') Map k (Maybe k, Maybe (b, b))
theta =
            [(k, b)]
-> [(k, b)]
-> Map k (Maybe k, Maybe (b, b))
-> Map k (Maybe k, Maybe (b, b))
generate [(k, b)]
vtys1' [(k, b)]
vtys2' (k
-> (Maybe k, Maybe (b, b))
-> Map k (Maybe k, Maybe (b, b))
-> Map k (Maybe k, Maybe (b, b))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
var1 (Maybe k
varR, Maybe (b, b)
typR) Map k (Maybe k, Maybe (b, b))
theta)
          where
             varR :: Maybe k
varR = if k
var1 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
var2 then Maybe k
forall a. Maybe a
Nothing else k -> Maybe k
forall a. a -> Maybe a
Just k
var2
             typR :: Maybe (b, b)
typR = if b
ty1  b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==  b
ty2 then Maybe (b, b)
forall a. Maybe a
Nothing else (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
ty1, b
ty2)
        generate [(k, b)]
_ [(k, b)]
_ Map k (Maybe k, Maybe (b, b))
_ = Directory -> Map k (Maybe k, Maybe (b, b))
forall a. HasCallStack => Directory -> a
error Directory
"Common blocks of different field length\n"

allCoherentCommons :: [TLCommon A] -> (String, Bool)
allCoherentCommons :: [TLCommon A] -> (Directory, Bool)
allCoherentCommons [TLCommon A]
commons =
   (Bool -> (TLCommon A, TLCommon A) -> (Directory, Bool))
-> Bool -> [(TLCommon A, TLCommon A)] -> (Directory, Bool)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Bool
p (TLCommon A
c1, TLCommon A
c2) -> TLCommon A -> TLCommon A -> (Directory, Bool)
coherentCommons TLCommon A
c1 TLCommon A
c2 (Directory, Bool)
-> (Bool -> (Directory, Bool)) -> (Directory, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
p' -> Bool -> (Directory, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> (Directory, Bool)) -> Bool -> (Directory, Bool)
forall a b. (a -> b) -> a -> b
$ Bool
p Bool -> Bool -> Bool
&& Bool
p')
     Bool
True ([TLCommon A] -> [(TLCommon A, TLCommon A)]
forall a. [a] -> [(a, a)]
pairs [TLCommon A]
commons)
   where
    -- Computes all pairwise combinations
    pairs :: [a] -> [(a, a)]
    pairs :: [a] -> [(a, a)]
pairs []     = []
    pairs (a
x:[a]
xs) = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (a -> [a]
forall a. a -> [a]
repeat a
x) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairs [a]
xs


coherentCommons :: TLCommon A -> TLCommon A -> (String, Bool)
coherentCommons :: TLCommon A -> TLCommon A -> (Directory, Bool)
coherentCommons (Directory
_, (Directory
_, (Maybe Directory
n1, [(Directory, TypeInfo)]
vtys1))) (Directory
_, (Directory
_, (Maybe Directory
n2, [(Directory, TypeInfo)]
vtys2))) =
    if Maybe Directory
n1 Maybe Directory -> Maybe Directory -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Directory
n2
    then [(Directory, TypeInfo)]
-> [(Directory, TypeInfo)] -> (Directory, Bool)
coherentCommons' [(Directory, TypeInfo)]
vtys1 [(Directory, TypeInfo)]
vtys2
    else Directory -> (Directory, Bool)
forall a. HasCallStack => Directory -> a
error (Directory -> (Directory, Bool)) -> Directory -> (Directory, Bool)
forall a b. (a -> b) -> a -> b
$ Directory
"Trying to compare differently named common blocks: "
               Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Maybe Directory -> Directory
forall a. Show a => a -> Directory
show Maybe Directory
n1 Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
" and " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Maybe Directory -> Directory
forall a. Show a => a -> Directory
show Maybe Directory
n2 Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"\n"

coherentCommons' ::  [(F.Name, TypeInfo)] -> [(F.Name, TypeInfo)] -> (String, Bool)
coherentCommons' :: [(Directory, TypeInfo)]
-> [(Directory, TypeInfo)] -> (Directory, Bool)
coherentCommons' []               []                = (Directory
"", Bool
True)
coherentCommons' ((Directory
var1, TypeInfo
ty1):[(Directory, TypeInfo)]
xs) ((Directory
var2, TypeInfo
ty2):[(Directory, TypeInfo)]
ys)
      | TypeInfo -> AnnotationFree TypeInfo
forall t. t -> AnnotationFree t
af TypeInfo
ty1 AnnotationFree TypeInfo -> AnnotationFree TypeInfo -> Bool
forall a. Eq a => a -> a -> Bool
== TypeInfo -> AnnotationFree TypeInfo
forall t. t -> AnnotationFree t
af TypeInfo
ty2 = let (Directory
r', Bool
c) = [(Directory, TypeInfo)]
-> [(Directory, TypeInfo)] -> (Directory, Bool)
coherentCommons' [(Directory, TypeInfo)]
xs [(Directory, TypeInfo)]
ys
                                           in (Directory
r', Bool
c Bool -> Bool -> Bool
&& Bool
True)
      | Bool
otherwise = let r :: Directory
r = Directory
var1 Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
":"
                          Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ FortranVersion -> BaseType -> Indentation -> Directory
forall t.
IndentablePretty t =>
FortranVersion -> t -> Indentation -> Directory
PP.pprintAndRender FortranVersion
PM.Fortran90 (TypeInfo -> BaseType
forall a b. (a, b) -> a
fst TypeInfo
ty1) Indentation
forall a. Maybe a
Nothing
                          Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"(" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ AnnotationFree TypeInfo -> Directory
forall a. Show a => a -> Directory
show (TypeInfo -> AnnotationFree TypeInfo
forall t. t -> AnnotationFree t
af TypeInfo
ty1) Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
")"
                          Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
" differs from " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
var2
                          Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
":" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ FortranVersion -> BaseType -> Indentation -> Directory
forall t.
IndentablePretty t =>
FortranVersion -> t -> Indentation -> Directory
PP.pprintAndRender FortranVersion
PM.Fortran90 (TypeInfo -> BaseType
forall a b. (a, b) -> a
fst TypeInfo
ty2) Indentation
forall a. Maybe a
Nothing
                          Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"(" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ AnnotationFree TypeInfo -> Directory
forall a. Show a => a -> Directory
show (TypeInfo -> AnnotationFree TypeInfo
forall t. t -> AnnotationFree t
af TypeInfo
ty2) Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
")" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"\n"
                        (Directory
r', Bool
_) = [(Directory, TypeInfo)]
-> [(Directory, TypeInfo)] -> (Directory, Bool)
coherentCommons' [(Directory, TypeInfo)]
xs [(Directory, TypeInfo)]
ys
                    in (Directory
r Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
r', Bool
False)
    -- TODO - give more information in the error
coherentCommons' [(Directory, TypeInfo)]
_ [(Directory, TypeInfo)]
_ = (Directory
"Common blocks of different field lengths", Bool
False)

introduceModules :: F.MetaInfo
                 -> Directory
                 -> [TLCommon A]
                 -> (String, [F.ProgramFile A])
introduceModules :: MetaInfo
-> Directory -> [TLCommon A] -> (Directory, [ProgramFile A])
introduceModules MetaInfo
meta Directory
dir [TLCommon A]
cenv =
    ([[TLCommon A]] -> (Directory, ProgramFile A))
-> [[[TLCommon A]]] -> (Directory, [ProgramFile A])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MetaInfo -> Directory -> TLCommon A -> (Directory, ProgramFile A)
mkModuleFile MetaInfo
meta Directory
dir (TLCommon A -> (Directory, ProgramFile A))
-> ([[TLCommon A]] -> TLCommon A)
-> [[TLCommon A]]
-> (Directory, ProgramFile A)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TLCommon A] -> TLCommon A
forall a. [a] -> a
head ([TLCommon A] -> TLCommon A)
-> ([[TLCommon A]] -> [TLCommon A]) -> [[TLCommon A]] -> TLCommon A
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TLCommon A]] -> [TLCommon A]
forall a. [a] -> a
head) ([TLCommon A] -> [[[TLCommon A]]]
groupSortCommonBlock [TLCommon A]
cenv)

mkModuleFile ::
  F.MetaInfo -> Directory -> TLCommon A -> (String, F.ProgramFile A)
mkModuleFile :: MetaInfo -> Directory -> TLCommon A -> (Directory, ProgramFile A)
mkModuleFile MetaInfo
meta Directory
dir (Directory
_, (Directory
_, (Maybe Directory
name, [(Directory, TypeInfo)]
varTys))) =
    (Directory
r, Directory -> ProgramFile A -> ProgramFile A
forall a. Directory -> ProgramFile a -> ProgramFile a
F.pfSetFilename Directory
path (ProgramFile A -> ProgramFile A) -> ProgramFile A -> ProgramFile A
forall a b. (a -> b) -> a -> b
$ MetaInfo -> [ProgramUnit A] -> ProgramFile A
forall a. MetaInfo -> [ProgramUnit a] -> ProgramFile a
F.ProgramFile MetaInfo
meta [ProgramUnit A
mod])
  where
    modname :: Directory
modname = Maybe Directory -> Directory
commonName Maybe Directory
name
    path :: Directory
path = Directory
dir Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
modname Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
".f90"
    r :: Directory
r = Directory
"Creating module " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
modname Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
" at " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
path Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"\n"
    mod :: ProgramUnit A
mod = Directory -> [(Directory, TypeInfo)] -> Directory -> ProgramUnit A
mkModule Directory
modname [(Directory, TypeInfo)]
varTys Directory
modname

mkModule :: String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A
mkModule :: Directory -> [(Directory, TypeInfo)] -> Directory -> ProgramUnit A
mkModule Directory
name [(Directory, TypeInfo)]
vtys Directory
fname =
    A
-> SrcSpan
-> Directory
-> [Block A]
-> Maybe [ProgramUnit A]
-> ProgramUnit A
forall a.
a
-> SrcSpan
-> Directory
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUModule A
a SrcSpan
sp (Directory -> Directory
caml Directory
fname) [Block A]
decls Maybe [ProgramUnit A]
forall a. Maybe a
Nothing
  where
    a :: A
a = A
unitAnnotation { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
loc, newNode :: Bool
newNode = Bool
True }
    loc :: Position
loc = Int
-> Int -> Int -> Directory -> Maybe (Int, Directory) -> Position
FU.Position Int
0 Int
0 Int
0 Directory
"" Maybe (Int, Directory)
forall a. Maybe a
Nothing
    sp :: SrcSpan
sp = Position -> Position -> SrcSpan
FU.SrcSpan Position
loc Position
loc
    toDeclBlock :: (Directory, TypeInfo) -> Block A
toDeclBlock (Directory
v, TypeInfo
t) = A -> SrcSpan -> Maybe (Expression A) -> Statement A -> Block A
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement A
a SrcSpan
sp Maybe (Expression A)
forall a. Maybe a
Nothing ((Directory, TypeInfo) -> Statement A
toStmt (Directory
v, TypeInfo
t))
    toStmt :: (Directory, TypeInfo) -> Statement A
toStmt (Directory
v, (BaseType
bt, ConstructType
ct)) = A
-> SrcSpan
-> TypeSpec A
-> Maybe (AList Attribute A)
-> AList Declarator A
-> Statement A
forall a.
a
-> SrcSpan
-> TypeSpec a
-> Maybe (AList Attribute a)
-> AList Declarator a
-> Statement a
F.StDeclaration A
a SrcSpan
sp (BaseType -> TypeSpec A
toTypeSpec BaseType
bt) Maybe (AList Attribute A)
attrs ((Directory, ConstructType) -> AList Declarator A
toDeclarator (Directory
v, ConstructType
ct))
    attrs :: Maybe (AList Attribute A)
attrs = AList Attribute A -> Maybe (AList Attribute A)
forall a. a -> Maybe a
Just (AList Attribute A -> Maybe (AList Attribute A))
-> AList Attribute A -> Maybe (AList Attribute A)
forall a b. (a -> b) -> a -> b
$ A -> SrcSpan -> [Attribute A] -> AList Attribute A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
a SrcSpan
sp [A -> SrcSpan -> Attribute A
forall a. a -> SrcSpan -> Attribute a
F.AttrSave A
a SrcSpan
sp]
    toTypeSpec :: BaseType -> TypeSpec A
toTypeSpec BaseType
t = A -> SrcSpan -> BaseType -> Maybe (Selector A) -> TypeSpec A
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
F.TypeSpec A
a SrcSpan
sp BaseType
t Maybe (Selector A)
forall a. Maybe a
Nothing
    toDeclarator :: (Directory, ConstructType) -> AList Declarator A
toDeclarator (Directory
v, ConstructType
FA.CTVariable) = A -> SrcSpan -> [Declarator A] -> AList Declarator A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
a SrcSpan
sp
       [A
-> SrcSpan
-> Expression A
-> Maybe (Expression A)
-> Maybe (Expression A)
-> Declarator A
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclVariable A
a SrcSpan
sp
          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Directory -> Value A
forall a. Directory -> Value a
F.ValVariable (Directory -> Directory
caml Directory
name Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"_" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
v))) Maybe (Expression A)
forall a. Maybe a
Nothing Maybe (Expression A)
forall a. Maybe a
Nothing]
    toDeclarator (Directory
v, FA.CTArray [(Indentation, Indentation)]
dims) = A -> SrcSpan -> [Declarator A] -> AList Declarator A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
a SrcSpan
sp
       [A
-> SrcSpan
-> Expression A
-> AList DimensionDeclarator A
-> Maybe (Expression A)
-> Maybe (Expression A)
-> Declarator A
forall a.
a
-> SrcSpan
-> Expression a
-> AList DimensionDeclarator a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclArray A
a SrcSpan
sp
          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Directory -> Value A
forall a. Directory -> Value a
F.ValVariable (Directory -> Directory
caml Directory
name Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
"_" Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ Directory
v))) AList DimensionDeclarator A
dimDecls Maybe (Expression A)
forall a. Maybe a
Nothing Maybe (Expression A)
forall a. Maybe a
Nothing]
       where
         dimDecls :: AList DimensionDeclarator A
dimDecls = A
-> SrcSpan
-> [DimensionDeclarator A]
-> AList DimensionDeclarator A
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A
a SrcSpan
sp ([DimensionDeclarator A] -> AList DimensionDeclarator A)
-> (((Indentation, Indentation) -> DimensionDeclarator A)
    -> [DimensionDeclarator A])
-> ((Indentation, Indentation) -> DimensionDeclarator A)
-> AList DimensionDeclarator A
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Indentation, Indentation) -> DimensionDeclarator A)
 -> [(Indentation, Indentation)] -> [DimensionDeclarator A])
-> [(Indentation, Indentation)]
-> ((Indentation, Indentation) -> DimensionDeclarator A)
-> [DimensionDeclarator A]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Indentation, Indentation) -> DimensionDeclarator A)
-> [(Indentation, Indentation)] -> [DimensionDeclarator A]
forall a b. (a -> b) -> [a] -> [b]
map [(Indentation, Indentation)]
dims (((Indentation, Indentation) -> DimensionDeclarator A)
 -> AList DimensionDeclarator A)
-> ((Indentation, Indentation) -> DimensionDeclarator A)
-> AList DimensionDeclarator A
forall a b. (a -> b) -> a -> b
$ \ (Indentation
lb, Indentation
ub) -> A
-> SrcSpan
-> Maybe (Expression A)
-> Maybe (Expression A)
-> DimensionDeclarator A
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> DimensionDeclarator a
F.DimensionDeclarator A
a SrcSpan
sp ((Int -> Expression A) -> Indentation -> Maybe (Expression A)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Expression A
expr Indentation
lb) ((Int -> Expression A) -> Indentation -> Maybe (Expression A)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Expression A
expr Indentation
ub)
         expr :: Int -> Expression A
expr = A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Value A -> Expression A)
-> (Int -> Value A) -> Int -> Expression A
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> Value A
forall a. Directory -> Value a
F.ValInteger (Directory -> Value A) -> (Int -> Directory) -> Int -> Value A
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Directory
forall a. Show a => a -> Directory
show
    toDeclarator (Directory
_, ConstructType
ct) = Directory -> AList Declarator A
forall a. HasCallStack => Directory -> a
error (Directory -> AList Declarator A)
-> Directory -> AList Declarator A
forall a b. (a -> b) -> a -> b
$ Directory
"mkModule: toDeclarator: bad construct type: " Directory -> Directory -> Directory
forall a. [a] -> [a] -> [a]
++ ConstructType -> Directory
forall a. Show a => a -> Directory
show ConstructType
ct
    decls :: [Block A]
decls = ((Directory, TypeInfo) -> Block A)
-> [(Directory, TypeInfo)] -> [Block A]
forall a b. (a -> b) -> [a] -> [b]
map (Directory, TypeInfo) -> Block A
toDeclBlock [(Directory, TypeInfo)]
vtys