module Feldspar.Core.Constructs.MutableArray
where
import Control.Monad
import Data.Array.IO
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Feldspar.Lattice
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
data MutableArray a
where
NewArr :: Type a => MutableArray (Length :-> a :-> Full (Mut (MArr a)))
NewArr_ :: Type a => MutableArray (Length :-> Full (Mut (MArr a)))
GetArr :: Type a => MutableArray (MArr a :-> Index :-> Full (Mut a))
SetArr :: MutableArray (MArr a :-> Index :-> a :-> Full (Mut ()))
ArrLength :: MutableArray (MArr a :-> Full (Mut Length))
instance Semantic MutableArray
where
semantics NewArr = Sem "newMArr" (\l -> newArray (0,l1))
semantics NewArr_ = Sem "newMArr_" (\l -> newArray_ (0,l1))
semantics GetArr = Sem "getMArr" readArray
semantics SetArr = Sem "setMArr" writeArray
semantics ArrLength = Sem "arrLength" (getBounds >=> \(l,u) -> return (ul+1))
instance Equality MutableArray where equal = equalDefault; exprHash = exprHashDefault
instance Render MutableArray where renderArgs = renderArgsDefault
instance ToTree MutableArray
instance Eval MutableArray where evaluate = evaluateDefault
instance EvalBind MutableArray where evalBindSym = evalBindSymDefault
instance Sharable MutableArray
instance AlphaEq dom dom dom env => AlphaEq MutableArray MutableArray dom env
where
alphaEqSym = alphaEqSymDefault
instance SizeProp MutableArray
where
sizeProp NewArr (WrapFull len :* _ :* Nil) = infoSize len :> universal
sizeProp NewArr_ (WrapFull len :* Nil) = infoSize len :> universal
sizeProp GetArr _ = universal
sizeProp SetArr _ = universal
sizeProp ArrLength (WrapFull arr :* Nil) = len
where
len :> _ = infoSize arr
instance (MutableArray :<: dom, Optimize dom dom) => Optimize MutableArray dom
where
constructFeatUnOpt NewArr args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr args
constructFeatUnOpt NewArr_ args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr_ args
constructFeatUnOpt GetArr args = constructFeatUnOptDefaultTyp (MutType typeRep) GetArr args
constructFeatUnOpt SetArr args = constructFeatUnOptDefaultTyp (MutType typeRep) SetArr args
constructFeatUnOpt ArrLength args = constructFeatUnOptDefaultTyp (MutType typeRep) ArrLength args