module Language.Fortran.Vars.SymbolTable.Arrays where

import Language.Fortran.AST

import Language.Fortran.Vars.Eval ( eval' )
import Language.Fortran.Vars.Types ( ExpVal(..), SymbolTable, Dim(..), Dims(..), Dimensions )

import Control.Monad.Except
--import Data.List.NonEmpty ( NonEmpty( (:|) ) )

resolveDims
    :: SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions
resolveDims :: forall a.
SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions
resolveDims SymbolTable
symt [DimensionDeclarator a]
dds
  -- We assume array type from a quick look at the dimension declarators.
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedSize  [DimensionDeclarator a]
dds =
      case forall a.
SymbolTable
-> [DimensionDeclarator a]
-> Either String (Maybe [Dim (Maybe Int)], Maybe Int)
resolveDimsAssumedSize SymbolTable
symt [DimensionDeclarator a]
dds of
        Left String
_err -> forall a. Maybe a
Nothing -- discard errors/warnings :(
        Right (Maybe [Dim (Maybe Int)]
Nothing, Maybe Int
x) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Maybe (t (Dim a)) -> a -> Dims t a
DimsAssumedSize forall a. Maybe a
Nothing Maybe Int
x
        -- resolveDimsAssumedSize can't return an empty list. Clumsy code means
        -- we don't prove this in types.
        Right (Just (Dim (Maybe Int)
a:[Dim (Maybe Int)]
as), Maybe Int
x) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Maybe (t (Dim a)) -> a -> Dims t a
DimsAssumedSize (forall a. a -> Maybe a
Just (Dim (Maybe Int)
a forall a. a -> [a] -> NonEmpty a
:| [Dim (Maybe Int)]
as)) Maybe Int
x
        Right (Just [], Maybe Int
_x) -> forall a. HasCallStack => String -> a
error String
"impossible"
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedShape [DimensionDeclarator a]
dds =
      case forall a.
SymbolTable -> [DimensionDeclarator a] -> Either String [Maybe Int]
resolveDimsAssumedShape SymbolTable
symt [DimensionDeclarator a]
dds of
        Left String
_err -> forall a. Maybe a
Nothing -- discard errors/warnings :(
        Right [] -> forall a. HasCallStack => String -> a
error String
"empty DimensionDeclarator list (should not be parseable)"
        Right (Maybe Int
a:[Maybe Int]
as) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. t a -> Dims t a
DimsAssumedShape forall a b. (a -> b) -> a -> b
$ Maybe Int
a forall a. a -> [a] -> NonEmpty a
:| [Maybe Int]
as
  | Bool
otherwise =
      case forall a.
SymbolTable
-> [DimensionDeclarator a] -> Either String [Dim (Maybe Int)]
resolveDimsExplicitShape SymbolTable
symt [DimensionDeclarator a]
dds of
        Left String
_err -> forall a. Maybe a
Nothing -- discard errors/warnings :(
        Right [] -> forall a. HasCallStack => String -> a
error String
"empty DimensionDeclarator list (should not be parseable)"
        Right (Dim (Maybe Int)
a:[Dim (Maybe Int)]
as) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. t (Dim a) -> Dims t a
DimsExplicitShape forall a b. (a -> b) -> a -> b
$ Dim (Maybe Int)
a forall a. a -> [a] -> NonEmpty a
:| [Dim (Maybe Int)]
as

-- | Assumed-size arrays have the special 'ValStar' upper bound (whereas
--   explicit-shape and assumed-shape arrays never do).
dimDeclLooksLikeAssumedSize :: DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedSize :: forall a. DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedSize = \case
  DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
_ (Just (ExpValue a
_ SrcSpan
_ Value a
ValStar)) -> Bool
True
  DimensionDeclarator a
_ -> Bool
False

-- | Assumed-shape arrays have no upper bounds (whereas explicit-shape and
--   assumed-size arrays always do).
dimDeclLooksLikeAssumedShape :: DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedShape :: forall a. DimensionDeclarator a -> Bool
dimDeclLooksLikeAssumedShape = \case
  DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
_ Maybe (Expression a)
Nothing -> Bool
True
  DimensionDeclarator a
_ -> Bool
False

evalStaticDimBoundExpr :: SymbolTable -> Expression a -> Either String Int
evalStaticDimBoundExpr :: forall a. SymbolTable -> Expression a -> Either String Int
evalStaticDimBoundExpr SymbolTable
symt Expression a
expr =
    case forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symt Expression a
expr of
      Right (Int Int
val) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
val
      Right{} -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"wrong type for array dimension bound"
      Left String
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"error evaluating array dimension bound expression: "forall a. Semigroup a => a -> a -> a
<>String
err

-- | Returns @'Right' 'Nothing'@ for dynamic bounds (e.g. which use dummy vars).
evalDynamicDimBoundExpr :: SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr :: forall a. SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr SymbolTable
symt Expression a
expr =
    case forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symt Expression a
expr of
      Right (Int Int
val) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
val
      Right{} -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"wrong type for array dimension bound"
      Left{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

resolveDimsExplicitShape
    :: SymbolTable -> [DimensionDeclarator a] -> Either String [Dim (Maybe Int)]
resolveDimsExplicitShape :: forall a.
SymbolTable
-> [DimensionDeclarator a] -> Either String [Dim (Maybe Int)]
resolveDimsExplicitShape SymbolTable
symt = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a.
SymbolTable
-> DimensionDeclarator a -> Either String (Dim (Maybe Int))
resolveDimExplicitShape SymbolTable
symt)

resolveDimExplicitShape
    :: SymbolTable -> DimensionDeclarator a -> Either String (Dim (Maybe Int))
resolveDimExplicitShape :: forall a.
SymbolTable
-> DimensionDeclarator a -> Either String (Dim (Maybe Int))
resolveDimExplicitShape SymbolTable
symt (DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
mlb Maybe (Expression a)
mub) =
    case Maybe (Expression a)
mub of
      Maybe (Expression a)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"explicit-shape array must have an upper bound for every dimension"
      Just Expression a
ubExpr -> do
        Maybe Int
lb <- case Maybe (Expression a)
mlb of
                Maybe (Expression a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
1
                Just Expression a
lbExpr -> forall a. SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr SymbolTable
symt Expression a
lbExpr
        Maybe Int
ub <- forall a. SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr SymbolTable
symt Expression a
ubExpr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Dim a
Dim Maybe Int
lb Maybe Int
ub

resolveDimsAssumedShape
    :: SymbolTable -> [DimensionDeclarator a] -> Either String [Maybe Int]
resolveDimsAssumedShape :: forall a.
SymbolTable -> [DimensionDeclarator a] -> Either String [Maybe Int]
resolveDimsAssumedShape SymbolTable
symt = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DimensionDeclarator a -> Either String (Maybe Int)
go
  where
    go :: DimensionDeclarator a -> Either String (Maybe Int)
go (DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
mlb Maybe (Expression a)
mub) =
        case Maybe (Expression a)
mub of
          Just{} ->
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"assumed-shape array can't have a dimension with an upper bound"
          Maybe (Expression a)
Nothing ->
            case Maybe (Expression a)
mlb of
              Maybe (Expression a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
1
              Just Expression a
lbExpr -> forall a. SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr SymbolTable
symt Expression a
lbExpr

resolveDimsAssumedSize
    :: SymbolTable -> [DimensionDeclarator a]
    -> Either String (Maybe [Dim (Maybe Int)], Maybe Int)
resolveDimsAssumedSize :: forall a.
SymbolTable
-> [DimensionDeclarator a]
-> Either String (Maybe [Dim (Maybe Int)], Maybe Int)
resolveDimsAssumedSize SymbolTable
symt = \case
  []   -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"resolveDimsAssumedSize: array can't have zero dimensions"
  DimensionDeclarator a
d:[] ->
    case forall a.
SymbolTable -> DimensionDeclarator a -> Either String (Maybe Int)
resolveDimStar SymbolTable
symt DimensionDeclarator a
d of
      Left String
err -> forall a b. a -> Either a b
Left String
err
      Right Maybe Int
a -> forall a b. b -> Either a b
Right (forall a. Maybe a
Nothing, Maybe Int
a)
  [DimensionDeclarator a]
ds   ->
    case forall a.
[Dim (Maybe Int)]
-> [DimensionDeclarator a]
-> Either String ([Dim (Maybe Int)], Maybe Int)
go [] [DimensionDeclarator a]
ds of
      Left String
err -> forall a b. a -> Either a b
Left String
err
      Right ([Dim (Maybe Int)]
l, Maybe Int
r) -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just [Dim (Maybe Int)]
l, Maybe Int
r)
  where
    go
        :: [Dim (Maybe Int)] -> [DimensionDeclarator a]
        -> Either String ([Dim (Maybe Int)], Maybe Int)
    go :: forall a.
[Dim (Maybe Int)]
-> [DimensionDeclarator a]
-> Either String ([Dim (Maybe Int)], Maybe Int)
go [Dim (Maybe Int)]
ds = \case
      []     -> forall a b. b -> Either a b
Right (forall a. [a] -> [a]
reverse [Dim (Maybe Int)]
ds, forall a. Maybe a
Nothing)
      DimensionDeclarator a
dd:[]  ->
        case forall a.
SymbolTable -> DimensionDeclarator a -> Either String (Maybe Int)
resolveDimStar SymbolTable
symt DimensionDeclarator a
dd of
          Left  String
err -> forall a b. a -> Either a b
Left String
err
          Right Maybe Int
d   -> forall a b. b -> Either a b
Right ([Dim (Maybe Int)]
ds, Maybe Int
d)
      DimensionDeclarator a
dd:[DimensionDeclarator a]
dds ->
        case forall a.
SymbolTable
-> DimensionDeclarator a -> Either String (Dim (Maybe Int))
resolveDimExplicitShape SymbolTable
symt DimensionDeclarator a
dd of
          Left  String
err -> forall a b. a -> Either a b
Left String
err
          Right Dim (Maybe Int)
d   -> forall a.
[Dim (Maybe Int)]
-> [DimensionDeclarator a]
-> Either String ([Dim (Maybe Int)], Maybe Int)
go (Dim (Maybe Int)
dforall a. a -> [a] -> [a]
:[Dim (Maybe Int)]
ds) [DimensionDeclarator a]
dds

resolveDimStar
    :: SymbolTable -> DimensionDeclarator a -> Either String (Maybe Int)
resolveDimStar :: forall a.
SymbolTable -> DimensionDeclarator a -> Either String (Maybe Int)
resolveDimStar SymbolTable
symt (DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
mlb Maybe (Expression a)
mub) = do
    Maybe Int
lb <- case Maybe (Expression a)
mlb of
            Maybe (Expression a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
1
            Just Expression a
lbExpr -> forall a. SymbolTable -> Expression a -> Either String (Maybe Int)
evalDynamicDimBoundExpr SymbolTable
symt Expression a
lbExpr
    () <- forall a. Maybe (Expression a) -> Either String ()
resolveDimBoundStar Maybe (Expression a)
mub
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
lb

resolveDimBoundStar :: Maybe (Expression a) -> Either String ()
resolveDimBoundStar :: forall a. Maybe (Expression a) -> Either String ()
resolveDimBoundStar = \case
  Just (ExpValue a
_ SrcSpan
_ Value a
ValStar) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Just{}  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"resolveDimBoundStar: expression wasn't a ValStar"
  Maybe (Expression a)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"resolveDimBoundStar: upper bound must be present"