{-
Tock: a compiler for parallel languages
Copyright (C) 2007, 2008  University of Kent

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 2 of the License, or (at your
option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

-- | Type inference and checking.
module Types
  (
    specTypeOfName, typeOfSpec, typeOfSpec', abbrevModeOfName, underlyingType, underlyingTypeOf, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec
    , isRealType, isIntegerType, isNumericType, isCaseableType, isScalarType, isDataType, isCommunicableType, isSequenceType, isMobileType
    , resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain
    , isOperator, functionOperator, builtInOperator, occamDefaultOperator, occamBuiltInOperatorFunctions, occamOperatorTranslateDefault
    , returnTypesOfFunction
    , BytesInResult(..), bytesInType, countReplicator, countStructured, computeStructured

    , makeAbbrevAM, makeConstant, makeConstant', makeDimension, specificDimSize
    , addOne, subOne, addExprs, subExprs, mulExprs, divExprs, remExprs
    , addOneInt, subOneInt, addExprsInt, subExprsInt, mulExprsInt, divExprsInt
    , dyadicExpr, dyadicExprInt
    , addDimensions, applyDimension, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType
    , applyDirection
    , recordFields, recordAttr, protocolItems, dirAttr

    , leastGeneralSharedTypeRain
    
    , ASTTypeable(..), findMeta
  ) where

import Control.Monad.State
import Data.Char
import Data.Generics (Data)
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Data.Ord
import qualified Data.Set as Set

import qualified AST as A
import CompState hiding (CSM) -- all these functions are read-only!
import Errors
import EvalLiterals
import Intrinsics
import Metadata
import PrettyShow
import ShowCode
import Traversal
import TypeSizes
import Utils

class ASTTypeable a where
  astTypeOf :: (CSMR m, Die m) => a -> m A.Type

instance ASTTypeable A.Type where
  astTypeOf = return

underlyingTypeOf :: (ASTTypeable a, CSMR m, Die m) => Meta -> a -> m A.Type
underlyingTypeOf m = underlyingType m <.< astTypeOf

-- | Gets the 'A.AbbrevMode' for a given 'A.Name' from the recorded types in the 'CompState'.  Dies with an error if the name is unknown.
abbrevModeOfName :: (CSMR m, Die m) => A.Name -> m A.AbbrevMode
abbrevModeOfName n
    = liftM A.ndAbbrevMode (lookupNameOrError n $ dieP (A.nameMeta n) $ "Could not find abbreviation mode in abbrevModeOfName for: " ++ (show $ A.nameName n))

instance ASTTypeable A.Name where
  astTypeOf = typeOfName

instance ASTTypeable A.Formal where
  astTypeOf (A.Formal _ t _) = return t

instance ASTTypeable A.Actual where
  astTypeOf (A.ActualVariable v) = astTypeOf v
  astTypeOf (A.ActualExpression e) = astTypeOf e
  astTypeOf (A.ActualClaim v)
              =  do t <- typeOfVariable v
                    case t of
                          A.Chan attr innerT -> return $ A.Chan (attr
                            { A.caWritingShared = A.Unshared
                            , A.caReadingShared = A.Unshared
                            }) innerT
                          A.ChanEnd A.DirInput _ innerT
                            -> return $ A.ChanEnd A.DirInput A.Unshared innerT
                          A.ChanEnd A.DirOutput _ innerT
                            -> return $ A.ChanEnd A.DirOutput A.Unshared innerT
                          A.ChanDataType dir _ innerT -> return $ A.ChanDataType dir A.Unshared innerT
                          _ -> dieP (findMeta v) "Item in claim not channel"
  astTypeOf (A.ActualChannelArray (v:vs))
    = do t <- typeOfVariable v
         return $ A.Array [A.Dimension $ makeConstant (findMeta v) (length vs+1)] t


-- | Gets the 'A.Type' for a given 'A.Name' by looking at its definition in the 'CompState'.  Dies with an error if the name is unknown.
typeOfName :: (CSMR m, Die m) => A.Name -> m A.Type
typeOfName n
    =  do st <- specTypeOfName n
          t <- typeOfSpec st
          case t of
            Just t' -> return t'
            Nothing -> dieP (findMeta n) $ "cannot type name " ++ pshow n ++
              ":" ++ show st

typeOfSpec' :: (CSMR m, Die m) => A.SpecType -> m (Maybe (A.Type, A.Type -> A.SpecType))
typeOfSpec' st
        = case st of
            A.Declaration a t -> return $ Just (t, A.Declaration a)
            A.Is a b t c -> return $ Just (t, \t' -> A.Is a b t' c)
            A.Retypes a b t c -> return $ Just (t, \t' -> A.Retypes a b t' c)
            A.RetypesExpr a b t c
              -> return $ Just (t, \t' -> A.RetypesExpr a b t' c)
            A.Rep _ (A.For _ _ e _) -> do t <- astTypeOf e
                                          return $ Just (t, error "typeOfSpec'")
            A.Rep _ (A.ForEach _ e) ->
              do t <- astTypeOf e
                 case t of
                   A.List t' -> return $ Just (t', error "typeOfSpec'")
                   A.Array _ t' -> return $ Just (t', error "typeOfSpec'")
                   _ -> return Nothing
            _ -> return Nothing

