{-
   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 #-}
{-# LANGUAGE LambdaCase #-}

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.SemanticTypes as FAS
import qualified Language.Fortran.Analysis.Renaming as FAR
import qualified Language.Fortran.Analysis.Types as FAT
import qualified Language.Fortran.Version as F
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 = (FAS.SemType, 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 :: Name
-> [ProgramFile A]
-> PureAnalysis Void Void ([ProgramFile A], [ProgramFile A])
commonElimToModules Name
d [ProgramFile A]
pfs = do
  let ([ProgramFile A]
pfs', (Name
r, [TLCommon Any]
cg)) = State (Name, [TLCommon Any]) [ProgramFile A]
-> (Name, [TLCommon Any])
-> ([ProgramFile A], (Name, [TLCommon Any]))
forall s a. State s a -> s -> (a, s)
runState ([ProgramFile A] -> State (Name, [TLCommon Any]) [ProgramFile A]
analyseAndRmCommons [ProgramFile A]
pfs) (Name
"", [])
      (Name
r', [ProgramFile A]
pfM)       = MetaInfo -> Name -> [TLCommon Any] -> (Name, [ProgramFile A])
introduceModules MetaInfo
meta Name
d [TLCommon Any]
cg
      pfs'' :: [ProgramFile A]
pfs''           = [ProgramFile A] -> [TLCommon Any] -> [ProgramFile A]
updateUseDecls [ProgramFile A]
pfs' [TLCommon Any]
cg
  [ProgramFile A] -> Text -> AnalysisT Void Void Identity ()
forall a. Spanned a => 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
$ Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
r Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
r'
  ([ProgramFile A], [ProgramFile A])
-> PureAnalysis Void Void ([ProgramFile A], [ProgramFile A])
forall a. a -> AnalysisT Void Void Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ProgramFile A]
pfs'', [ProgramFile A]
pfM)
  where
    meta :: MetaInfo
meta = FortranVersion -> Name -> MetaInfo
F.MetaInfo FortranVersion
F.Fortran90 Name
""

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

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

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

collectAndRmCommons :: FAT.TypeEnv -> Filename -> F.ProgramUnitName
               -> F.Block A1 -> CommonState (F.Block A1)
collectAndRmCommons :: TypeEnv
-> Name
-> ProgramUnitName
-> Block A1
-> StateT (Name, [TLCommon Any]) Identity (Block A1)
collectAndRmCommons TypeEnv
tenv Name
fname ProgramUnitName
pname = (Statement A1
 -> StateT (Name, [TLCommon Any]) Identity (Statement A1))
-> Block A1 -> StateT (Name, [TLCommon Any]) Identity (Block A1)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Statement A1
-> StateT (Name, [TLCommon Any]) Identity (Statement A1)
commons
  where
    commons :: F.Statement A1 -> CommonState (F.Statement A1)
    commons :: Statement A1
-> StateT (Name, [TLCommon Any]) Identity (Statement A1)
commons (F.StCommon A1
a s :: SrcSpan
s@(FU.SrcSpan Position
p1 Position
_) AList CommonGroup A1
cgrps) = do
        (CommonGroup A1 -> StateT (Name, [TLCommon Any]) Identity ())
-> [CommonGroup A1] -> StateT (Name, [TLCommon Any]) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CommonGroup A1 -> StateT (Name, [TLCommon Any]) Identity ()
commonGroups (AList CommonGroup A1 -> [CommonGroup A1]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList CommonGroup A1
cgrps)
        let a' :: A1
a' = (A -> A) -> A1 -> A1
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}) A1
a
        Statement A1
-> StateT (Name, [TLCommon Any]) Identity (Statement A1)
forall a. a -> StateT (Name, [TLCommon Any]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement A1
 -> StateT (Name, [TLCommon Any]) Identity (Statement A1))
-> Statement A1
-> StateT (Name, [TLCommon Any]) Identity (Statement A1)
forall a b. (a -> b) -> a -> b
$ A1 -> SrcSpan -> AList CommonGroup A1 -> Statement A1
forall a. a -> SrcSpan -> AList CommonGroup a -> Statement a
F.StCommon A1
a' (SrcSpan -> SrcSpan
deleteLine SrcSpan
s) (A1 -> SrcSpan -> [CommonGroup A1] -> AList CommonGroup A1
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList A1
a SrcSpan
s [])
    commons Statement A1
