module AccessOps (byteArrayAccessOps, addrAccessOps) where

import Syntax

data ElementType = MkElementType
  { elt_name :: String
  , elt_rep_ty :: Ty
  , elt_desc :: String
  , elt_width :: Maybe Int
  }

machWord :: Maybe Int
machWord = Nothing

strToTy :: String -> Ty
strToTy s = TyApp (TyCon s) []

elementTypes :: [ElementType]
elementTypes =
  [ MkElementType "Char"      (strToTy "Char#"  ) "an 8-bit character"             (Just 1)
  , MkElementType "WideChar"  (strToTy "Char#"  ) "a 32-bit character"             (Just 4)
  , MkElementType "Int"       (strToTy "Int#"   ) "a word-sized integer"           machWord
  , MkElementType "Word"      (strToTy "Word#"  ) "a word-sized unsigned integer"  machWord
  , MkElementType "Addr"      (strToTy "Addr#"  ) "a machine address"              machWord
  , MkElementType "Float"     (strToTy "Float#" ) "a single-precision floating-point value"  (Just 4)
  , MkElementType "Double"    (strToTy "Double#") "a double-precision floating-point value"  (Just 8)
  , MkElementType "StablePtr" (TyApp (TyCon "StablePtr#") [TyVar "a"])
                  "a 'StablePtr#' value"  machWord
  ] ++ do
  n <- [8, 16, 32, 64]
  let mkDesc suff = (if n == 8 then "an " else "a ") ++ shows n suff
  [ MkElementType
      { elt_name = "Int" ++ show n
      , elt_rep_ty = strToTy $ "Int" ++ shows n "#"
      , elt_desc = mkDesc "-bit signed integer"
      , elt_width = Just (n `quot` 8)
      },
    MkElementType
      { elt_name = "Word" ++ show n
      , elt_rep_ty = strToTy $ "Word" ++ shows n "#"
      , elt_desc = mkDesc "-bit unsigned integer"
      , elt_width = Just (n `quot` 8)
      }
    ]

unalignedElementTypes :: [ElementType]
unalignedElementTypes
  = filter (\e -> elt_name e `notElem` ["Int8", "Word8"]) elementTypes
--unalignedElementTypes = filter (\e -> elt_width e /= Just 1) elementTypes

prettyOffset :: ElementType -> String
prettyOffset e = case elt_width e of
  Nothing -> "machine words"
  Just 1  -> "bytes"
  Just n  -> shows n "-byte words"

getAlignWarn :: ElementType -> String
getAlignWarn e = case elt_width e of
  Just 1 -> ""
  _ -> "On some platforms, the access may fail\n"
       ++ "for an insufficiently aligned @Addr#@."

mutableByteArrayS :: Ty
mutableByteArrayS = TyApp (TyCon "MutableByteArray#") [TyVar "s"]

stateS :: Ty
stateS = TyApp (TyCon "State#") [TyVar "s"]

readResTy :: ElementType -> Ty
readResTy e = TyF stateS (TyUTup [stateS, elt_rep_ty e])

writeResTy :: ElementType -> Ty
writeResTy e = TyF (elt_rep_ty e) (TyF stateS stateS)



mkIndexByteArrayOp :: ElementType -> Entry
mkIndexByteArrayOp e = PrimOpSpec
  { cons = "IndexByteArrayOp_" ++ elt_name e
  , name = "index" ++ elt_name e ++ "Array#"
  , ty = TyF (strToTy "ByteArray#")
       $ TyF (strToTy "Int#")
             (elt_rep_ty e)
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
  , opts = [OptionEffect CanFail]
  }

mkUnalignedIndexByteArrayOp :: ElementType -> Entry
mkUnalignedIndexByteArrayOp e = PrimOpSpec
  { cons = "IndexByteArrayOp_Word8As" ++ elt_name e
  , name = "indexWord8ArrayAs" ++ elt_name e ++ "#"
  , ty = TyF (strToTy "ByteArray#")
       $ TyF (strToTy "Int#")
             (elt_rep_ty e)
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect CanFail]
  }

