content: module Language.Fortran.Analysis.Types
    ( analyseTypes
    , analyseTypesWithEnv
    , analyseAndCheckTypesWithEnv
    , stripExtended
    , extractTypeEnv
    , extractTypeEnvExtended
    , TypeEnv
    , TypeEnvExtended
    , TypeError
    , deriveSemTypeFromDeclaration
    , deriveSemTypeFromTypeSpec
    , deriveSemTypeFromBaseType
    , runInfer
    , inferState0
    ) where
  
  import Language.Fortran.AST
  import Language.Fortran.AST.Literal.Real
  import Language.Fortran.AST.Literal.Complex
  
  import Prelude hiding (lookup, EQ, LT, GT)
  import Data.Map (insert)
  import qualified Data.Map as M
  import Data.Maybe (maybeToList)
  import Data.List (find, foldl')
  import Control.Monad.State.Strict
  import Control.Monad.Reader
  import Control.Monad -- required for mtl-2.3 (GHC 9.6)
  import Data.Generics.Uniplate.Data
  import Data.Data
  import Language.Fortran.Analysis
  import Language.Fortran.Analysis.SemanticTypes
  import Language.Fortran.Intrinsics
  import Language.Fortran.Util.Position
  import Language.Fortran.Version (FortranVersion(..))
  
  --------------------------------------------------
  
  -- | Mapping of names to type information.
  type TypeEnv = M.Map Name IDType
  -- | Mapping of names to type information with more information about the source
  type TypeEnvExtended = M.Map Name (Name, SrcSpan, IDType)
  
  stripExtended :: TypeEnvExtended -> TypeEnv
  stripExtended = M.map (\(_, _, t) -> t)
  
  -- | Information about a detected type error.
  type TypeError = (String, SrcSpan)
  
  -- | Mapping of structures to field types
  type StructTypeEnv = M.Map Name StructMemberTypeEnv
  type StructMemberTypeEnv = M.Map Name IDType
  
  --------------------------------------------------
  
  -- Monad for type inference work
  type Infer a = StateT InferState (Reader InferConfig) a
  data InferState = InferState { langVersion :: FortranVersion
                               , intrinsics  :: IntrinsicsTable
                               , environ     :: TypeEnv
                               , structs     :: StructTypeEnv
                               , entryPoints :: M.Map Name (Name, Maybe Name)
                               , typeErrors  :: [TypeError] }
    deriving Show
  data InferConfig = InferConfig
    { inferConfigAcceptNonCharLengthAsKind :: Bool
    -- ^ How to handle declarations like @INTEGER x*8@. If true, providing a
    --   character length for a non-character data type will treat it as a kind
    --   parameter. In both cases, a warning is logged (nonstandard syntax).
    } deriving (Eq, Show)
  type InferFunc t = t -> Infer ()
  
  --------------------------------------------------
  
  -- | Annotate AST nodes with type information and also return a type
  -- environment mapping names to type information.
  analyseTypes :: Data a => ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
  analyseTypes = analyseTypesWithEnv M.empty
  
  -- | Annotate AST nodes with type information and also return a type
  -- environment mapping names to type information; provided with a
  -- starting type environment.
  analyseTypesWithEnv :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
  analyseTypesWithEnv env pf = (pf', tenv)
    where
      (pf', endState) = analyseTypesWithEnv' env pf
      tenv            = environ endState
  
  -- | Annotate AST nodes with type information, return a type
  -- environment mapping names to type information and return any type
  -- errors found; provided with a starting type environment.
  analyseAndCheckTypesWithEnv
    :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv, [TypeError])
  analyseAndCheckTypesWithEnv env pf = (pf', tenv, terrs)
    where
      (pf', endState) = analyseTypesWithEnv' env pf
      tenv            = environ endState
      terrs           = typeErrors endState
  
  analyseTypesWithEnv' :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), InferState)
  analyseTypesWithEnv' env pf@(ProgramFile mi _) = runInfer (miVersion mi) env $ do
    -- Gather information.
    mapM_ intrinsicsExp (allExpressions pf)
    mapM_ programUnit (allProgramUnits pf)
    mapM_ recordArrayDecl (allDeclarators pf)
    mapM_ statement (allStatements pf)
  
    -- Gather types for known entry points.
    eps <- gets (M.toList . entryPoints)
    forM_ eps $ \ (eName, (fName, mRetName)) -> do
      mFType <- getRecordedType fName
      case mFType of
        Just (IDType fVType fCType) -> do
          recordMType fVType fCType eName
          -- FIXME: what about functions that return arrays?
          maybe (return ()) (error "Entry points with result variables unsupported" >> recordMType fVType Nothing) mRetName
        _                           -> return ()
  
    annotateTypes pf              -- Annotate AST nodes with their types.
  
  extractTypeEnv :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnv
  extractTypeEnv pf = M.union puEnv expEnv
    where
      puEnv = M.fromList [ (n, ty) | pu <- universeBi pf :: [ProgramUnit (Analysis a)]
                                   , Named n <- [puName pu]
                                   , ty <- maybeToList (idType (getAnnotation pu)) ]
      expEnv = M.fromList [ (n, ty) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)]
                                    , let n = varName e
                                    , ty <- maybeToList (idType (getAnnotation e)) ]
  
  extractTypeEnvExtended :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnvExtended
  extractTypeEnvExtended pf = M.union puEnv expEnv
    where
      puEnv = M.fromList [ (n, (srcName, getSpan pu, ty)) | pu <- universeBi pf :: [ProgramUnit (Analysis a)]
                                   , Named n <- [puName pu]
                                   , Named srcName <- [puSrcName pu]
                                   , ty <- maybeToList (idType (getAnnotation pu)) ]
      expEnv = M.fromList [ (n, (srcName e, sp, ty)) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)]
                                    , let n = varName e
                                    , sp <- getDeclarator n
                                    , ty <- maybeToList (idType (getAnnotation e)) ]
      getDeclarator v' =
          [ sp | d@(Declarator _ sp ev _ _ _) <- universeBi pf :: [Declarator (Analysis a)]
               , varName ev == v' ]
  
  
  
  
  type TransType f g a = (f (Analysis a) -> Infer (f (Analysis a))) -> g (Analysis a) -> Infer (g (Analysis a))
  annotateTypes :: Data a => ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
  annotateTypes pf = (transformBiM :: Data a => TransType Expression ProgramFile a) annotateExpression pf >>=
                     (transformBiM :: Data a => TransType ProgramUnit ProgramFile a) annotateProgramUnit
  
  intrinsicsExp :: Data a => InferFunc (Expression (Analysis a))
  intrinsicsExp (ExpSubscript _ _ nexp _)    = intrinsicsHelper nexp
  intrinsicsExp (ExpFunctionCall _ _ nexp _) = intrinsicsHelper nexp
  intrinsicsExp _                            = return ()
  
  intrinsicsHelper :: MonadState InferState m => Expression (Analysis a) -> m ()
  intrinsicsHelper nexp | isNamedExpression nexp = do
    itab <- gets intrinsics
    case getIntrinsicReturnType (srcName nexp) itab of
      Just _ -> do
        let n = varName nexp
        recordCType CTIntrinsic n
        -- recordBaseType _  n -- FIXME: going to skip base types for the moment
      _             -> return ()
  intrinsicsHelper _ = return ()
  
  programUnit :: Data a => InferFunc (ProgramUnit (Analysis a))
  programUnit pu@(PUFunction _ _ mRetType _ _ _ mRetVar blocks _)
    | Named n <- puName pu   = do
      -- record some type information that we can glean
      recordCType CTFunction n
      case (mRetType, mRetVar) of
        (Just ts@(TypeSpec _ _ _ _), Just v) -> do
          semType <- deriveSemTypeFromTypeSpec ts
          recordSemType semType n >> recordSemType semType (varName v)
        (Just ts@(TypeSpec _ _ _ _), _)      -> do
          semType <- deriveSemTypeFromTypeSpec ts
          recordSemType semType n
        _                                        -> return ()
      -- record entry points for later annotation
      forM_ blocks $ \ block ->
        sequence_ [ recordEntryPoint n (varName v) (fmap varName mRetVar') | (StEntry _ _ v _ mRetVar') <- allStatements block ]
  programUnit pu@(PUSubroutine _ _ _ _ _ blocks _) | Named n <- puName pu = do
    -- record the fact that this is a subroutine
    recordCType CTSubroutine n
    -- record entry points for later annotation
    forM_ blocks $ \ block ->
      sequence_ [ recordEntryPoint n (varName v) Nothing | (StEntry _ _ v _ _) <- allStatements block ]
  programUnit _                                           = return ()
  
  -- | Records array type information from a 'Declarator'. (Scalar type info is
  --   processed elsewhere.)
  --
  --   Note that 'ConstructType' is rewritten for 'Declarator's in
  --   'handleDeclaration' later. TODO how does this assist exactly? disabling
  --   apparently doesn't impact tests
  recordArrayDecl :: Data a => InferFunc (Declarator (Analysis a))
  recordArrayDecl (Declarator _ _ v (ArrayDecl ddAList) _ _) =
      recordCType (CTArray $ dimDeclarator ddAList) (varName v)
  recordArrayDecl _ = return ()
  
  dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)]
  dimDeclarator ddAList = [ (lb, ub) | DimensionDeclarator _ _ lbExp ubExp <- aStrip ddAList
                                     , let lb = do ExpValue _ _ (ValInteger i _) <- lbExp
                                                   return $ read i
                                     , let ub = do ExpValue _ _ (ValInteger i _) <- ubExp
                                                   return $ read i ]
  
  -- | Auxiliary function for getting semantic and construct type of a declaration.
  -- Used in standard declarations and structures
  handleDeclaration :: Data a => TypeEnv -> SrcSpan -> TypeSpec (Analysis a)
    -> Maybe (AList Attribute (Analysis a))
    -> AList Declarator (Analysis a)
    -> Infer [(Name, SemType, ConstructType)]
  handleDeclaration env stmtSs ts mAttrAList declAList
    | mAttrs  <- maybe [] aStrip mAttrAList
    , attrDim <- find isAttrDimension mAttrs
    , isParam <- any isAttrParameter mAttrs
    , isExtrn <- any isAttrExternal mAttrs
    , decls   <- aStrip declAList =
      let cType n | isExtrn                                     = CTExternal
                  | Just (AttrDimension _ _ ddAList) <- attrDim = CTArray (dimDeclarator ddAList)
                  | isParam                                     = CTParameter
                  | Just (IDType _ (Just ct)) <- M.lookup n env
                  , ct /= CTIntrinsic                           = ct
                  | otherwise                                   = CTVariable
          handler rs = \case
            Declarator _ declSs v mDdAList mLenExpr _ -> do
              st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr
              let n  = varName v
                  ct = case mDdAList of
                         ScalarDecl -> cType n
                         ArrayDecl dims -> CTArray $ dimDeclarator dims
              pure $ (n, st, ct) : rs
      in foldM handler [] decls
  
  handleStructureItem :: Data a => StructMemberTypeEnv -> StructureItem (Analysis a) -> Infer StructMemberTypeEnv
  handleStructureItem mt (StructFields _ src ts mAttrAList declAList) = do
    env <- gets environ
    ds <- handleDeclaration env src ts mAttrAList declAList
    pure $ foldl' (\m (n, s, c) -> M.insert n (IDType (Just s) (Just c)) m) mt ds
  -- TODO: These should eventually be implemented
  handleStructureItem mt StructUnion{} = pure mt
  handleStructureItem mt StructStructure{} = pure mt
  
  -- | Create a structure env from the list of fields and add it to the InferState
  handleStructure ::Data a => Maybe String -> AList StructureItem (Analysis a) -> Infer ()
  handleStructure mName itemAList = do
    case mName of
      Just n -> do
        structEnv <- foldM handleStructureItem M.empty (aStrip itemAList)
        recordStruct structEnv n
      Nothing -> pure ()
  
  statement :: Data a => InferFunc (Statement (Analysis a))
  
  statement (StDeclaration _ stmtSs ts mAttrAList declAList) = do
    env <- gets environ
    decls <- handleDeclaration env stmtSs ts mAttrAList declAList
    forM_ decls $ \(n, b, c) -> recordType b c n
  statement (StExternal _ _ varAList) = do
    let vars = aStrip varAList
    mapM_ (recordCType CTExternal . varName) vars
  statement (StExpressionAssign _ ss (ExpSubscript _ _ v ixAList) _)
    --  | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v)  -- it's an array (or a string?) FIXME
    | all isIxSingle (aStrip ixAList) = do
      mIDType <- getExprRecordedType v
      case mIDType of
        Just (IDType _ (Just CTArray{})) -> return ()                -- do nothing, it's already known to be an array
        _                                ->
          -- inspect the subscript to make a safe(r) assumption about type
          -- (ideally, we would have more information coming in to this call)
          case v of
            ExpDataRef{} ->
              -- can't have a function in a struct: must be array but we can't
              -- record "some array", we need dimension info! so, refuse
              typeError "likely found an array in a struct, but unable to record type information" ss
            _ -> -- else assume it's a function statement
              recordCType CTFunction (varName v)
  
  -- FIXME: if StFunctions can only be identified after types analysis
  -- is complete and disambiguation is performed, then how do we get
  -- them in the first place? (iterate until fixed point?)
  statement (StFunction _ _ v _ _) = recordCType CTFunction (varName v)
  -- (part of answer to above is) nullary function statement: foo() = ...
  statement (StExpressionAssign _ _ (ExpFunctionCall _ _ v args) _) =
    case alistList args of
      []  -> recordCType CTFunction (varName v)
      _:_ -> pure ()
  
  statement (StDimension _ _ declAList) = do
    let decls = aStrip declAList
    forM_ decls $ \ decl -> case decl of
      Declarator _ _ v (ArrayDecl ddAList) _ _ ->
        recordCType (CTArray $ dimDeclarator ddAList) (varName v)
      _ -> return ()
  
  statement (StStructure _ _ mName itemAList) = handleStructure mName itemAList
  
  statement _ = return ()
  
  annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))
  
  -- handle the various literals
  annotateExpression e@(ExpValue _ _ (ValVariable _))    = maybe e (`setIDType` e) `fmap` getRecordedType (varName e)
  annotateExpression e@(ExpValue _ _ (ValIntrinsic _))   = maybe e (`setIDType` e) `fmap` getRecordedType (varName e)
  annotateExpression e@(ExpValue _ ss (ValReal r mkp))        = do
      k <- deriveRealLiteralKind ss r mkp
      return $ setSemType (TReal k) e
  annotateExpression e@(ExpValue _ _ (ValComplex (ComplexLit _a _ss _cr _ci))) = do
      -- TODO check F90 standard for complex lit typing rules (kind params)
      return e
  annotateExpression e@(ExpValue _ _ ValInteger{})     =
      -- FIXME: in >F90, int lits can have kind info on end @_8@, same as real
      -- lits. We do parse this into the lit string, it is available to us.
      return $ setSemType (deriveSemTypeFromBaseType TypeInteger) e
  annotateExpression e@(ExpValue _ _ (ValLogical{}))     =
      return $ setSemType (deriveSemTypeFromBaseType TypeLogical) e
  
  annotateExpression e@(ExpBinary _ _ op e1 e2)          = flip setIDType e `fmap` binaryOpType (getSpan e) op e1 e2
  annotateExpression e@(ExpUnary _ _ op e1)              = flip setIDType e `fmap` unaryOpType (getSpan e1) op e1
  annotateExpression e@(ExpSubscript _ _ e1 idxAList)    = flip setIDType e `fmap` subscriptType (getSpan e) e1 idxAList
  annotateExpression e@(ExpFunctionCall _ _ e1 parAList) = flip setIDType e `fmap` functionCallType (getSpan e) e1 parAList
  annotateExpression e                                   = return e
  
  annotateProgramUnit :: Data a => ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
  annotateProgramUnit pu | Named n <- puName pu = maybe pu (`setIDType` pu) `fmap` getRecordedType n
  annotateProgramUnit pu                        = return pu
  
  -- | Derive the kind of a REAL literal constant.
  --
  -- Logic taken from HP's F90 reference pg.33, written to gfortran's behaviour.
  -- Stays in the 'Infer' monad so it can report type errors
  deriveRealLiteralKind :: SrcSpan -> RealLit -> Maybe (KindParam a) -> Infer Kind
  deriveRealLiteralKind ss r mkp =
      case mkp of
        Nothing -> case exponentLetter (realLitExponent r) of
                     ExpLetterE -> return  4
                     ExpLetterD -> return  8
                     ExpLetterQ -> return 16
        Just _kp -> case exponentLetter (realLitExponent r) of
                     ExpLetterE -> return 0 -- TODO return k
                     _          -> do
                       -- badly formed literal, but we'll allow and use the
                       -- provided kind param (with no doubling or anything)
                       typeError ("only real literals with exponent letter 'e'"
                               <> "can specify explicit kind parameter") ss
                       return 0 -- TODO return k
  
  binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType
  binaryOpType ss op e1 e2 = do
    mst1 <- case getIDType e1 of
              Just (IDType (Just st) _) -> return $ Just st
              _ -> typeError "Unable to obtain type for first operand" (getSpan e1) >> return Nothing
    mst2 <- case getIDType e2 of
              Just (IDType (Just st) _) -> return $ Just st
              _ -> typeError "Unable to obtain type for second operand" (getSpan e2) >> return Nothing
    case (mst1, mst2) of
      (_, Nothing) -> return emptyType
      (Nothing, _) -> return emptyType
      (Just st1, Just st2) -> do
        mst  <- binopSimpleCombineSemTypes ss op st1 st2
        mst' <- case mst of
          Just st
            | op `elem` [ Addition, Subtraction, Multiplication, Division
                        , Exponentiation, Concatenation, Or, XOr, And ]       -> return $ Just st
            | op `elem` [GT, GTE, LT, LTE, EQ, NE, Equivalent, NotEquivalent] -> return $ Just (deriveSemTypeFromBaseType TypeLogical)
            | BinCustom{} <- op -> typeError "custom binary ops not supported" ss >> return Nothing
          _ -> return Nothing
  
        return $ IDType mst' Nothing -- FIXME: might have to check kinds of each operand
  
  -- | Combine two 'SemType's with a 'BinaryOp'.
  --
  -- No real work done here, no kind combining, just selection.
  binopSimpleCombineSemTypes :: SrcSpan -> BinaryOp -> SemType -> SemType -> Infer (Maybe SemType)
  binopSimpleCombineSemTypes ss op st1 st2 = do
      case (st1, st2) of
        (_           , TComplex k2) -> ret $ TComplex k2
        (TComplex k1, _           ) -> ret $ TComplex k1
        (_           , TReal    k2) -> ret $ TReal k2
        (TReal    k1, _           ) -> ret $ TReal k1
        (_           , TInteger k2) -> ret $ TInteger k2
        (TInteger k1, _           ) -> ret $ TInteger k1
        (TByte    k1, TByte     _ ) -> ret $ TByte k1
        (TLogical k1, TLogical  _ ) -> ret $ TLogical k1
        (TCustom  _, TCustom   _) -> do
          typeError "custom types / binary op not supported" ss
          return Nothing
        (TCharacter l1 k1, TCharacter l2 k2)
          | k1 /= k2 -> do typeError "operation on character strings of different kinds" ss
                           return Nothing
          | op == Concatenation -> ret $ TCharacter (charLenConcat l1 l2) k1
          | op `elem` [EQ, NE]  -> ret $ deriveSemTypeFromBaseType TypeLogical
          | otherwise -> do typeError "Invalid op on character strings" ss
                            return Nothing
        _ -> do typeError "Type error between operands of binary operator" ss
                return Nothing
    where
      ret = return . Just
  
  unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType
  unaryOpType ss op e = do
    mst <- case getIDType e of
             Just (IDType (Just st) _) -> return $ Just st
             _ -> typeError "Unable to obtain type for" (getSpan e) >> return Nothing
    mst' <- case (mst, op) of
      (Nothing, _)               -> return Nothing
      (Just TCustom{}, _)        -> typeError "custom types / unary ops not supported" ss >> return Nothing
      (_, UnCustom{})            -> typeError "custom unary ops not supported" ss >> return Nothing
      (Just st@(TLogical _), Not)    -> return $ Just st
      (Just st, _)
        | op `elem` [Plus, Minus] &&
          isNumericType st -> return $ Just st
      _ -> typeError "Type error for unary operator" ss >> return Nothing
    return $ IDType mst' Nothing -- FIXME: might have to check kind of operand
  
  subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType
  subscriptType ss e1 (AList _ _ idxs) = do
    let isInteger ie | Just (IDType (Just (TInteger _)) _) <- getIDType ie = True
                     | otherwise = False
    forM_ idxs $ \ idx -> case idx of
      IxSingle _ _ _ ie
        | not (isInteger ie) -> typeError "Invalid or unknown type for index" (getSpan ie)
      IxRange _ _ mie1 mie2 mie3
        | Just ie1 <- mie1, not (isInteger ie1) -> typeError "Invalid or unknown type for index" (getSpan ie1)
        | Just ie2 <- mie2, not (isInteger ie2) -> typeError "Invalid or unknown type for index" (getSpan ie2)
        | Just ie3 <- mie3, not (isInteger ie3) -> typeError "Invalid or unknown type for index" (getSpan ie3)
      _ -> return ()
    case getIDType e1 of
      Just ty@(IDType mst (Just (CTArray dds))) -> do
        when (length idxs /= length dds) $ typeError "Length of indices does not match rank of array." ss
        let isSingle (IxSingle{}) = True; isSingle _ = False
        if all isSingle idxs
          then return $ IDType mst Nothing
          else return ty
      _ -> return emptyType
  
  functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Argument (Analysis a) -> Infer IDType
  functionCallType ss (ExpValue _ _ (ValIntrinsic n)) (AList _ _ params) = do
    itab <- gets intrinsics
    let mRetType = getIntrinsicReturnType n itab
    case mRetType of
      Nothing -> return emptyType
      Just retType -> do
        mst <- case retType of
              ITReal      -> wrapBaseType TypeReal
              ITInteger   -> wrapBaseType TypeInteger
              ITComplex   -> wrapBaseType TypeComplex
              ITDouble    -> wrapBaseType TypeDoublePrecision
              ITLogical   -> wrapBaseType TypeLogical
              ITCharacter -> wrapBaseType TypeCharacter
              ITParam i
                | length params >= i, Argument _ _ _ ae <- params !! (i-1)
                  -> return $ idVType =<< getIDType (argExprNormalize ae)
                | otherwise -> typeError ("Invalid parameter list to intrinsic '" ++ n ++ "'") ss >> return Nothing
        case mst of
          Nothing -> return emptyType
          Just _ -> return $ IDType mst Nothing
    where
      wrapBaseType :: Monad m => BaseType -> m (Maybe SemType)
      wrapBaseType = return . Just . deriveSemTypeFromBaseType
  
  functionCallType ss e1 _ = case getIDType e1 of
    Just (IDType (Just st) (Just CTFunction)) -> return $ IDType (Just st) Nothing
    Just (IDType (Just st) (Just CTExternal)) -> return $ IDType (Just st) Nothing
    _ -> typeError "non-function invoked by call" ss >> return emptyType
  
  isNumericType :: SemType -> Bool
  isNumericType = \case
    TComplex{} -> True
    TReal{}    -> True
    TInteger{} -> True
    TByte{}    -> True
    _            -> False
  
  --------------------------------------------------
  -- Monadic helper combinators.
  
  inferState0 :: FortranVersion -> InferState
  inferState0 v = InferState
    { environ     = M.empty
    , structs     = M.empty
    , entryPoints = M.empty
    , langVersion = v
    , intrinsics  = getVersionIntrinsics v
    , typeErrors  = []
    }
  
  inferConfig0 :: InferConfig
  inferConfig0 = InferConfig
    { inferConfigAcceptNonCharLengthAsKind = True
    }
  
  runInfer :: FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
  runInfer v env f = flip runReader inferConfig0 $ flip runStateT ((inferState0 v) { environ = env }) f
  
  typeError :: MonadState InferState m => String -> SrcSpan -> m ()
  typeError msg ss = modify $ \ s -> s { typeErrors = (msg, ss):typeErrors s }
  
  emptyType :: IDType
  emptyType = IDType Nothing Nothing
  
  -- Record the type of the given name.
  recordType :: SemType -> ConstructType -> Name -> Infer ()
  recordType st ct n = modify $ \ s -> s { environ = insert n (IDType (Just st) (Just ct)) (environ s) }
  
  recordStruct :: StructMemberTypeEnv -> Name -> Infer ()
  recordStruct mt n = modify $ \s -> s { structs = insert n mt (structs s) }
  
  -- Record the type (maybe) of the given name.
  recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer ()
  recordMType st ct n = modify $ \ s -> s { environ = insert n (IDType st ct) (environ s) }
  
  -- Record the CType of the given name.
  recordCType :: MonadState InferState m => ConstructType -> Name -> m ()
  recordCType ct n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }
    where changeFunc mIDType = Just (IDType (mIDType >>= idVType) (Just ct))
  
  -- Record the SemType of the given name.
  recordSemType :: SemType -> Name -> Infer ()
  recordSemType st n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }
    where changeFunc mIDType = Just (IDType (Just st) (mIDType >>= idCType))
  
  recordEntryPoint :: Name -> Name -> Maybe Name -> Infer ()
  recordEntryPoint fn en mRetName = modify $ \ s -> s { entryPoints = M.insert en (fn, mRetName) (entryPoints s) }
  
  getRecordedType :: Name -> Infer (Maybe IDType)
  getRecordedType n = gets (M.lookup n . environ)
  
  getExprRecordedType :: Data a => Expression (Analysis a) -> Infer (Maybe IDType)
  getExprRecordedType e@(ExpValue _ _ (ValVariable _)) = getRecordedType $ varName e
  getExprRecordedType (ExpSubscript _ _ base _) = do
    mTy <- getExprRecordedType base
    case mTy of
      Just (IDType semTy (Just CTArray{})) -> pure . Just $ IDType semTy (Just CTVariable)
      _ -> pure Nothing
  getExprRecordedType (ExpDataRef _ _ base ref) = do
    mTy <- getExprRecordedType base
    case mTy of
      Just (IDType (Just (TCustom n)) _) -> do
        mStructEnv <- gets (M.lookup n . structs)
        case mStructEnv of
          Nothing -> pure Nothing
          Just env -> pure $ M.lookup (varName ref) env
      x -> pure x
  getExprRecordedType _ = pure Nothing
  
  -- Set the idType annotation
  setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a)
  setIDType ty x =
      let a = getAnnotation x
       in setAnnotation (a { idType = Just ty }) x
  
  -- Get the idType annotation
  getIDType :: (Annotated f, Data a) => f (Analysis a) -> Maybe IDType
  getIDType x = idType (getAnnotation x)
  
  -- | For all types holding an 'IDType' (in an 'Analysis'), set the 'SemType'
  --   field of the 'IDType'.
  setSemType :: (Annotated f, Data a) => SemType -> f (Analysis a) -> f (Analysis a)
  setSemType st x =
      let anno  = getAnnotation x
          idt   = idType anno
          anno' = anno { idType = Just (setIDTypeSemType idt) }
       in setAnnotation anno' x
    where
      setIDTypeSemType :: Maybe IDType -> IDType
      setIDTypeSemType (Just (IDType _ mCt)) = IDType (Just st) mCt
      setIDTypeSemType Nothing               = IDType (Just st) Nothing
  
  -- Set the CType part of idType annotation
  --setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a)
  --setCType ct x
  --  | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x
  --  | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x
  
  type UniFunc f g a = f (Analysis a) -> [g (Analysis a)]
  
  allProgramUnits :: Data a => UniFunc ProgramFile ProgramUnit a
  allProgramUnits = universeBi
  
  allDeclarators :: Data a => UniFunc ProgramFile Declarator a
  allDeclarators = universeBi
  
  allStatements :: (Data a, Data (f (Analysis a))) => UniFunc f Statement a
  allStatements = universeBi
  
  allExpressions :: (Data a, Data (f (Analysis a))) => UniFunc f Expression a
  allExpressions = universeBi
  
  isAttrDimension :: Attribute a -> Bool
  isAttrDimension AttrDimension {} = True
  isAttrDimension _                = False
  
  isAttrParameter :: Attribute a -> Bool
  isAttrParameter AttrParameter {} = True
  isAttrParameter _                = False
  
  isAttrExternal :: Attribute a -> Bool
  isAttrExternal AttrExternal {} = True
  isAttrExternal _               = False
  
  isIxSingle :: Index a -> Bool
  isIxSingle IxSingle {} = True
  isIxSingle _           = False
  
  --------------------------------------------------
  
  -- Most, but not all deriving functions can report type errors. So most of these
  -- functions are in the Infer monad.
  
  -- | Attempt to derive the 'SemType' of a variable from the relevant parts of
  --   its surrounding 'StDeclaration'.
  --
  -- This is an example of a simple declaration:
  --
  --     INTEGER(8) :: var_name
  --
  -- A declaration holds a 'TypeSpec' (left of the double colon; LHS) and a list
  -- of 'Declarator's (right of the double colon; RHS). However, CHARACTER
  -- variable are allowed to specify their length via special syntax on the RHS:
  --
  --     CHARACTER :: string*10
  --
  -- so to handle that, this function takes that length as a Maybe Expression (as
  -- provided in 'StDeclaration').
  --
  -- If a length was defined on both sides, the declaration length (RHS) is used.
  -- This matches gfortran's behaviour, though even with -Wall they don't warn on
  -- this rather confusing syntax usage. We report a (soft) type error.
  deriveSemTypeFromDeclaration
      :: (MonadState InferState m, MonadReader InferConfig m)
      => SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
  deriveSemTypeFromDeclaration stmtSs declSs ts@(TypeSpec tsA tsSS bt mSel) mLenExpr =
      case mLenExpr of
        Nothing ->
          -- no RHS length, can continue with regular deriving
          deriveSemTypeFromTypeSpec ts
  
        Just lenExpr ->
          -- we got a RHS length; only CHARACTERs permit this
          case bt of
            TypeCharacter -> deriveCharWithLen lenExpr
  
            _ -> do
              -- oh dear! probably the nonstandard kind param syntax @INTEGER x*2@
              asks inferConfigAcceptNonCharLengthAsKind >>= \case
                False -> do
                  flip typeError stmtSs $
                      "non-CHARACTER variable given a length @ "
                   <> show (getSpan lenExpr)
                   <> ": ignoring"
                  deriveSemTypeFromTypeSpec ts
                True -> do
                  flip typeError stmtSs $
                      "non-CHARACTER variable given a length @ "
                   <> show (getSpan lenExpr)
                   <> ": treating as nonstandard kind parameter syntax"
  
                  -- silly check to give an in-depth type error
                  case mSel of
                    Just (Selector sA sSS sLen sMKpExpr) -> do
                      _ <- case sMKpExpr of
                             Nothing     -> return ()
                             Just kpExpr -> do
                               -- also got a LHS kind param, inform that we are
                               -- overriding
                               flip typeError stmtSs $
                                   "non-CHARACTER variable"
                                <> " given both"
                                <> " LHS kind @ " <> show (getSpan kpExpr) <> " and"
                                <> " nonstandard RHS kind @ " <> show (getSpan lenExpr)
                                <> ": specific RHS declarator overrides"
                               return ()
                      let sel = Selector sA sSS sLen (Just lenExpr)
                          ts' = TypeSpec tsA tsSS bt (Just sel)
                       in deriveSemTypeFromTypeSpec ts'
                    Nothing ->
                      let sel = Selector undefined undefined Nothing (Just lenExpr)
                          ts' = TypeSpec tsA tsSS bt (Just sel)
                       in deriveSemTypeFromTypeSpec ts'
  
    where
      -- Function called when we have a TypeCharacter and a RHS declarator length.
      -- (no function signature due to type variable scoping)
      --deriveCharWithLen :: Expression a -> Infer SemType
      deriveCharWithLen lenExpr =
          case mSel of
            Just (Selector selA selSs mSelLenExpr mKindExpr) -> do
              _ <- case mSelLenExpr of
                     Just _ -> do
                        -- both LHS & RHS lengths: surprising syntax, notify user
                        -- Ben has seen this IRL: a high-ranking Fortran
                        -- tutorial site uses it (2021-04-30):
                        -- http://web.archive.org/web/20210118202503/https://www.tutorialspoint.com/fortran/fortran_strings.htm
                       flip typeError stmtSs $
                           "warning: CHARACTER variable @ " <> show declSs
                        <> " has length in LHS type spec and RHS declarator"
                        <> " -- specific RHS declarator overrides"
                     _ -> return ()
              -- overwrite the Selector with RHS length expr & continue
              let sel' = Selector selA selSs (Just lenExpr) mKindExpr
              deriveSemTypeFromBaseTypeAndSelector TypeCharacter sel'
            Nothing ->
              -- got RHS len, no Selector (e.g. @CHARACTER :: x*3 = "sup"@)
              -- naughty let binding to avoid re-hardcoding default char kind
              let (TCharacter _ k) = deriveSemTypeFromBaseType TypeCharacter
               in return $ TCharacter (charLenSelector' lenExpr) k
  
  -- | Attempt to derive a 'SemType' from a 'TypeSpec'.
  deriveSemTypeFromTypeSpec
      :: MonadState InferState m => TypeSpec a -> m SemType
  deriveSemTypeFromTypeSpec (TypeSpec _ _ bt mSel) =
      case mSel of
        -- Selector present: we might have kind/other info provided
        Just sel -> deriveSemTypeFromBaseTypeAndSelector bt sel
        -- no Selector: derive using default kinds etc.
        Nothing  -> return $ deriveSemTypeFromBaseType bt
  
  -- | Attempt to derive a SemType from a 'BaseType' and a 'Selector'.
  deriveSemTypeFromBaseTypeAndSelector
      :: MonadState InferState m => BaseType -> Selector a -> m SemType
  deriveSemTypeFromBaseTypeAndSelector bt (Selector _ ss mLen mKindExpr) = do
      st <- deriveFromBaseTypeAndKindExpr mKindExpr
      case mLen of
        Nothing      -> return st
        Just lenExpr ->
          case st of
            TCharacter _ kind ->
              let charLen = charLenSelector' lenExpr
               in return $ TCharacter charLen kind
            _ -> do
              -- (unreachable code path in correct parser operation)
              typeError "only CHARACTER types can specify length (separate to kind)" ss
              return st
    where
      deriveFromBaseTypeAndKindExpr = \case
        Nothing -> defaultSemType
        Just kindExpr ->
          case kindExpr of
            -- FIXME: only support integer kind selectors for now, no params/exprs
            -- (would require a wide change across codebase)
            ExpValue _ _ (ValInteger k _) ->
              deriveSemTypeFromBaseTypeAndKind bt (read k)
            _ -> do
              typeError "unsupported or invalid kind selector, only literal integers allowed" (getSpan kindExpr)
              defaultSemType
      defaultSemType = return $ deriveSemTypeFromBaseType bt
  
  -- | Derive 'SemType' directly from 'BaseType', using relevant default kinds.
  deriveSemTypeFromBaseType :: BaseType -> SemType
  deriveSemTypeFromBaseType = \case
    TypeInteger         -> TInteger 4
    TypeReal            -> TReal    4
    TypeComplex         -> TComplex 4
    TypeLogical         -> TLogical 4
  
    -- Fortran specs & compilers seem to agree on equating these intrinsic types
    -- to others with a larger kind, so we drop the extra syntactic info here.
    TypeDoublePrecision -> TReal    8
    TypeDoubleComplex   -> TComplex 8
  
    -- BYTE: HP's Fortran 90 reference says that BYTE is an HP extension, equates
    -- it to INTEGER(1), and indicates that it doesn't take a kind selector.
    -- Don't know how BYTEs are used in the wild. I wonder if we could safely
    -- equate BYTE to (TInteger 1)?
    TypeByte            -> TByte    noKind
  
    -- CHARACTERs default to len=1, kind=1 (non-1 is rare)
    TypeCharacter       -> TCharacter (CharLenInt 1) 1
  
    -- FIXME: this is where Fortran specs diverge, and fortran-vars doesn't
    -- support beyond F77e. Sticking with what passes the fortran-vars tests.
    ClassStar           -> TCustom "ClassStar"
    TypeCustom    str   -> TCustom str
    ClassCustom   str   -> TCustom str
  
  noKind :: Kind
  noKind = -1
  
  deriveSemTypeFromBaseTypeAndKind
      :: MonadState InferState m => BaseType -> Kind -> m SemType
  deriveSemTypeFromBaseTypeAndKind bt k =
      return $ setTypeKind (deriveSemTypeFromBaseType bt) k
  
  --------------------------------------------------
  
  -- Local variables:
  -- mode: haskell
  -- haskell-program-name: "cabal repl"
  -- End:
  