{-# 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)
type TypeInfo = (FAS.SemType, FA.ConstructType)
type TCommon p = (Maybe F.Name, [(F.Name, TypeInfo)])
type TLCommon p = (Filename, (F.Name, TCommon p))
type A1 = FA.Analysis Annotation
type CommonState = State (String, [TLCommon A])
type (:?) a (b :: k) = a
commonElimToModules ::
Directory
-> [F.ProgramFile A]
-> PureAnalysis Void Void ([F.ProgramFile A], [F.ProgramFile A])
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
""
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)
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
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
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)
groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]]
groupSortCommonBlock :: [TLCommon Any] -> [[[TLCommon Any]]]
groupSortCommonBlock [TLCommon Any]
commons = [[[TLCommon Any]]]
gccs
where
gcs :: [[TLCommon Any]]
gcs = [TLCommon Any] -> [[TLCommon Any]]
groupCommonBlocksByName [TLCommon Any]
commons
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
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 ->
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
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)
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
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)
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
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
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)
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) []
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
((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])
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
Maybe (Expression A)
Nothing -> ([Statement A]
assgnsNew, [Declarator A]
declsNew)
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)
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
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
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
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
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"
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)
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)
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