mkReadByteArrayOp :: ElementType -> Entry
mkReadByteArrayOp e = PrimOpSpec
  { cons = "ReadByteArrayOp_" ++ elt_name e
  , name = "read" ++ elt_name e ++ "Array#"
  , ty = TyF mutableByteArrayS
       $ TyF (strToTy "Int#")
       $ readResTy e
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkUnalignedReadByteArrayOp :: ElementType -> Entry
mkUnalignedReadByteArrayOp e = PrimOpSpec
  { cons = "ReadByteArrayOp_Word8As" ++ elt_name e
  , name = "readWord8ArrayAs" ++ elt_name e ++ "#"
  , ty = TyF mutableByteArrayS
       $ TyF (strToTy "Int#")
       $ readResTy e
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkWriteByteArrayOp :: ElementType -> Entry
mkWriteByteArrayOp e = PrimOpSpec
  { cons = "WriteByteArrayOp_" ++ elt_name e
  , name = "write" ++ elt_name e ++ "Array#"
  , ty = TyF mutableByteArrayS
       $ TyF (strToTy "Int#")
       $ writeResTy e
  , cat = GenPrimOp
  , desc = "Write " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkUnalignedWriteByteArrayOp :: ElementType -> Entry
mkUnalignedWriteByteArrayOp e = PrimOpSpec
  { cons = "WriteByteArrayOp_Word8As" ++ elt_name e
  , name = "writeWord8ArrayAs" ++ elt_name e ++ "#"
  , ty = TyF mutableByteArrayS
       $ TyF (strToTy "Int#")
       $ writeResTy e
  , cat = GenPrimOp
  , desc = "Write " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }


byteArrayAccessOps :: [Entry]
byteArrayAccessOps
  =  map mkIndexByteArrayOp elementTypes
  ++ map mkUnalignedIndexByteArrayOp unalignedElementTypes
  ++ map mkReadByteArrayOp elementTypes
  ++ map mkUnalignedReadByteArrayOp unalignedElementTypes
  ++ map mkWriteByteArrayOp elementTypes
  ++ map mkUnalignedWriteByteArrayOp unalignedElementTypes



mkIndexOffAddrOp :: ElementType -> Entry
mkIndexOffAddrOp e = PrimOpSpec
  { cons = "IndexOffAddrOp_" ++ elt_name e
  , name = "index" ++ elt_name e ++ "OffAddr#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
             (elt_rep_ty e)
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
           ++ getAlignWarn e
  , opts = [OptionEffect CanFail]
  }

mkUnalignedIndexOffAddrOp :: ElementType -> Entry
mkUnalignedIndexOffAddrOp e = PrimOpSpec
  { cons = "IndexOffAddrOp_Word8As" ++ elt_name e
  , name = "indexWord8OffAddrAs" ++ elt_name e ++ "#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
             (elt_rep_ty e)
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect CanFail]
  }

mkReadOffAddrOp :: ElementType -> Entry
mkReadOffAddrOp e = PrimOpSpec
  { cons = "ReadOffAddrOp_" ++ elt_name e
  , name = "read" ++ elt_name e ++ "OffAddr#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
       $ readResTy e
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
           ++ getAlignWarn e
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkUnalignedReadOffAddrOp :: ElementType -> Entry
mkUnalignedReadOffAddrOp e = PrimOpSpec
  { cons = "ReadOffAddrOp_Word8As" ++ elt_name e
  , name = "readWord8OffAddrAs" ++ elt_name e ++ "#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
       $ readResTy e
  , cat = GenPrimOp
  , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkWriteOffAddrOp :: ElementType -> Entry
mkWriteOffAddrOp e = PrimOpSpec
  { cons = "WriteOffAddrOp_" ++ elt_name e
  , name = "write" ++ elt_name e ++ "OffAddr#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
       $ writeResTy e
  , cat = GenPrimOp
  , desc = "Write " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
           ++ getAlignWarn e
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }

mkUnalignedWriteOffAddrOp :: ElementType -> Entry
mkUnalignedWriteOffAddrOp e = PrimOpSpec
  { cons = "WriteOffAddrOp_Word8As" ++ elt_name e
  , name = "writeWord8OffAddrAs" ++ elt_name e ++ "#"
  , ty = TyF (strToTy "Addr#")
       $ TyF (strToTy "Int#")
       $ writeResTy e
  , cat = GenPrimOp
  , desc = "Write " ++ elt_desc e ++ "; offset in bytes."
  , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail]
  }


addrAccessOps :: [Entry]
addrAccessOps
  =  map mkIndexOffAddrOp elementTypes
  ++ map mkUnalignedIndexOffAddrOp unalignedElementTypes
  ++ map mkReadOffAddrOp elementTypes
  ++ map mkUnalignedReadOffAddrOp unalignedElementTypes
  ++ map mkWriteOffAddrOp elementTypes
  ++ map mkUnalignedWriteOffAddrOp unalignedElementTypes