typeOfSpec :: (CSMR m, Die m) => A.SpecType -> m (Maybe A.Type)
typeOfSpec = liftM (fmap fst) . typeOfSpec'

--{{{  identifying types
-- | Get the fields of a record type.
recordFields :: (CSMR m, Die m) => Meta -> A.Type -> m [(A.Name, A.Type)]
recordFields m (A.Record rec)
    =  do st <- specTypeOfName rec
          case st of
            A.RecordType _ _ fs -> return fs
            _ -> dieP m "not record type"
recordFields m (A.ChanDataType A.DirInput _ n)
    =  do st <- specTypeOfName n
          case st of
            A.ChanBundleType _ _ fs -> return fs
            _ -> dieP m "not record type"
-- Directions are flipped for the ! end:
recordFields m (A.ChanDataType A.DirOutput _ n)
    =  do st <- specTypeOfName n
          case st of
            A.ChanBundleType _ _ fs -> return [(n, flipDirOfEnd t) | (n, t) <- fs]
            _ -> dieP m "not record type"
  where
    flipDirOfEnd (A.ChanEnd dir attr t) = A.ChanEnd (flipDir dir) attr t
    flipDir A.DirInput = A.DirOutput
    flipDir A.DirOutput = A.DirInput
recordFields m _ = dieP m "not record type"

recordAttr :: (CSMR m, Die m) => Meta -> A.Type -> m A.RecordAttr
recordAttr m (A.Record rec)
    =  do st <- specTypeOfName rec
          case st of
            A.RecordType _ attr _ -> return attr
            _ -> dieP m "not record type"
recordAttr m _ = dieP m "not record type"

dirAttr :: A.Direction -> A.ChanAttributes -> A.ShareMode
dirAttr A.DirInput = A.caReadingShared
dirAttr A.DirOutput = A.caWritingShared

-- | Get the type of a record field.
typeOfRecordField :: (CSMR m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
typeOfRecordField m t field
    =  do fs <- recordFields m t
          checkJust (Just m, "unknown record field") $ lookup field fs

-- | Apply a plain subscript to a type.
plainSubscriptType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
plainSubscriptType m (A.Array (_:ds) t)
    = return $ case ds of
                 [] -> t
                 _ -> A.Array ds t
plainSubscriptType m (A.Mobile t) = plainSubscriptType m t
plainSubscriptType m t = diePC m $ formatCode "Subscript of non-array type: %" t

-- | Turn an expression into a 'Dimension'.
-- If the expression is constant, it'll produce 'Dimension'; if not, it'll
-- produce 'UnknownDimension'.
dimensionFromExpr :: A.Expression -> A.Dimension
dimensionFromExpr e
    = if isConstant e
        then A.Dimension $ e
        else A.UnknownDimension

-- | Apply a subscript to a type, and return what the type is after it's been
-- subscripted.
subscriptType :: (CSMR m, Die m) => A.Subscript -> A.Type -> m A.Type
subscriptType sub A.Infer
    = return $ A.Infer
subscriptType sub t@(A.UserDataType _)
    = resolveUserType (findMeta sub) t >>= subscriptType sub
subscriptType (A.SubscriptFromFor m _ _ count) (A.Array (_:ds) t)
    = return $ A.Array (dimensionFromExpr count : ds) t
subscriptType (A.SubscriptFrom m _ base) (A.Array (d:ds) t)
    = return $ A.Array (dim : ds) t
  where
    dim = case d of
            A.Dimension size -> dimensionFromExpr $ subExprsInt size base
            _ -> A.UnknownDimension
subscriptType (A.SubscriptFor m _ count) (A.Array (_:ds) t)
    = return $ A.Array (dimensionFromExpr count : ds) t
subscriptType (A.SubscriptField m tag) t = typeOfRecordField m t tag
subscriptType (A.Subscript m _ _) t = plainSubscriptType m t
subscriptType sub t = diePC (findMeta sub) $ formatCode "Unsubscriptable type: %" t

-- | The inverse of 'subscriptType': given a type that we know is the result of
-- a subscript, return what the type being subscripted is.
unsubscriptType :: A.Subscript -> A.Type -> Maybe A.Type
unsubscriptType _ A.Infer
    = Just $ A.Infer
unsubscriptType (A.SubscriptFromFor _ _ _ _) t
    = Just $ removeFixedDimension t
unsubscriptType (A.SubscriptFrom _ _ _) t
    = Just $ removeFixedDimension t
unsubscriptType (A.SubscriptFor _ _ _) t
    = Just $ removeFixedDimension t
unsubscriptType (A.SubscriptField m _) t
    = Nothing
unsubscriptType (A.Subscript _ _ sub) t
    = Just $ addDimensions [A.UnknownDimension] t

-- | Just remove the first dimension from an array type -- like doing
-- subscriptType with constant 0 as a subscript, but without the checking.
-- This is used for the couple of cases where we know it's safe and don't want
-- the usage check.
trivialSubscriptType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
trivialSubscriptType _ A.Infer = return A.Infer
trivialSubscriptType m t@(A.UserDataType _)
    = resolveUserType m t >>= trivialSubscriptType m
trivialSubscriptType _ (A.Array [d] t) = return t
trivialSubscriptType _ (A.Array (d:ds) t) = return $ A.Array ds t
trivialSubscriptType m (A.Mobile t) = trivialSubscriptType m t
trivialSubscriptType m t = diePC m $ formatCode "not plain array type: %" t

instance ASTTypeable A.Variable where
  astTypeOf = typeOfVariable

-- | Gets the 'A.Type' of a 'A.Variable' by looking at the types recorded in the 'CompState'.
typeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.Type
typeOfVariable (A.Variable m n) = typeOfName n
typeOfVariable (A.SubscriptedVariable m s v)
    = typeOfVariable v >>= subscriptType s
typeOfVariable (A.DerefVariable m v)
    = do t <- typeOfVariable v >>= resolveUserType m
         case t of
           A.Mobile innerT -> return innerT
           _ -> diePC m $ formatCode "Dereference applied to non-mobile variable of type %" t
typeOfVariable (A.DirectedVariable m dir v)
    = do t <- typeOfVariable v
         case t of
           A.ChanEnd dir' _ _ ->
             if dir == dir'
               then return t
               else dieP m $ "Attempted to reverse direction of a channel-end"
           A.Chan attr innerT -> return $ A.ChanEnd dir (dirAttr dir attr) innerT
           A.Array ds (A.Chan attr innerT)
             -> return $ A.Array ds (A.ChanEnd dir (dirAttr dir attr) innerT)
           A.Array _ (A.ChanEnd dir' _ _) ->
             if dir == dir'
               then return t
               else dieP m $ "Attempted to reverse direction of a channel-end"
           A.Infer -> return $ A.ChanEnd dir A.Unshared A.Infer
           _ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t
typeOfVariable (A.VariableSizes m v)
  = do t <- typeOfVariable v
       case t of
         A.Array ds _ -> return $ A.Array [A.Dimension $ makeConstant m $ length ds] A.Int
         A.Mobile (A.Array ds _) -> return $ A.Array [A.Dimension $ makeConstant m $ length ds] A.Int
         _ -> diePC m $ formatCode "Attempted to get size of non-array: % (type: %)" v t

-- | Get the abbreviation mode of a variable.
abbrevModeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.AbbrevMode
abbrevModeOfVariable (A.Variable _ n) = abbrevModeOfName n
abbrevModeOfVariable (A.SubscriptedVariable _ sub v) = abbrevModeOfVariable v
abbrevModeOfVariable (A.DirectedVariable _ _ v) = abbrevModeOfVariable v
abbrevModeOfVariable (A.DerefVariable _ v) = return A.Original
abbrevModeOfVariable (A.VariableSizes {}) = return A.Original

instance ASTTypeable A.Expression where
  astTypeOf = typeOfExpression

-- | Gets the 'A.Type' of an 'A.Expression'.  This function assumes that the expression has already been type-checked.
typeOfExpression :: (CSMR m, Die m) => A.Expression -> m A.Type
typeOfExpression e
    = case e of
        A.MostPos m t -> return t
        A.MostNeg m t -> return t
        A.SizeType m t -> return A.Int
        A.SizeExpr m t -> return A.Int
        A.Conversion m cm t e -> return t
        A.ExprVariable m v -> typeOfVariable v
        A.Literal _ t _ -> return t
        A.True m -> return A.Bool
        A.False m -> return A.Bool
        A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n
        A.IntrinsicFunctionCall m s _ -> liftM head $ returnTypesOfIntrinsic m s
        A.SubscriptedExpr m s e ->
          typeOfExpression e >>= subscriptType s
        A.BytesInExpr m e -> return A.Int
        A.BytesInType m t -> return A.Int
        A.OffsetOf m t n -> return A.Int
        A.AllocMobile _ t _ -> return t
        A.CloneMobile _ e -> typeOfExpression e
        A.IsDefined {} -> return A.Bool
--}}}

-- | Gets the return type(s) of a function call from the 'CompState'.
returnTypesOfFunction :: (CSMR m, Die m) => A.Name -> m [A.Type]
returnTypesOfFunction n
    =  do st <- specTypeOfName n
          case st of
            A.Function _ _ rs _ _ -> return rs
            -- If it's not defined as a function, it might have been converted to a proc.
            _ ->
              do ps <- getCompState
                 checkJust (Just $ findMeta n, "not defined as a function") $
                   Map.lookup (A.nameName n) (csFunctionReturns ps)

returnTypesOfIntrinsic :: (CSMR m, Die m) => Meta -> String -> m [A.Type]
returnTypesOfIntrinsic m s
 = do frontend <- getCompState >>* csFrontend
      let intrinsicList = case frontend of
            FrontendOccam -> intrinsicFunctions
            FrontendRain -> rainIntrinsicFunctions
      case lookup s intrinsicList of
        Just (rts, _) -> return rts
        Nothing -> dieP m $ "unknown intrinsic function " ++ s

-- | Get the items in a channel's protocol (for typechecking).
-- Returns Left if it's a simple protocol, Right if it's tagged.
protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => Meta -> a -> m (Either [A.Type] [(A.Name, [A.Type])])
protocolItems m v
    =  do chanT <- astTypeOf v
          t <- case chanT of
                 A.Chan _ t -> return t
                 A.ChanEnd _ _ t -> return t
                 _ -> dieP m $ "Expected a channel variable, but this is of type: " ++ show chanT
          case t of
            A.UserProtocol proto ->
              do st <- specTypeOfName proto
                 case st of
                   A.Protocol _ ts -> return $ Left ts
                   A.ProtocolCase _ nts -> return $ Right nts
            _ -> return $ Left [t]

-- | Gets the 'A.AbrrevMode' of a 'A.SpecType' directly.
abbrevModeOfSpec :: A.SpecType -> A.AbbrevMode
abbrevModeOfSpec s
    = case s of
        A.Is _ am _ _ -> am
        A.Retypes _ am _ _ -> am
        A.RetypesExpr _ am _ _ -> am
        _ -> A.Original

-- | Add array dimensions to a type; if it's already an array it'll just add
-- the new dimensions to the existing array.
addDimensions :: [A.Dimension] -> A.Type -> A.Type
addDimensions newDs (A.Array ds t) = A.Array (newDs ++ ds) t
addDimensions ds t = A.Array ds t

-- | Set the first dimension of an array type.
applyDimension :: A.Dimension -> A.Type -> A.Type
applyDimension dim (A.Array (_:ds) t) = A.Array (dim : ds) t
applyDimension _ t = t

-- | Return a type with any enclosing arrays removed; useful for identifying
-- things that should be channel names, timer names, etc. in the parser.
stripArrayType :: A.Type -> A.Type
stripArrayType (A.Array _ t) = stripArrayType t
stripArrayType t = t

-- | Remove one fixed dimension from a type.
removeFixedDimension :: A.Type -> A.Type
removeFixedDimension (A.Array (A.Dimension _:ds) t) = A.Array (A.UnknownDimension:ds) t
removeFixedDimension t = t

-- | Remove any fixed array dimensions from a type.
removeFixedDimensions :: A.Type -> A.Type
removeFixedDimensions (A.Array ds t) = A.Array [A.UnknownDimension | _ <- ds] t
removeFixedDimensions t = t

-- | Given the abbreviation mode of something, return what the abbreviation
-- mode of something that abbreviated it would be.
makeAbbrevAM :: A.AbbrevMode -> A.AbbrevMode
makeAbbrevAM A.Original = A.Abbrev
makeAbbrevAM am = am

-- | Generate a constant expression from an integer -- for array sizes and the
-- like.
makeConstant :: Meta -> Int -> A.Expression
makeConstant m = makeConstant' m A.Int . toInteger

makeConstant' :: Meta -> A.Type -> Integer -> A.Expression
makeConstant' m t n = A.Literal m t $ A.IntLiteral m (show n)

-- | Generate a constant dimension from an integer.
makeDimension :: Meta -> Int -> A.Dimension
makeDimension m n = A.Dimension $ makeConstant m n

-- | Apply a direction to a type.
applyDirection :: Die m => Meta -> A.Direction -> A.Type -> m A.Type
applyDirection m dir (A.Array ds t)
    = applyDirection m dir t >>* A.Array ds
applyDirection m dir (A.Chan ca t)
    = return $ A.ChanEnd dir (dirAttr dir ca) t
applyDirection m _ t
    = dieP m "Direction specified on non-channel type"

-- | Checks whether a given conversion can be done implicitly in Rain
-- Parameters are src dest
isImplicitConversionRain :: A.Type -> A.Type -> Bool
isImplicitConversionRain x y
  = if (x == y)
      then True
      else if (x == A.Bool || y == A.Bool)
             then False
             else isSafeConversion x y

-- | Is a conversion between two types precise (i.e. do you need to specify
-- ROUND or TRUNC when doing it)?
isPreciseConversion :: A.Type -> A.Type -> Bool
isPreciseConversion A.Real32 A.Real64 = True
isPreciseConversion fromT toT
    = fromT == toT || not (isRealType fromT || isRealType toT)

-- | Will a conversion between two types always succeed?
--Parameters are src dest
isSafeConversion :: A.Type -> A.Type -> Bool
isSafeConversion A.Real32 A.Real64 = True
isSafeConversion src dest = (src' == dest') || ((src' == A.Bool || isIntegerType src') && (dest' == A.Bool || isIntegerType dest') && (findCastRoute dest' src'))
  where
    src' = convInt src
    dest' = convInt dest

    --Turn Int into Int32:
    convInt :: A.Type -> A.Type
    convInt A.Int = A.Int32
    convInt t = t

    --Parameters are dest src
    findCastRoute :: A.Type -> A.Type -> Bool
    findCastRoute dest src
        --Either a direct converstion is possible
      = (elem (dest,src) possibleConversions)
        --Or there exists some chained conversion:
        || (any (findCastRoute dest) (findDests src possibleConversions))

    --Finds all the conversions from the src type using the given list of (dest,src)
    --Note that the list must not allow any cycles!  (or else we will engage in infinite recursion)
    findDests :: A.Type -> [(A.Type,A.Type)] -> [A.Type]
    findDests _ [] = []
    findDests src ((dest,src'):ts) = if src == src' then dest : (findDests src ts) else findDests src ts

    --Listed in order (dest, src)
    --Signed numbers cannot be safely cast to unsigned numbers.  So (A.UInt16, A.Int8) isn't possible
    possibleConversions :: [(A.Type,A.Type)]
    possibleConversions
      = [
          (A.Byte, A.Bool)
          ,(A.Int8, A.Bool)

          ,(A.Int16, A.Int8)
          ,(A.Int16, A.Byte)
          ,(A.Int32, A.Int16)
          ,(A.Int32, A.UInt16)
          ,(A.Int64, A.Int32)
          ,(A.Int64, A.UInt32)

          ,(A.UInt16, A.Byte)
          ,(A.UInt32, A.UInt16)
          ,(A.UInt64, A.UInt32)
        ]


-- | Works out the least-general type that all given types can be upcast to.  Does not work with A.Int (as this function is expected only to be used by Rain)
-- As you would expect from the name, this function specifically follows the conversion rules for Rain.
leastGeneralSharedTypeRain :: [A.Type] -> Maybe A.Type
leastGeneralSharedTypeRain [] = Nothing
leastGeneralSharedTypeRain [t] = Just t
leastGeneralSharedTypeRain list@(t:ts)
  = if (all ((==) t) ts) then Just t else
      if (all isIntegerType list) then findInt list
      else Nothing
  where
    findInt :: [A.Type] -> Maybe A.Type
    findInt list = if null candidates
                     then Nothing
                     else Just $ snd $ maximumBy (comparing fst) candidates
                   where
                     candidates = if (all unsignedInt list) then (zip (map intSize list) list) else (allJustElseEmpty $ map findIntSigned list)

    signedInt :: A.Type -> Bool
    signedInt = not . unsignedInt

    unsignedInt :: A.Type -> Bool
    unsignedInt A.Byte = True
    unsignedInt A.UInt16 = True
    unsignedInt A.UInt32 = True
    unsignedInt A.UInt64 = True
    unsignedInt _ = False

    intSize :: A.Type -> Int
    intSize A.Byte = 1
    intSize A.UInt16 = 2
    intSize A.UInt32 = 4
    intSize A.UInt64 = 8
    intSize A.Int8 = 1
    intSize A.Int16 = 2
    intSize A.Int32 = 4
    intSize A.Int64 = 8
    intSize _ = 0 --should never happen

    --If all the items in the list are Just x, returns a list of them all.
    --If one (or more items) is Nothing, returns an empty list.
    allJustElseEmpty :: [Maybe a] -> [a]
    allJustElseEmpty ms = if (any isNothing ms) then [] else catMaybes ms

    --For each item in the list, get an ordered list of types we can cast to.
    findIntSigned :: A.Type -> Maybe (Int,A.Type)
    findIntSigned t = if (signedInt t)
                        then Just (intSize t,t)
                        --if it's unsigned, we need to cast it up by one type, assuming it's not already the biggest size
                        else transformMaybe (\x -> (intSize x,x)) (case t of
                               A.Byte -> Just A.Int16
                               A.UInt16 -> Just A.Int32
                               A.UInt32 -> Just A.Int64
                               A.UInt64 -> Nothing)

--{{{ classes of types
-- | Scalar integer types.
isIntegerType :: A.Type -> Bool
isIntegerType t
    = case t of
        A.Byte -> True
        A.UInt16 -> True
        A.UInt32 -> True
        A.UInt64 -> True
        A.Int8 -> True
        A.Int -> True
        A.Int16 -> True
        A.Int32 -> True
        A.Int64 -> True
        A.Time -> True
        _ -> False

-- | Scalar real types.
isRealType :: A.Type -> Bool
isRealType t
    = case t of
        A.Real32 -> True
        A.Real64 -> True
        _ -> False

-- | Numeric types.
isNumericType :: A.Type -> Bool
isNumericType t = isIntegerType t || isRealType t

-- | Types that are permitted as 'Case' selectors.
isCaseableType :: A.Type -> Bool
isCaseableType A.Bool = True
isCaseableType t = isIntegerType t

-- | All scalar types.
isScalarType :: A.Type -> Bool
isScalarType A.Bool = True
isScalarType t = isIntegerType t || isRealType t

-- | Types that can be used to define 'DataType's.
isDataType :: A.Type -> Bool
-- This may change in the future.
isDataType = isCommunicableType

-- | Types that can be communicated across a channel.
isCommunicableType :: A.Type -> Bool
isCommunicableType (A.Array _ t) = isCommunicableType t
isCommunicableType (A.List t) = isCommunicableType t
isCommunicableType (A.Record _) = True
isCommunicableType (A.Mobile _) = True
isCommunicableType t = isScalarType t

-- | Types that support 'Size' and subscripting.
isSequenceType :: Bool -> A.Type -> Bool
isSequenceType _ (A.Array _ _) = True
isSequenceType _ (A.List _) = True
isSequenceType True (A.Mobile t) = isSequenceType False t
isSequenceType _ _ = False

isMobileType :: (CSMR m, Die m) => A.Type -> m Bool
isMobileType (A.Mobile {}) = return True
isMobileType t@(A.Record n) = recordAttr (A.nameMeta n) t >>* A.mobileRecord
isMobileType (A.ChanDataType {}) = return True
isMobileType _ = return False

--}}}

--{{{ sizes of types
-- | The size in bytes of a data type.
data BytesInResult =
  BIJust A.Expression          -- ^ Just that many bytes.
  | BIOneFree A.Expression Int -- ^ An array type; A bytes, times unknown dimension B.
  | BIManyFree                 -- ^ An array type with multiple unknown dimensions.
  | BIUnknown                  -- ^ We can't tell the size at compile time.
  deriving (Show, Eq)

-- | Make a fixed-size 'BytesInResult'.
justSize :: CSMR m => Int -> m BytesInResult
justSize n = return $ BIJust $ makeConstant emptyMeta n

-- | Given the C and C++ values (in that order), selects according to the
-- backend. If the backend is not recognised, the C sizes are used.
justSizeBackends :: CSMR m => Int -> Int -> m BytesInResult
justSizeBackends c cxx
    =  do backend <- getCompState >>* csBackend
          case backend of
            BackendCPPCSP -> justSize c
            _ -> justSize cxx

-- | Return the size in bytes of a data type.
bytesInType :: (CSMR m, Die m) => A.Type -> m BytesInResult
bytesInType A.Bool = justSizeBackends cBoolSize cxxBoolSize
bytesInType A.Byte = justSize 1
bytesInType A.UInt16 = justSize 2
bytesInType A.UInt32 = justSize 4
bytesInType A.UInt64 = justSize 8
bytesInType A.Int8 = justSize 1
bytesInType A.Int = justSizeBackends cIntSize cxxIntSize
bytesInType A.Int16 = justSize 2
bytesInType A.Int32 = justSize 4
bytesInType A.Int64 = justSize 8
bytesInType A.Real32 = justSize 4
bytesInType A.Real64 = justSize 8
bytesInType a@(A.Array _ _) = bytesInArray 0 a
  where
    bytesInArray :: (CSMR m, Die m) => Int -> A.Type -> m BytesInResult
    bytesInArray num (A.Array [] t) = bytesInType t
    bytesInArray num (A.Array (d:ds) t)
        =  do ts <- bytesInArray (num + 1) (A.Array ds t)
              case (d, ts) of
                (A.Dimension n, BIJust m) -> return $ BIJust (mulExprsInt n m)
                (A.Dimension n, BIOneFree m x) -> return $ BIOneFree (mulExprsInt n m) x
                (A.UnknownDimension, BIJust m) -> return $ BIOneFree m num
                (A.UnknownDimension, BIOneFree _ _) -> return BIManyFree
                (_, _) -> return ts
bytesInType (A.Record n)
    =  do st <- specTypeOfName n
          case st of
            -- We can only do this for *packed* records -- for normal records,
            -- the compiler might insert padding.
            (A.RecordType _ (A.RecordAttr {A.packedRecord=True}) nts) -> bytesInList nts
            _ -> return $ BIUnknown
  where
    bytesInList :: (CSMR m, Die m) => [(A.Name, A.Type)] -> m BytesInResult
    bytesInList [] = justSize 0
    bytesInList ((_, t):rest)
        =  do bi <- bytesInType t
              br <- bytesInList rest
              case (bi, br) of
                (BIJust a, BIJust b) -> return $ BIJust (addExprsInt a b)
                (_, _) -> return BIUnknown
bytesInType _ = return $ BIUnknown
--}}}

-- | Get the number of items a replicator produces.
countReplicator :: A.Replicator -> A.Expression
countReplicator (A.For _ _ count _) = count

-- | Get the number of items in a Structured as an expression.
countStructured :: Data a => A.Structured a -> A.Expression
countStructured = computeStructured (\m _ -> makeConstant m 1)

-- | Compute an expression over a Structured.
computeStructured :: Data a => (Meta -> a -> A.Expression) -> A.Structured a -> A.Expression
computeStructured f (A.Spec _ (A.Specification _ _ (A.Rep m rep)) s)
    = mulExprsInt (countReplicator rep) (computeStructured f s)
computeStructured f (A.Spec _ _ s) = computeStructured f s
computeStructured f (A.ProcThen _ _ s) = computeStructured f s
computeStructured f (A.Only m x) = f m x
computeStructured f (A.Several m ss)
    = case ss of
        [] -> makeConstant m 0
        _ -> foldl1 addExprsInt (map (computeStructured f) ss)

specificDimSize :: Int -> A.Variable -> A.Variable
specificDimSize n v = A.SubscriptedVariable (findMeta v) (A.Subscript (findMeta v) A.NoCheck
  $ makeConstant (findMeta v) n) $ A.VariableSizes (findMeta v) v


functionOperator :: (CSMR m, Die m) => A.Name -> m (Maybe String)
functionOperator n
  = lookupNameOrError n (dieP (A.nameMeta n) $ "Can't find operator definition for " ++ A.nameName n)
      >>* A.ndOrigName
      >>* (\op -> if isOperator op then Just op else Nothing)

-- Only gives back a Just result if it's a non-overridden operator
builtInOperator :: (CSMR m, Die m) => A.Name -> m (Maybe String)
builtInOperator n
  = do mOp <- functionOperator n
       return $ case mOp of
         Nothing -> Nothing
         Just op
           | A.nameName n `Set.member` occamBuiltInOperatorFunctionsSet
             -> Just op
           | otherwise
             -> Nothing

isOperator :: String -> Bool
isOperator op = any (== op) operatorNames

operatorNames :: [String]
operatorNames =
  ["??"
  ,"@@"
  ,"$$"
  ,"%"
  ,"%%"
  ,"&&"
  ,"<%"
  ,"%>"
  ,"<&"
  ,"&>"
  ,"<]"
  ,"[>"
  ,"<@"
  ,"@>"
  ,"@"
  ,"++"
  ,"!!"
  ,"=="
  ,"^"
  ,"-"
  ,"MINUS"
  ,"~"
  ,"NOT"
  ,"+"
  ,"*"
  ,"/"
  ,"\\"
  ,"REM"
  ,"PLUS"
  ,"TIMES"
  ,"AFTER"
  ,"/\\"
  ,"\\/"
  ,"><"
  ,"BITNOT"
  ,"BITAND"
  ,"BITOR"
  ,"<<"
  ,">>"
  ,"AND"
  ,"OR"
  ,"="
  ,"<>"
  ,"<="
  ,"<"
  ,">="
  ,">"
  ]

-- | This gives a default mapping from operator (such as "+") to a valid name string
-- to be used in the backend (i.e. the Tock support headers), such as "add", which
-- will later be suffixed by the types in question.
occamOperatorTranslateDefault :: String -> String
occamOperatorTranslateDefault "+" = "add"
occamOperatorTranslateDefault "-" = "subtr"
occamOperatorTranslateDefault "*" = "mul"
occamOperatorTranslateDefault "/" = "div"
occamOperatorTranslateDefault "TIMES" = "times"
occamOperatorTranslateDefault "PLUS" = "plus"
occamOperatorTranslateDefault "MINUS" = "minus"
occamOperatorTranslateDefault "AFTER" = "after"
occamOperatorTranslateDefault ">" = "more"
occamOperatorTranslateDefault "<" = "less"
occamOperatorTranslateDefault ">=" = "moreEq"
occamOperatorTranslateDefault "<=" = "lessEq"
occamOperatorTranslateDefault "=" = "eq"
occamOperatorTranslateDefault "<>" = "notEq"
occamOperatorTranslateDefault "\\" = "rem"
occamOperatorTranslateDefault "REM" = "REM"
occamOperatorTranslateDefault "/\\" = "and"
occamOperatorTranslateDefault "\\/" = "or"
occamOperatorTranslateDefault "><" = "xor"
occamOperatorTranslateDefault "<<" = "lshift"
occamOperatorTranslateDefault ">>" = "rshift"
occamOperatorTranslateDefault "AND" = "and"
occamOperatorTranslateDefault "OR" = "or"
occamOperatorTranslateDefault "NOT" = "not"
occamOperatorTranslateDefault "~" = "not"
occamOperatorTranslateDefault cs = "op_" ++ concatMap (show . ord) cs

occamDefaultOperator :: String -> [A.Type] -> String
occamDefaultOperator op ts = "occam_" ++ occamOperatorTranslateDefault op
  ++ concatMap (('_':) . showOccam) ts

occamBuiltInOperatorFunctions :: [String]
occamBuiltInOperatorFunctions
  = [occamDefaultOperator n ts
    | (n, _, ts) <- occamIntrinsicOperators]

occamBuiltInOperatorFunctionsSet :: Set.Set String
occamBuiltInOperatorFunctionsSet = Set.fromList occamBuiltInOperatorFunctions

-- | Add one to an expression.
addOne :: (CSMR m, Die m) => A.Expression -> m A.Expression
addOne e = addExprs (makeConstant m 1) e
  where m = findMeta e

-- | Subtrace one from an expression.
subOne :: (CSMR m, Die m) => A.Expression -> m A.Expression
subOne e = subExprs e (makeConstant m 1)
  where m = findMeta e

-- | Add one to an expression.
addOneInt :: A.Expression -> A.Expression
addOneInt e = addExprsInt (makeConstant m 1) e
  where m = findMeta e

-- | Subtrace one from an expression.
subOneInt :: A.Expression -> A.Expression
subOneInt e = subExprsInt e (makeConstant m 1)
  where m = findMeta e

type DyadicExpr = A.Expression -> A.Expression -> A.Expression
type DyadicExprM = (CSMR m, Die m) => A.Expression -> A.Expression -> m A.Expression

dyadicExpr' :: (A.Type, A.Type) -> String -> DyadicExpr
dyadicExpr' (t0, t1) op a b
  = A.FunctionCall m (A.Name m $ occamDefaultOperator op [t0,t1]) [a, b]
  where
    m = findMeta a

dyadicExpr :: String -> DyadicExprM
dyadicExpr op a b = do ta <- astTypeOf a
                       tb <- astTypeOf b
                       return $ dyadicExpr' (ta, tb) op a b

dyadicExprInt :: String -> DyadicExpr
dyadicExprInt op = dyadicExpr' (A.Int, A.Int) op

-- | Add two expressions.
addExprs :: DyadicExprM
addExprs = dyadicExpr "+"

-- | Add two expressions.
subExprs :: DyadicExprM
subExprs = dyadicExpr "-"

-- | Multiply two expressions.
mulExprs :: DyadicExprM
mulExprs = dyadicExpr "*"

-- | Divide two expressions.
divExprs :: DyadicExprM
divExprs = dyadicExpr "/"

-- | Divide two expressions.
remExprs :: DyadicExprM
remExprs = dyadicExpr "\\"

-- | Add two expressions.
addExprsInt :: DyadicExpr
addExprsInt = dyadicExpr' (A.Int,A.Int) "+"

-- | Add two expressions.
subExprsInt :: DyadicExpr
subExprsInt = dyadicExpr' (A.Int,A.Int) "-"

-- | Multiply two expressions.
mulExprsInt :: DyadicExpr
mulExprsInt = dyadicExpr' (A.Int,A.Int) "*"

-- | Divide two expressions.
divExprsInt :: DyadicExpr
divExprsInt = dyadicExpr' (A.Int,A.Int) "/"