Runtime.hs

-- | Implementations of builtin Granule functions in Haskell

{-# LANGUAGE NamedFieldPuns, Strict, NoImplicitPrelude, TypeFamilies,
             DataKinds, GADTs #-}
{-# OPTIONS_GHC -fno-full-laziness -fno-warn-unused-binds #-}
module Language.Granule.Runtime
  (
    -- Granule runtime-specific data structures
    FloatArray(..), BenchList(..), RuntimeData(..)

    -- Granule runtime-specific procedures
  , pure
  , mkIOBenchMain,fromStdin,toStdout,toStderr,timeDate,readInt,showChar,intToFloat
  , showInt,showFloat, charToInt, charFromInt, stringAppend
  , newFloatArray,newFloatArrayI,writeFloatArray,writeFloatArrayI
  , readFloatArray,readFloatArrayI,lengthFloatArray,deleteFloatArray,copyFloatArray'
  , uniqueReturn,uniqueBind,uniquePush,uniquePull,uniquifyFloatArray,borrowFloatArray
  , newFloatArraySafe,newFloatArrayISafe,writeFloatArraySafe,writeFloatArrayISafe
  , readFloatArraySafe,readFloatArrayISafe,deleteFloatArraySafe,copyFloatArraySafe
  , uniquifyFloatArraySafe,borrowFloatArraySafe
  , newRefSafe, freezeRefSafe, swapRefSafe, readRefSafe, copyRefSafe
  , cap, Cap(..), Capability(..), CapabilityType

  -- Re-exported from Prelude
  , String, Int, IO, Float, Maybe(..), Show(..), Char, getLine
  , putStr, read, (<$>) , fromIntegral, Monad(..)
  , ($), error, (>), (++), id, Num(..), (.)
  , pack, Text
  ) where

import Foreign.Marshal.Array ( callocArray )
import Foreign.Ptr ( Ptr )
import Foreign.Storable ( Storable(peekElemOff, pokeElemOff) )
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.Marshal.Alloc ( free )
import System.IO ( hFlush, stderr, stdout )
import qualified Data.Array.IO as MA
import Criterion.Main ( defaultMain, bench, bgroup, nfAppIO )
import System.IO.Silently ( silence )
import Prelude
    ( Int, IO, Double, Maybe(..), Show(..), Char, read, fromEnum, toEnum
    , (<$>), (<>), fromIntegral, ($), error, (>), (++), id, Num (..), (.) )
import Control.Monad
import GHC.Err (undefined)
import Data.Function (const)
import Data.Text
import Data.Text.IO
import Data.Time.Clock
import qualified Data.IORef as MR

-- ^ Eventually this can be expanded with other kinds of runtime-managed data
data RuntimeData a = FA FloatArray | PR (PolyRef a)

-- ^ Granule calls doubles floats
type Float = Double

-- ^ Granule calls Text String
type String = Text

pure :: Monad m => a -> m a
pure = return

--------------------------------------------------------------------------------
-- Benchmarking
--------------------------------------------------------------------------------

data BenchList =
    BenchGroup String BenchList BenchList
  | Bench Int String (Int -> IO ()) BenchList
  | Done

mkIOBenchMain :: BenchList -> IO ()
mkIOBenchMain ns = defaultMain (go ns)
  where go (Bench n s f next) = bench (unpack s) (nfAppIO (silence . f) n) : go next
        go (BenchGroup str benchs next) = bgroup (unpack str) (go benchs) : go next
        go Done = []

--------------------------------------------------------------------------------
-- I/O
--------------------------------------------------------------------------------

fromStdin :: IO String
fromStdin = do
  putStr "> "
  hFlush stdout
  getLine

toStdout :: String -> IO ()
toStdout = putStr

toStderr :: String -> IO ()
toStderr = let red x = "\ESC[31;1m" <> x <> "\ESC[0m" in (hPutStr stderr) . red

timeDate :: () -> IO String
timeDate () = getCurrentTime >>= (return . pack . show)

--------------------------------------------------------------------------------
-- Conversions
--------------------------------------------------------------------------------

readInt :: String -> Int
readInt s =
  if null s
  then 0
  else read $ unpack s

showChar :: Char -> String
showChar = singleton

charToInt :: Char -> Int
charToInt = fromEnum

charFromInt :: Int -> Char
charFromInt = toEnum

intToFloat :: Int -> Float
intToFloat = fromIntegral

showInt :: Int -> String
showInt = pack . show

showFloat :: Float -> String
showFloat = pack . show

--------------------------------------------------------------------------------
-- String operations
--------------------------------------------------------------------------------

stringAppend :: String -> String -> String
stringAppend = (<>)

--------------------------------------------------------------------------------
-- Mutable arrays
--------------------------------------------------------------------------------

data FloatArray =
  HaskellArray {
    -- | Length of Haskell array
    grLength :: Int,
    -- | An ordinary Haskell IOArray
    grArr :: MA.IOArray Int Float } |
  PointerArray {
    -- | Length of the array in memory
    grLength :: Int,
    -- | Pointer to a block of memory
    grPtr :: Ptr Float }

data PolyRef a =
  HaskellRef {
    haskRef :: MR.IORef a
  }

{-# NOINLINE newFloatArray #-}
newFloatArray :: Int -> FloatArray
newFloatArray = unsafePerformIO . newFloatArraySafe

newFloatArraySafe :: Int -> IO FloatArray
newFloatArraySafe size = do
  ptr <- callocArray size
  return $ PointerArray size ptr

{-# NOINLINE newRef #-}
newRef :: a -> PolyRef a
newRef = unsafePerformIO . newRefSafe

newRefSafe :: a -> IO (PolyRef a)
newRefSafe v = do
  r <- MR.newIORef v
  return $ HaskellRef r

{-# NOINLINE newFloatArrayI #-}
newFloatArrayI :: Int -> FloatArray
newFloatArrayI = unsafePerformIO . newFloatArrayISafe

newFloatArrayISafe :: Int -> IO FloatArray
newFloatArrayISafe size = do
  arr <- MA.newArray (0,size-1) 0.0
  return $ HaskellArray size arr

{-# NOINLINE writeFloatArray #-}
writeFloatArray :: FloatArray -> Int -> Float -> FloatArray
writeFloatArray a i v = unsafePerformIO $ writeFloatArraySafe a i v

writeFloatArraySafe :: FloatArray -> Int -> Float -> IO FloatArray
writeFloatArraySafe a i v =
  if i > grLength a
  then error $ "array index out of bounds: " ++ show i ++ " > " ++ show (grLength a)
  else case a of
    HaskellArray{} -> error "expected unique array"
    PointerArray len ptr -> do
      () <- pokeElemOff ptr i v
      return $ PointerArray len ptr

{-# NOINLINE writeFloatArrayI #-}
writeFloatArrayI :: FloatArray -> Int -> Float -> FloatArray
writeFloatArrayI a i v = unsafePerformIO $ writeFloatArrayISafe a i v

writeFloatArrayISafe :: FloatArray -> Int -> Float -> IO FloatArray
writeFloatArrayISafe a i v =
  if i > grLength a
  then error $ "array index out of bounds: " ++ show i ++ " > " ++ show (grLength a)
  else case a of
    PointerArray{} -> error "expected non-unique array"
    HaskellArray len arr -> do
      arr' <- MA.mapArray id arr
      () <- MA.writeArray arr' i v
      return $ HaskellArray len arr'

{-# NOINLINE swapRef #-}
swapRef :: PolyRef a -> a -> (a, PolyRef a)
swapRef r v = unsafePerformIO $ swapRefSafe r v

swapRefSafe :: PolyRef a -> a -> IO (a, PolyRef a)
swapRefSafe HaskellRef{haskRef} v = do
  x <- MR.readIORef haskRef
  MR.writeIORef haskRef v
  return $ (x, HaskellRef haskRef)

{-# NOINLINE readRef #-}
readRef :: PolyRef a -> (a, PolyRef a)
readRef = unsafePerformIO . readRefSafe

readRefSafe :: PolyRef a -> IO (a, PolyRef a)
readRefSafe HaskellRef{haskRef} = do
  x <- MR.readIORef haskRef
  return $ (x, HaskellRef haskRef)

{-# NOINLINE readFloatArray #-}
readFloatArray :: FloatArray -> Int -> (Float, FloatArray)
readFloatArray a i = unsafePerformIO $ readFloatArraySafe a i

readFloatArraySafe :: FloatArray -> Int -> IO (Float, FloatArray)
readFloatArraySafe a i =
  if i > grLength a
  then error $ "readFloatArray index out of bounds: " ++ show i ++ " > " ++ show (grLength a)
  else case a of
    HaskellArray{} -> error "expected unique array"
    PointerArray len ptr -> do
      v <- peekElemOff ptr i
      return (v,a)

{-# NOINLINE readFloatArrayI #-}
readFloatArrayI :: FloatArray -> Int -> (Float, FloatArray)
readFloatArrayI a i = unsafePerformIO $ readFloatArrayISafe a i

readFloatArrayISafe :: FloatArray -> Int -> IO (Float, FloatArray)
readFloatArrayISafe a i =
  if i > grLength a
  then error $ "readFloatArrayI index out of bounds: " ++ show i ++ " > " ++ show (grLength a)
  else case a of
    PointerArray{} -> error "expected non-unique array"
    HaskellArray _ arr -> do
      e <- MA.readArray arr i
      return (e,a)

lengthFloatArray :: FloatArray -> (Int, FloatArray)
lengthFloatArray a = (grLength a, a)

{-# NOINLINE deleteFloatArray #-}
deleteFloatArray :: FloatArray -> ()
deleteFloatArray = unsafePerformIO . deleteFloatArraySafe

deleteFloatArraySafe :: FloatArray -> IO ()
deleteFloatArraySafe PointerArray{grPtr} =
  free grPtr
deleteFloatArraySafe HaskellArray{grArr} =
  void (MA.mapArray (const undefined) grArr)

{-# NOINLINE freezeRef #-}
freezeRef :: PolyRef a -> a
freezeRef = unsafePerformIO . freezeRefSafe

freezeRefSafe :: PolyRef a -> IO a
freezeRefSafe HaskellRef{haskRef} =
  MR.readIORef haskRef

{-# NOINLINE copyFloatArray' #-}
copyFloatArray' :: FloatArray -> FloatArray
copyFloatArray' = unsafePerformIO . copyFloatArraySafe

copyFloatArraySafe :: FloatArray -> IO FloatArray
copyFloatArraySafe a =
  case a of
    PointerArray{} -> error "expected non-unique array"
    HaskellArray len arr -> do
      arr' <- MA.mapArray id arr
      return $ uniquifyFloatArray $ HaskellArray len arr'

{-# NOINLINE copyRef #-}
copyRef :: PolyRef a -> PolyRef a
copyRef = unsafePerformIO . copyRefSafe

copyRefSafe :: PolyRef a -> IO (PolyRef a)
copyRefSafe HaskellRef{haskRef} = do
  val <- MR.readIORef haskRef
  haskRef' <- MR.newIORef val
  return $ HaskellRef haskRef'

{-# NOINLINE uniquifyFloatArray #-}
uniquifyFloatArray :: FloatArray -> FloatArray
uniquifyFloatArray = unsafePerformIO . uniquifyFloatArraySafe

uniquifyFloatArraySafe :: FloatArray -> IO FloatArray
uniquifyFloatArraySafe a =
  case a of
    PointerArray{} -> error "expected non-unique array"
    HaskellArray len arr -> do
      arr' <- newFloatArraySafe len
      forM_ [0..(len-1)] $ \i -> do
        v <- MA.readArray arr i
        pokeElemOff (grPtr arr') i v
      return arr'

{-# NOINLINE borrowFloatArray #-}
borrowFloatArray :: FloatArray -> FloatArray
borrowFloatArray = unsafePerformIO . borrowFloatArraySafe

borrowFloatArraySafe :: FloatArray -> IO FloatArray
borrowFloatArraySafe a =
  case a of
    HaskellArray{} -> error "expected unique array"
    PointerArray len ptr -> do
      arr' <- newFloatArrayISafe len
      forM_ [0..(len-1)] $ \i -> do
        v <- peekElemOff ptr i
        MA.writeArray (grArr arr') i v
      return arr'

--------------------------------------------------------------------------------
-- Uniqueness monadic operations
--------------------------------------------------------------------------------

uniqueReturn :: a -> a
uniqueReturn = id

uniqueBind :: (a -> b) -> a -> b
uniqueBind f = f

uniquePush :: (a,b) -> (a,b)
uniquePush = id

uniquePull :: (a,b) -> (a,b)
uniquePull = id

--------------------------------------------------------------------------------
-- Capabilities
--------------------------------------------------------------------------------

-- Emulate dependent types
data Cap = ConsoleTag | TimeDateTag

data Capability (c :: Cap) where
    Console :: Capability 'ConsoleTag
    TimeDate :: Capability 'TimeDateTag

type family CapabilityType (c :: Cap)
type instance CapabilityType 'ConsoleTag = Text -> ()
type instance CapabilityType 'TimeDateTag = () -> Text

{-# NOINLINE cap #-}
cap :: Capability cap -> () -> CapabilityType cap
cap Console ()  = \x -> unsafePerformIO $ toStdout $ x
cap TimeDate () = \() -> unsafePerformIO $ timeDate ()