f = Statement A1
-> StateT (Name, [TLCommon Any]) Identity (Statement A1)
forall a. a -> StateT (Name, [TLCommon Any]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Statement A1
f

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

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

    typeCommonExprs :: F.Declarator A1 -> (F.Name, TypeInfo)
    typeCommonExprs :: Declarator A1 -> (Name, TypeInfo)
typeCommonExprs (F.Declarator A1
_ SrcSpan
sp Expression A1
nameExpr DeclaratorType A1
_ Maybe (Expression A1)
_ Maybe (Expression A1)
_) =
        let var :: Name
var = Expression A1 -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression A1
nameExpr
            src :: Name
src = Expression A1 -> Name
forall a. Expression (Analysis a) -> Name
FA.srcName Expression A1
nameExpr
         in case Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
var TypeEnv
tenv of
              Just (FA.IDType (Just SemType
t) (Just ct :: ConstructType
ct@ConstructType
FA.CTVariable)) -> (Name
src, (SemType
t, ConstructType
ct))
              Just (FA.IDType (Just SemType
t) (Just ct :: ConstructType
ct@FA.CTArray{}))  -> (Name
src, (SemType
t, ConstructType
ct))
              Maybe IDType
_ -> Name -> (Name, TypeInfo)
forall a. HasCallStack => Name -> a
error (Name -> (Name, TypeInfo)) -> Name -> (Name, TypeInfo)
forall a b. (a -> b) -> a -> b
$ Name
"Variable '" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
src
                        Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"' is of an unknown or higher-order type at: "
                        Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
sp Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Maybe IDType -> Name
forall a. Show a => a -> Name
show (Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
var TypeEnv
tenv)

{- Comparison functions for common block names and variables -}
cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering
cmpTLConFName :: forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConFName (Name
f1, (Name
_, (Maybe Name, [(Name, TypeInfo)])
_)) (Name
f2, (Name
_, (Maybe Name, [(Name, TypeInfo)])
_)) = Name -> Name -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Name
f1 Name
f2

cmpTLConPName :: TLCommon a -> TLCommon a -> Ordering
cmpTLConPName :: forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConPName (Name
_, (Name
p1, (Maybe Name, [(Name, TypeInfo)])
_)) (Name
_, (Name
p2, (Maybe Name, [(Name, TypeInfo)])
_)) = Name -> Name -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Name
p1 Name
p2

cmpTLConBNames :: TLCommon a -> TLCommon a -> Ordering
cmpTLConBNames :: forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConBNames (Name
_, (Name
_, (Maybe Name, [(Name, TypeInfo)])
c1)) (Name
_, (Name
_, (Maybe Name, [(Name, TypeInfo)])
c2)) = (Maybe Name, [(Name, TypeInfo)])
-> (Maybe Name, [(Name, TypeInfo)]) -> Ordering
forall {k} (a :: k).
(Maybe Name, [(Name, TypeInfo)])
-> (Maybe Name, [(Name, TypeInfo)]) -> Ordering
cmpTConBNames (Maybe Name, [(Name, TypeInfo)])
c1 (Maybe Name, [(Name, TypeInfo)])
c2

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

cmpVarName :: TLCommon a -> TLCommon a -> Ordering
cmpVarName :: forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpVarName (Name
_, (Name
_, (Maybe Name
_, [(Name, TypeInfo)]
vtys1))) (Name
_, (Name
_, (Maybe Name
_, [(Name, TypeInfo)]
vtys2))) =
  ((Name, TypeInfo) -> Name) -> [(Name, TypeInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TypeInfo) -> Name
forall a b. (a, b) -> a
fst [(Name, TypeInfo)]
vtys1 [Name] -> [Name] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ((Name, TypeInfo) -> Name) -> [(Name, TypeInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TypeInfo) -> Name
forall a b. (a, b) -> a
fst [(Name, 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 Name -> Name
commonName = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"Common"

commonNameFromAST :: Maybe (F.Expression a) -> Maybe F.Name
commonNameFromAST :: forall a. Maybe (Expression a) -> Maybe Name
commonNameFromAST (Just (F.ExpValue a
_ SrcSpan
_ (F.ValVariable Name
v))) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
v
commonNameFromAST Maybe (Expression a)
_ = Maybe Name
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 Any -> (TLCommon Any, RenamerCoercer)
freshenCommonNames (Name
fname, (Name
pname, (Maybe Name
cname, [(Name, TypeInfo)]
fields))) =
        let mkRenamerAndCommon :: (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
 [(Name, TypeInfo)])
-> (Name, TypeInfo)
-> (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
    [(Name, TypeInfo)])
mkRenamerAndCommon (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
r, [(Name, TypeInfo)]
tc) (Name
v, TypeInfo
t) =
                           let v' :: Name
v' = Name -> Name
caml (Maybe Name -> Name
commonName Maybe Name
cname) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"_" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
v
                           in (Name
-> (Maybe Name, Maybe (TypeInfo, TypeInfo))
-> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
-> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
v (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
v', Maybe (TypeInfo, TypeInfo)
forall a. Maybe a
Nothing) Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
r, (Name
v', TypeInfo
t) (Name, TypeInfo) -> [(Name, TypeInfo)] -> [(Name, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Name, TypeInfo)]
tc)
            (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
rmap, [(Name, TypeInfo)]
fields') = ((Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
  [(Name, TypeInfo)])
 -> (Name, TypeInfo)
 -> (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
     [(Name, TypeInfo)]))
-> (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
    [(Name, TypeInfo)])
-> [(Name, TypeInfo)]
-> (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
    [(Name, TypeInfo)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
 [(Name, TypeInfo)])
-> (Name, TypeInfo)
-> (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)),
    [(Name, TypeInfo)])
mkRenamerAndCommon (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
forall k a. Map k a
M.empty, []) [(Name, TypeInfo)]
fields
        in ((Name
fname, (Name
pname, (Maybe Name
cname, [(Name, TypeInfo)]
fields'))), Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)) -> RenamerCoercer
forall a. a -> Maybe a
Just Map Name (Maybe Name, 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 Any] -> [[[TLCommon Any]]]
groupSortCommonBlock [TLCommon Any]
commons = [[[TLCommon Any]]]
gccs
  where
    -- Group by names of the common blocks
    gcs :: [[TLCommon Any]]
gcs = [TLCommon Any] -> [[TLCommon Any]]
groupCommonBlocksByName [TLCommon Any]
commons
    -- Group within by the different common block variable-type fields
    gccs :: [[[TLCommon Any]]]
gccs = ([TLCommon Any] -> [[TLCommon Any]])
-> [[TLCommon Any]] -> [[[TLCommon Any]]]
forall a b. (a -> b) -> [a] -> [b]
map (([TLCommon Any] -> [TLCommon Any] -> Ordering)
-> [[TLCommon Any]] -> [[TLCommon Any]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\[TLCommon Any]
y [TLCommon Any]
x -> [TLCommon Any] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TLCommon Any]
x Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [TLCommon Any] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TLCommon Any]
y) ([[TLCommon Any]] -> [[TLCommon Any]])
-> ([TLCommon Any] -> [[TLCommon Any]])
-> [TLCommon Any]
-> [[TLCommon Any]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TLCommon Any] -> [[TLCommon Any]]
forall a. Eq a => [a] -> [[a]]
group ([TLCommon Any] -> [[TLCommon Any]])
-> ([TLCommon Any] -> [TLCommon Any])
-> [TLCommon Any]
-> [[TLCommon Any]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TLCommon Any -> TLCommon Any -> Ordering)
-> [TLCommon Any] -> [TLCommon Any]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy TLCommon Any -> TLCommon Any -> Ordering
forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpVarName) [[TLCommon Any]]
gcs

groupCommonBlocksByName :: [TLCommon A] -> [[TLCommon A]]
groupCommonBlocksByName :: [TLCommon Any] -> [[TLCommon Any]]
groupCommonBlocksByName [TLCommon Any]
commons =
    (TLCommon Any -> TLCommon Any -> Bool)
-> [TLCommon Any] -> [[TLCommon Any]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\TLCommon Any
x TLCommon Any
y -> Ordering -> Bool
cmpEq (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ TLCommon Any -> TLCommon Any -> Ordering
forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConBNames TLCommon Any
x TLCommon Any
y) [TLCommon Any]
commons
  where
    cmpEq :: Ordering -> Bool
cmpEq = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ)

mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)]
mkTLCommonRenamers :: [TLCommon Any] -> [(TLCommon Any, RenamerCoercer)]
mkTLCommonRenamers [TLCommon Any]
commons =
    case [TLCommon Any] -> (Name, Bool)
allCoherentCommons [TLCommon Any]
commons of
      (Name
r, Bool
False) -> Name -> [(TLCommon Any, RenamerCoercer)]
forall a. HasCallStack => Name -> a
error (Name -> [(TLCommon Any, RenamerCoercer)])
-> Name -> [(TLCommon Any, RenamerCoercer)]
forall a b. (a -> b) -> a -> b
$ Name
"Common blocks are incoherent!\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
r
      (Name
_, Bool
True) -> [(TLCommon Any, RenamerCoercer)]
commons'
  where
    gccs :: [[[TLCommon Any]]]
gccs = [TLCommon Any] -> [[[TLCommon Any]]]
groupSortCommonBlock [TLCommon Any]
commons
    -- Find the "mode" common block and freshen the names for
    -- this, creating a renamer between this and every module
    gcrcs :: [[(TLCommon Any, RenamerCoercer)]]
gcrcs = ([[TLCommon Any]] -> [(TLCommon Any, RenamerCoercer)])
-> [[[TLCommon Any]]] -> [[(TLCommon Any, RenamerCoercer)]]
forall a b. (a -> b) -> [a] -> [b]
map (\[[TLCommon Any]]
grp -> -- grp are block decls all for the same block
             let (TLCommon Any
com, RenamerCoercer
r) = TLCommon Any -> (TLCommon Any, RenamerCoercer)
freshenCommonNames ([TLCommon Any] -> TLCommon Any
forall a. HasCallStack => [a] -> a
head ([[TLCommon Any]] -> [TLCommon Any]
forall a. HasCallStack => [a] -> a
head [[TLCommon Any]]
grp))
             in  (TLCommon Any -> (TLCommon Any, RenamerCoercer))
-> [TLCommon Any] -> [(TLCommon Any, RenamerCoercer)]
forall a b. (a -> b) -> [a] -> [b]
map (\TLCommon Any
c -> (TLCommon Any
c, RenamerCoercer
r)) ([[TLCommon Any]] -> [TLCommon Any]
forall a. HasCallStack => [a] -> a
head [[TLCommon Any]]
grp) [(TLCommon Any, RenamerCoercer)]
-> [(TLCommon Any, RenamerCoercer)]
-> [(TLCommon Any, RenamerCoercer)]
forall a. [a] -> [a] -> [a]
++
                  (TLCommon Any -> (TLCommon Any, RenamerCoercer))
-> [TLCommon Any] -> [(TLCommon Any, RenamerCoercer)]
forall a b. (a -> b) -> [a] -> [b]
map (\TLCommon Any
c -> (TLCommon Any
c, TLCommon Any -> TLCommon Any -> RenamerCoercer
forall {k} {k} (source :: k) (target :: k).
TLCommon Any -> TLCommon Any -> RenamerCoercer
mkRenamerCoercerTLC TLCommon Any
c TLCommon Any
com)) ([[TLCommon Any]] -> [TLCommon Any]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TLCommon Any]] -> [TLCommon Any])
-> [[TLCommon Any]] -> [TLCommon Any]
forall a b. (a -> b) -> a -> b
$ [[TLCommon Any]] -> [[TLCommon Any]]
forall a. HasCallStack => [a] -> [a]
tail [[TLCommon Any]]
grp)) [[[TLCommon Any]]]
gccs
    -- Now re-sort based on the file and program unit
    commons' :: [(TLCommon Any, RenamerCoercer)]
