module Language.Fortran.Vars.Union
  ( union
  )
where

import qualified Data.Map                      as M
import           Language.Fortran.AST           ( Name )

import           Language.Fortran.Vars.Types
                                                ( SymbolTableEntry(..)
                                                , Location
                                                , MemoryBlock(..)
                                                , MemoryBlockName
                                                , ProgramUnitModel
                                                , StorageClass(..)
                                                , SymbolTable
                                                )

updateVal :: MemoryBlockName -> Int -> Name -> SymbolTable -> SymbolTable
updateVal :: Name -> Offset -> Name -> SymbolTable -> SymbolTable
updateVal Name
blockName Offset
diff Name
symbol SymbolTable
symt = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
  Just (SVariable Type
ty (Name
_, Offset
offset)) ->
    let entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable Type
ty (Name
blockName, Offset
offset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
diff)
    in  Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
  Just SymbolTableEntry
_  -> Name -> SymbolTable
forall a. HasCallStack => Name -> a
error (Name
symbol Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"is not a variable.")
  Maybe SymbolTableEntry
Nothing -> SymbolTable
symt

mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass StorageClass
Unspecified StorageClass
c2          = StorageClass
c2
mergeStClass StorageClass
c1          StorageClass
Unspecified = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 | StorageClass
c1 StorageClass -> StorageClass -> Bool
forall a. Eq a => a -> a -> Bool
== StorageClass
c2        = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 =
  Name -> StorageClass
forall a. HasCallStack => Name -> a
error (Name
"Try to merge StorageClass " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ StorageClass -> Name
forall a. Show a => a -> Name
show StorageClass
c1 Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" with " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ StorageClass -> Name
forall a. Show a => a -> Name
show StorageClass
c2)

-- | Given a 'ProgramUnitModel' and two different 'Location's,
-- produce a new 'ProgramUnitModel' and 'Location' that represents
-- the union of the inputs
union
  :: ProgramUnitModel -> Location -> Location -> (ProgramUnitModel, Location)
union :: ProgramUnitModel
-> Location -> Location -> (ProgramUnitModel, Location)
union ProgramUnitModel
puModel Location
loc1 Location
loc2 | Location
loc1 Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
loc2 = (ProgramUnitModel
puModel, Location
loc1)
union (SymbolTable
symTable, StorageTable
storageTable) Location
location1 Location
location2 =
  let (Name
blockName1, Offset
offset1) = Location
location1
      (Name
blockName2, Offset
offset2) = Location
location2
      Just MemoryBlock
block1           = case Name -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
blockName1 StorageTable
storageTable of
        Just MemoryBlock
block -> MemoryBlock -> Maybe MemoryBlock
forall a. a -> Maybe a
Just MemoryBlock
block
        Maybe MemoryBlock
Nothing    -> Name -> Maybe MemoryBlock
forall a. HasCallStack => Name -> a
error (Name
"Block doesn't exist: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
blockName1)
      Just MemoryBlock
block2 = case Name -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
blockName2 StorageTable
storageTable of
        Just MemoryBlock
block -> MemoryBlock -> Maybe MemoryBlock
forall a. a -> Maybe a
Just MemoryBlock
block
        Maybe MemoryBlock
Nothing    -> Name -> Maybe MemoryBlock
forall a. HasCallStack => Name -> a
error (Name
"Block doesn't exist: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
blockName2)
  in  case Offset -> Offset -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Offset
offset1 Offset
offset2 of
        Ordering
Prelude.GT -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
        Ordering
Prelude.LT -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
        Ordering
Prelude.EQ -> case (MemoryBlock -> StorageClass
storageClass MemoryBlock
block1, MemoryBlock -> StorageClass
storageClass MemoryBlock
block2) of
          (StorageClass
Common, StorageClass
_     ) -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
          (StorageClass
_     , StorageClass
Common) -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
          (StorageClass, StorageClass)
_                -> if MemoryBlock -> Maybe Offset
blockSize MemoryBlock
block1 Maybe Offset -> Maybe Offset -> Bool
forall a. Ord a => a -> a -> Bool
>= MemoryBlock -> Maybe Offset
blockSize MemoryBlock
block2
            then Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
            else Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
 where
  mergeTo :: Location -> Location -> (ProgramUnitModel, Location)
  mergeTo :: Location -> Location -> (ProgramUnitModel, Location)
mergeTo toLocation :: Location
toLocation@(Name
toBlockName, Offset
toOffset) (Name
fromBlockName, Offset
fromOffset) =
    let
      diff :: Offset
diff           = Offset
toOffset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
fromOffset
      Just MemoryBlock
fromBlock = Name -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fromBlockName StorageTable
storageTable
      Just MemoryBlock
toBlock   = Name -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
toBlockName StorageTable
storageTable
      -- update toBlock variables by appending the variables of fromBlock
      newVarList :: [Name]
newVarList     = MemoryBlock -> [Name]
variables MemoryBlock
toBlock [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ MemoryBlock -> [Name]
variables MemoryBlock
fromBlock
      -- update toBlock size
      newSize :: Maybe Offset
newSize        = do
        Offset
to   <- MemoryBlock -> Maybe Offset
blockSize MemoryBlock
toBlock
        Offset
from <- MemoryBlock -> Maybe Offset
blockSize MemoryBlock
fromBlock
        Offset -> Maybe Offset
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Offset -> Maybe Offset) -> Offset -> Maybe Offset
forall a b. (a -> b) -> a -> b
$ Offset -> Offset -> Offset
forall a. Ord a => a -> a -> a
max Offset
to (Offset
from Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
diff)
      newStClass :: StorageClass
newStClass = StorageClass -> StorageClass -> StorageClass
mergeStClass (MemoryBlock -> StorageClass
storageClass MemoryBlock
fromBlock) (MemoryBlock -> StorageClass
storageClass MemoryBlock
toBlock)
      newBlock :: MemoryBlock
newBlock   = MemoryBlock :: Maybe Offset -> StorageClass -> [Name] -> MemoryBlock
MemoryBlock { blockSize :: Maybe Offset
blockSize    = Maybe Offset
newSize
                               , storageClass :: StorageClass
storageClass = StorageClass
newStClass
                               , variables :: [Name]
variables    = [Name]
newVarList
                               }
      mbs :: StorageTable
mbs  = Name -> MemoryBlock -> StorageTable -> StorageTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
toBlockName MemoryBlock
newBlock StorageTable
storageTable
      -- remove the fromBlock
      mbs' :: StorageTable
mbs' = Name -> StorageTable -> StorageTable
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
fromBlockName StorageTable
mbs
      -- update the symbolTable for variables of fromBlock with
      -- toBlock name and updated offset
      symTable' :: SymbolTable
symTable' =
        (Name -> SymbolTable -> SymbolTable)
-> SymbolTable -> [Name] -> SymbolTable
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Offset -> Name -> SymbolTable -> SymbolTable
updateVal Name
toBlockName Offset
diff) SymbolTable
symTable (MemoryBlock -> [Name]
variables MemoryBlock
fromBlock)
    in
      ((SymbolTable
symTable', StorageTable
mbs'), Location
toLocation)