commons' = ((TLCommon Any, RenamerCoercer)
 -> (TLCommon Any, RenamerCoercer) -> Ordering)
-> [(TLCommon Any, RenamerCoercer)]
-> [(TLCommon Any, RenamerCoercer)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TLCommon Any -> TLCommon Any -> Ordering)
-> (TLCommon Any, RenamerCoercer)
-> (TLCommon Any, RenamerCoercer)
-> Ordering
forall {b} {c} {b}. (b -> b -> c) -> (b, b) -> (b, b) -> c
cmpFst TLCommon Any -> TLCommon Any -> Ordering
forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConFName) (((TLCommon Any, RenamerCoercer)
 -> (TLCommon Any, RenamerCoercer) -> Ordering)
-> [(TLCommon Any, RenamerCoercer)]
-> [(TLCommon Any, RenamerCoercer)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TLCommon Any -> TLCommon Any -> Ordering)
-> (TLCommon Any, RenamerCoercer)
-> (TLCommon Any, RenamerCoercer)
-> Ordering
forall {b} {c} {b}. (b -> b -> c) -> (b, b) -> (b, b) -> c
cmpFst TLCommon Any -> TLCommon Any -> Ordering
forall {k} (a :: k). TLCommon Any -> TLCommon Any -> Ordering
cmpTLConPName) ([[(TLCommon Any, RenamerCoercer)]]
-> [(TLCommon Any, RenamerCoercer)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(TLCommon Any, 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 :: Name -> RenamerCoercer -> Bool
hasRenaming Name
_ RenamerCoercer
Nothing   = Bool
False
    hasRenaming Name
v (Just Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
rc) = Name -> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Name
v Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
rc

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

updateUseDecls ::
  [F.ProgramFile A] -> [TLCommon A] -> [F.ProgramFile A]
updateUseDecls :: [ProgramFile A] -> [TLCommon Any] -> [ProgramFile A]
updateUseDecls [ProgramFile A]
fps [TLCommon Any]
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 Name
_) [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 -> Name -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v (ProgramFile a -> Name
forall a. ProgramFile a -> Name
F.pfGetFilename ProgramFile a
p)) ProgramFile a
p
    tcrs :: [(TLCommon Any, RenamerCoercer)]
tcrs = [TLCommon Any] -> [(TLCommon Any, RenamerCoercer)]
mkTLCommonRenamers [TLCommon Any]
tcs

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

    importIncludeCommons :: F.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A
    importIncludeCommons :: FortranVersion -> ProgramUnit A -> ProgramUnit A
importIncludeCommons FortranVersion
v ProgramUnit A
p =
        (ProgramUnit A -> Name -> ProgramUnit A)
-> ProgramUnit A -> [Name] -> ProgramUnit A
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name -> ProgramUnit A -> ProgramUnit A)
-> ProgramUnit A -> Name -> ProgramUnit A
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FortranVersion -> Name -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v)) ProgramUnit A
p ((Statement A -> Maybe Name) -> ProgramUnit A -> [Name]
forall s t a.
(Data s, Data t, Uniplate t, Biplate t s) =>
(s -> Maybe a) -> t -> [a]
reduceCollect Statement A -> Maybe Name
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 :: forall s t a.
(Data s, Data t, Uniplate t, Biplate t s) =>
(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 a. a -> WriterT [a] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                                           s -> WriterT [a] Identity s
forall a. a -> WriterT [a] Identity a
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 :: F.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A
    matchPUnit :: FortranVersion -> Name -> ProgramUnit A -> ProgramUnit A
matchPUnit FortranVersion
v Name
fname ProgramUnit A
p =
        FortranVersion
-> [RenamerCoercer] -> ProgramUnit A -> ProgramUnit A
removeDecls FortranVersion
v ((((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)
 -> RenamerCoercer)
-> [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
-> [RenamerCoercer]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)
-> RenamerCoercer
forall a b. (a, b) -> b
snd [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
tcrs') ProgramUnit A
p'
      where
        pname :: Name
pname = case ProgramUnit A -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit A
p of
                  F.Named Name
n -> Name
n
                   -- If no subname is available, use the filename
                  ProgramUnitName
_         -> Name
fname
        tcrs' :: [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
tcrs' = Name
-> [((Name, (Maybe Name, [(Name, TypeInfo)])), RenamerCoercer)]
-> [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
forall a b c. Eq a => a -> [((a, b), c)] -> [(b, c)]
lookups Name
pname (Name
-> [(TLCommon Any, RenamerCoercer)]
-> [((Name, (Maybe Name, [(Name, TypeInfo)])), RenamerCoercer)]
forall a b c. Eq a => a -> [((a, b), c)] -> [(b, c)]
lookups Name
fname [(TLCommon Any, RenamerCoercer)]
tcrs)
        pos :: SrcSpan
pos = ProgramUnit A -> SrcSpan
getUnitStartPosition ProgramUnit A
p
        uses :: [Block A]
uses = SrcSpan
-> [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
-> [Block A]
mkUseStatementBlocks SrcSpan
pos [((Maybe Name, [(Name, TypeInfo)]), 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 :: forall a b c. Eq a => 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 :: F.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 a. a -> StateT [Statement A] Identity 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. [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 a. [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 a. [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 declaration (care not whether scalar or array)
        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.Declarator A
_ SrcSpan
_ lvar :: Expression A
lvar@(F.ExpValue A
_ SrcSpan
_ (F.ValVariable Name
v)) DeclaratorType A
_ Maybe (Expression A)
_ Maybe (Expression A)
init  -> Expression A
-> Name -> Maybe (Expression A) -> ([Statement A], [Declarator A])
doMatchVar Expression A
lvar Name
v Maybe (Expression A)
init
          Declarator A
_                                                                 -> ([Statement A]
assgnsNew, [Declarator A]
declsNew)
          where
            doMatchVar :: Expression A
-> Name -> Maybe (Expression A) -> ([Statement A], [Declarator A])
doMatchVar Expression A
lvar Name
v Maybe (Expression A)
init
              | Name -> [RenamerCoercer] -> Bool
forall r. Renaming r => Name -> r -> Bool
hasRenaming Name
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 a. a -> StateT [Statement A] Identity 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 ::
   F.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 a. 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 Name
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUMain A
_ SrcSpan
_ Maybe Name
_ [Block A]
bs Maybe [ProgramUnit A]
_) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. HasCallStack => [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUSubroutine A
_ SrcSpan
s PrefixSuffix A
_ Name
_ Maybe (AList Expression A)
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUSubroutine A
_ SrcSpan
_ PrefixSuffix A
_ Name
_ 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. HasCallStack => [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUFunction A
_ SrcSpan
s Maybe (TypeSpec A)
_ PrefixSuffix A
_ Name
_ Maybe (AList Expression A)
_ Maybe (Expression A)
_ [] Maybe [ProgramUnit A]
_) = SrcSpan
s
getUnitStartPosition (F.PUFunction A
_ SrcSpan
_ Maybe (TypeSpec A)
_ PrefixSuffix A
_ Name
_ 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. HasCallStack => [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUBlockData A
_ SrcSpan
s Maybe Name
_ []) = SrcSpan
s
getUnitStartPosition (F.PUBlockData A
_ SrcSpan
_ Maybe Name
_ [Block A]
bs) = Block A -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan ([Block A] -> Block A
forall a. HasCallStack => [a] -> a
head [Block A]
bs)
getUnitStartPosition (F.PUComment A
_ SrcSpan
s Comment A
_) = SrcSpan
s
getUnitStartPosition (F.PUModule A
_ SrcSpan
s Name
_ [Block A]
_ Maybe [ProgramUnit A]
_) = SrcSpan
s

renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)]
renamerToUse :: RenamerCoercer -> [(Name, Name)]
renamerToUse RenamerCoercer
Nothing = []
renamerToUse (Just Map Name (Maybe Name, 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 ([(Name, Name)]
 -> Name
 -> (Maybe Name, Maybe (TypeInfo, TypeInfo))
 -> [(Name, Name)])
-> [(Name, Name)]
-> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
-> [(Name, Name)]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' (\[(Name, Name)]
xs Name
v (Maybe Name, Maybe (TypeInfo, TypeInfo))
e -> Name -> (Maybe Name, Maybe (TypeInfo, TypeInfo)) -> [(Name, Name)]
forall {a} {b} {b}. a -> (Maybe b, b) -> [(a, b)]
entryToPair Name
v (Maybe Name, Maybe (TypeInfo, TypeInfo))
e [(Name, Name)] -> [(Name, Name)] -> [(Name, Name)]
forall a. [a] -> [a] -> [a]
++ [(Name, Name)]
xs) [] Map Name (Maybe Name, 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
-> [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
-> [Block A]
mkUseStatementBlocks SrcSpan
s = (((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer) -> Block A)
-> [((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)]
-> [Block A]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Name, [(Name, TypeInfo)]), 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 :: ((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer) -> Block A
mkUseStmnt x :: ((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)
x@((Maybe Name
name, [(Name, 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' (Name -> Value A
forall a. Name -> Value a
F.ValVariable (Name -> Name
caml (Maybe Name -> Name
commonName Maybe Name
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
-> ((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer) -> [Use A]
mkUses Position
pos ((Maybe Name, [(Name, TypeInfo)]), RenamerCoercer)
x

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

    useRenamer :: (Name, Name) -> Use A
useRenamer (Name
v, Name
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' (Name -> Value A
forall a. Name -> Value a
F.ValVariable Name
v))
                                          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
s' (Name -> Value A
forall a. Name -> Value a
F.ValVariable Name
vR))

mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer
mkRenamerCoercerTLC :: forall {k} {k} (source :: k) (target :: k).
TLCommon Any -> TLCommon Any -> RenamerCoercer
mkRenamerCoercerTLC (Name
_, (Name
_, (Maybe Name, [(Name, TypeInfo)])
common1)) (Name
_, (Name
_, (Maybe Name, [(Name, TypeInfo)])
common2)) =
    (Maybe Name, [(Name, TypeInfo)])
-> (Maybe Name, [(Name, TypeInfo)]) -> RenamerCoercer
forall {k} {k} (source :: k) (target :: k).
(Maybe Name, [(Name, TypeInfo)])
-> (Maybe Name, [(Name, TypeInfo)]) -> RenamerCoercer
mkRenamerCoercer (Maybe Name, [(Name, TypeInfo)])
common1 (Maybe Name, [(Name, TypeInfo)])
common2

mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer
mkRenamerCoercer :: forall {k} {k} (source :: k) (target :: k).
(Maybe Name, [(Name, TypeInfo)])
-> (Maybe Name, [(Name, TypeInfo)]) -> RenamerCoercer
mkRenamerCoercer (Maybe Name
name1, [(Name, TypeInfo)]
vtys1) (Maybe Name
name2, [(Name, TypeInfo)]
vtys2)
  | Maybe Name
name1 Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Name
name2 = if [(Name, TypeInfo)]
vtys1 [(Name, TypeInfo)] -> [(Name, TypeInfo)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Name, TypeInfo)]
vtys2 then RenamerCoercer
forall a. Maybe a
Nothing
                     else Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo)) -> RenamerCoercer
forall a. a -> Maybe a
Just (Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
 -> RenamerCoercer)
-> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
-> RenamerCoercer
forall a b. (a -> b) -> a -> b
$ [(Name, TypeInfo)]
-> [(Name, TypeInfo)]
-> Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
-> Map Name (Maybe Name, 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 [(Name, TypeInfo)]
vtys1 [(Name, TypeInfo)]
vtys2 Map Name (Maybe Name, Maybe (TypeInfo, TypeInfo))
forall k a. Map k a
M.empty
  | Bool
otherwise      =
        Name -> RenamerCoercer
forall a. HasCallStack => Name -> a
error Name
"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))
_ = Name -> Map k (Maybe k, Maybe (b, b))
forall a. HasCallStack => Name -> a
error Name
"Common blocks of different field length\n"

-- Checks whether all commons of the same name (i.e., across program units)
-- are coherent with regards their types, returning a string of errors (if there are any)
-- and a boolean to indicate coherence or not
allCoherentCommons :: [TLCommon A] -> (String, Bool)
allCoherentCommons :: [TLCommon Any] -> (Name, Bool)
allCoherentCommons [TLCommon Any]
commons = do
    [Bool]
ps <- ([TLCommon Any] -> (Name, Bool))
-> [[TLCommon Any]] -> (Name, [Bool])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [TLCommon Any] -> (Name, Bool)
checkCoherence ([TLCommon Any] -> [[TLCommon Any]]
groupCommonBlocksByName [TLCommon Any]
commons)
    Bool -> (Name, Bool)
forall a. a -> (Name, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
ps)
   where
      checkCoherence :: [TLCommon A] -> (String, Bool)
      checkCoherence :: [TLCommon Any] -> (Name, Bool)
checkCoherence [TLCommon Any]
cs =
        (Bool -> (TLCommon Any, TLCommon Any) -> (Name, Bool))
-> Bool -> [(TLCommon Any, TLCommon Any)] -> (Name, Bool)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Bool
p (TLCommon Any
c1, TLCommon Any
c2) -> TLCommon Any -> TLCommon Any -> (Name, Bool)
coherentCommons TLCommon Any
c1 TLCommon Any
c2 (Name, Bool) -> (Bool -> (Name, Bool)) -> (Name, Bool)
forall a b. (Name, a) -> (a -> (Name, b)) -> (Name, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
p' -> Bool -> (Name, Bool)
forall a. a -> (Name, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> (Name, Bool)) -> Bool -> (Name, Bool)
forall a b. (a -> b) -> a -> b
$ Bool
p Bool -> Bool -> Bool
&& Bool
p') Bool
True ([TLCommon Any] -> [(TLCommon Any, TLCommon Any)]
forall a. [a] -> [(a, a)]
pairs [TLCommon Any]
cs)

      -- Computes all pairwise combinations
      pairs :: [a] -> [(a, a)]
      pairs :: forall a. [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 Any -> TLCommon Any -> (Name, Bool)
coherentCommons (Name
_, (Name
_, (Maybe Name
n1, [(Name, TypeInfo)]
vtys1))) (Name
_, (Name
_, (Maybe Name
n2, [(Name, TypeInfo)]
vtys2))) =
    if Maybe Name
n1 Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Name
n2
      then
        [(Name, TypeInfo)] -> [(Name, TypeInfo)] -> (Name, Bool)
coherentCommons' [(Name, TypeInfo)]
vtys1 [(Name, TypeInfo)]
vtys2
      else Name -> (Name, Bool)
forall a. HasCallStack => Name -> a
error (Name -> (Name, Bool)) -> Name -> (Name, Bool)
forall a b. (a -> b) -> a -> b
$ Name
"Trying to compare differently named common blocks: "
                 Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Maybe Name -> Name
forall a. Show a => a -> Name
show Maybe Name
n1 Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" and " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Maybe Name -> Name
forall a. Show a => a -> Name
show Maybe Name
n2 Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\n"

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

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

mkModuleFile ::
  F.MetaInfo -> Directory -> TLCommon A -> (String, F.ProgramFile A)
mkModuleFile :: MetaInfo -> Name -> TLCommon Any -> (Name, ProgramFile A)
mkModuleFile MetaInfo
meta Name
dir (Name
_, (Name
_, (Maybe Name
name, [(Name, TypeInfo)]
varTys))) =
    (Name
r, Name -> ProgramFile A -> ProgramFile A
forall a. Name -> ProgramFile a -> ProgramFile a
F.pfSetFilename Name
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 :: Name
modname = Maybe Name -> Name
commonName Maybe Name
name
    path :: Name
path = Name
dir Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
modname Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
".f90"
    r :: Name
r = Name
"Creating module " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
modname Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" at " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
path Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\n"
    mod :: ProgramUnit A
mod = FortranVersion
-> Name -> [(Name, TypeInfo)] -> Name -> ProgramUnit A
mkModule (MetaInfo -> FortranVersion
F.miVersion MetaInfo
meta) Name
modname [(Name, TypeInfo)]
varTys Name
modname

mkModule :: F.FortranVersion -> String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A
mkModule :: FortranVersion
-> Name -> [(Name, TypeInfo)] -> Name -> ProgramUnit A
mkModule FortranVersion
v Name
name [(Name, TypeInfo)]
vtys Name
fname =
    A
-> SrcSpan
-> Name
-> [Block A]
-> Maybe [ProgramUnit A]
-> ProgramUnit A
forall a.
a
-> SrcSpan
-> Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUModule A
a SrcSpan
sp (Name -> Name
caml Name
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 -> Name -> Maybe (Int, Name) -> Position
FU.Position Int
0 Int
0 Int
0 Name
"" Maybe (Int, Name)
forall a. Maybe a
Nothing
    sp :: SrcSpan
sp = Position -> Position -> SrcSpan
FU.SrcSpan Position
loc Position
loc
    toDeclBlock :: (Name, TypeInfo) -> Block A
toDeclBlock (Name
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 ((Name, TypeInfo) -> Statement A
toStmt (Name
v, TypeInfo
t))
    toStmt :: (Name, TypeInfo) -> Statement A
toStmt (Name
v, (SemType
st, 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 (SemType -> TypeSpec A
typespec SemType
st) Maybe (AList Attribute A)
attrs ((Name, ConstructType) -> AList Declarator A
toDeclarator (Name
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]
    typespec :: SemType -> TypeSpec A
typespec = A -> SrcSpan -> FortranVersion -> SemType -> TypeSpec A
forall a. a -> SrcSpan -> FortranVersion -> SemType -> TypeSpec a
FAS.recoverSemTypeTypeSpec A
a SrcSpan
sp FortranVersion
v
    toDeclarator :: (Name, ConstructType) -> AList Declarator A
toDeclarator (Name
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
-> DeclaratorType A
-> Maybe (Expression A)
-> Maybe (Expression A)
-> Declarator A
forall a.
a
-> SrcSpan
-> Expression a
-> DeclaratorType a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.Declarator A
a SrcSpan
sp
          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Name -> Value A
forall a. Name -> Value a
F.ValVariable (Name -> Name
caml Name
name Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"_" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
v))) DeclaratorType A
forall a. DeclaratorType a
F.ScalarDecl Maybe (Expression A)
forall a. Maybe a
Nothing Maybe (Expression A)
forall a. Maybe a
Nothing]
    toDeclarator (Name
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
-> DeclaratorType A
-> Maybe (Expression A)
-> Maybe (Expression A)
-> Declarator A
forall a.
a
-> SrcSpan
-> Expression a
-> DeclaratorType a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.Declarator A
a SrcSpan
sp
          (A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Name -> Value A
forall a. Name -> Value a
F.ValVariable (Name -> Name
caml Name
name Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"_" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
v))) (AList DimensionDeclarator A -> DeclaratorType A
forall a. AList DimensionDeclarator a -> DeclaratorType a
F.ArrayDecl 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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Expression A
forall {a}. Show a => a -> Expression A
expr Indentation
lb) ((Int -> Expression A) -> Indentation -> Maybe (Expression A)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Expression A
forall {a}. Show a => a -> Expression A
expr Indentation
ub)
         expr :: a -> Expression A
expr a
x = A -> SrcSpan -> Value A -> Expression A
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue A
a SrcSpan
sp (Value A -> Expression A) -> Value A -> Expression A
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (KindParam A) -> Value A
forall a. Name -> Maybe (KindParam a) -> Value a
F.ValInteger (a -> Name
forall a. Show a => a -> Name
show a
x) Maybe (KindParam A)
forall a. Maybe a
Nothing
    toDeclarator (Name
_, ConstructType
ct) = Name -> AList Declarator A
forall a. HasCallStack => Name -> a
error (Name -> AList Declarator A) -> Name -> AList Declarator A
forall a b. (a -> b) -> a -> b
$ Name
"mkModule: toDeclarator: bad construct type: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ ConstructType -> Name
forall a. Show a => a -> Name
show ConstructType
ct
    decls :: [Block A]
decls = ((Name, TypeInfo) -> Block A) -> [(Name, TypeInfo)] -> [Block A]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TypeInfo) -> Block A
toDeclBlock [(Name, TypeInfo)]
vtys