module Language.Embedded.Imperative.Frontend where
import Prelude hiding (break)
import Data.Array.IO
import Data.IORef
import Data.Typeable
import System.IO.Unsafe
import Control.Monad.Operational.Higher
import System.IO.Fake
import Language.Embedded.Expression
import Language.Embedded.Imperative.CMD
import Language.Embedded.Imperative.Args
import Language.Embedded.Imperative.Frontend.General
newRef :: (pred a, RefCMD :<: instr) =>
ProgramT instr (Param2 exp pred) m (Ref a)
newRef = newNamedRef "r"
newNamedRef :: (pred a, RefCMD :<: instr)
=> String
-> ProgramT instr (Param2 exp pred) m (Ref a)
newNamedRef = singleInj . NewRef
initRef :: (pred a, RefCMD :<: instr)
=> exp a
-> ProgramT instr (Param2 exp pred) m (Ref a)
initRef = initNamedRef "r"
initNamedRef :: (pred a, RefCMD :<: instr)
=> String
-> exp a
-> ProgramT instr (Param2 exp pred) m (Ref a)
initNamedRef base a = singleInj (InitRef base a)
getRef :: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m) =>
Ref a -> ProgramT instr (Param2 exp pred) m (exp a)
getRef = fmap valToExp . singleInj . GetRef
setRef :: (pred a, RefCMD :<: instr) =>
Ref a -> exp a -> ProgramT instr (Param2 exp pred) m ()
setRef r = singleInj . SetRef r
modifyRef :: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m) =>
Ref a -> (exp a -> exp a) -> ProgramT instr (Param2 exp pred) m ()
modifyRef r f = setRef r . f =<< unsafeFreezeRef r
unsafeFreezeRef
:: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m)
=> Ref a -> ProgramT instr (Param2 exp pred) m (exp a)
unsafeFreezeRef = fmap valToExp . singleInj . UnsafeFreezeRef
veryUnsafeFreezeRef :: (FreeExp exp, FreePred exp a) => Ref a -> exp a
veryUnsafeFreezeRef (RefRun r) = constExp $! unsafePerformIO $! readIORef r
veryUnsafeFreezeRef (RefComp v) = varExp v
newArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)
=> exp i
-> ProgramT instr (Param2 exp pred) m (Arr i a)
newArr = newNamedArr "a"
newNamedArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)
=> String
-> exp i
-> ProgramT instr (Param2 exp pred) m (Arr i a)
newNamedArr base len = singleInj (NewArr base len)
constArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)
=> [a]
-> ProgramT instr (Param2 exp pred) m (Arr i a)
constArr = constNamedArr "a"
constNamedArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)
=> String
-> [a]
-> ProgramT instr (Param2 exp pred) m (Arr i a)
constNamedArr base init = singleInj (ConstArr base init)
getArr
:: ( pred a
, FreeExp exp
, FreePred exp a
, Integral i
, Ix i
, ArrCMD :<: instr
, Monad m
)
=> Arr i a -> exp i -> ProgramT instr (Param2 exp pred) m (exp a)
getArr arr i = fmap valToExp $ singleInj $ GetArr arr i
setArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr) =>
Arr i a -> exp i -> exp a -> ProgramT instr (Param2 exp pred) m ()
setArr arr i a = singleInj (SetArr arr i a)
copyArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)
=> (Arr i a, exp i)
-> (Arr i a, exp i)
-> exp i
-> ProgramT instr (Param2 exp pred) m ()
copyArr arr1 arr2 len = singleInj $ CopyArr arr1 arr2 len
freezeArr :: (pred a, Integral i, Ix i, Num (exp i), ArrCMD :<: instr, Monad m)
=> Arr i a
-> exp i
-> ProgramT instr (Param2 exp pred) m (IArr i a)
freezeArr arr n = do
arr2 <- newArr n
copyArr (arr2,0) (arr,0) n
unsafeFreezeArr arr2
unsafeFreezeArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr) =>
Arr i a -> ProgramT instr (Param2 exp pred) m (IArr i a)
unsafeFreezeArr arr = singleInj $ UnsafeFreezeArr arr
thawArr :: (pred a, Integral i, Ix i, Num (exp i), ArrCMD :<: instr, Monad m)
=> IArr i a
-> exp i
-> ProgramT instr (Param2 exp pred) m (Arr i a)
thawArr arr n = do
arr2 <- unsafeThawArr arr
arr3 <- newArr n
copyArr (arr3,0) (arr2,0) n
return arr3
unsafeThawArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr) =>
IArr i a -> ProgramT instr (Param2 exp pred) m (Arr i a)
unsafeThawArr arr = singleInj $ UnsafeThawArr arr
iff :: (ControlCMD :<: instr)
=> exp Bool
-> ProgramT instr (Param2 exp pred) m ()
-> ProgramT instr (Param2 exp pred) m ()
-> ProgramT instr (Param2 exp pred) m ()
iff b t f = singleInj $ If b t f
ifE
:: ( pred a
, FreeExp exp
, FreePred exp a
, ControlCMD :<: instr
, RefCMD :<: instr
, Monad m
)
=> exp Bool
-> ProgramT instr (Param2 exp pred) m (exp a)
-> ProgramT instr (Param2 exp pred) m (exp a)
-> ProgramT instr (Param2 exp pred) m (exp a)
ifE b t f = do
r <- newRef
iff b (t >>= setRef r) (f >>= setRef r)
getRef r
while :: (ControlCMD :<: instr)
=> ProgramT instr (Param2 exp pred) m (exp Bool)
-> ProgramT instr (Param2 exp pred) m ()
-> ProgramT instr (Param2 exp pred) m ()
while b t = singleInj $ While b t
for
:: ( FreeExp exp
, ControlCMD :<: instr
, Integral n
, pred n
, FreePred exp n
)
=> IxRange (exp n)
-> (exp n -> ProgramT instr (Param2 exp pred) m ())
-> ProgramT instr (Param2 exp pred) m ()
for range body = singleInj $ For range (body . valToExp)
break :: (ControlCMD :<: instr) => ProgramT instr (Param2 exp pred) m ()
break = singleInj Break
assert :: (ControlCMD :<: instr)
=> exp Bool
-> String
-> ProgramT instr (Param2 exp pred) m ()
assert cond msg = singleInj $ Assert cond msg
unsafeSwap :: (IsPointer a, PtrCMD :<: instr) =>
a -> a -> ProgramT instr (Param2 exp pred) m ()
unsafeSwap a b = singleInj $ SwapPtr a b
fopen :: (FileCMD :<: instr) =>
FilePath -> IOMode -> ProgramT instr (Param2 exp pred) m Handle
fopen file = singleInj . FOpen file
fclose :: (FileCMD :<: instr) => Handle -> ProgramT instr (Param2 exp pred) m ()
fclose = singleInj . FClose
feof :: (FreeExp exp, FreePred exp Bool, FileCMD :<: instr, Monad m) =>
Handle -> ProgramT instr (Param2 exp pred) m (exp Bool)
feof = fmap valToExp . singleInj . FEof
class PrintfType r
where
type PrintfExp r :: * -> *
fprf :: Handle -> String -> [PrintfArg (PrintfExp r)] -> r
instance (FileCMD :<: instr, a ~ ()) =>
PrintfType (ProgramT instr (Param2 exp pred) m a)
where
type PrintfExp (ProgramT instr (Param2 exp pred) m a) = exp
fprf h form as = singleInj $ FPrintf h form (reverse as)
instance (Formattable a, PrintfType r, exp ~ PrintfExp r) =>
PrintfType (exp a -> r)
where
type PrintfExp (exp a -> r) = exp
fprf h form as = \a -> fprf h form (PrintfArg a : as)
fprintf :: PrintfType r => Handle -> String -> r
fprintf h format = fprf h format []
fput :: forall instr exp pred a m
. (Formattable a, FreePred exp a, FileCMD :<: instr)
=> Handle
-> String
-> exp a
-> String
-> ProgramT instr (Param2 exp pred) m ()
fput hdl prefix a suffix =
fprintf hdl (prefix ++ formatSpecPrint (Proxy :: Proxy a) ++ suffix) a
fget
:: ( Formattable a
, pred a
, FreeExp exp
, FreePred exp a
, FileCMD :<: instr
, Monad m
)
=> Handle -> ProgramT instr (Param2 exp pred) m (exp a)
fget = fmap valToExp . singleInj . FGet
printf :: PrintfType r => String -> r
printf = fprintf stdout
newPtr :: (pred a, C_CMD :<: instr) => ProgramT instr (Param2 exp pred) m (Ptr a)
newPtr = newNamedPtr "p"
newNamedPtr :: (pred a, C_CMD :<: instr)
=> String
-> ProgramT instr (Param2 exp pred) m (Ptr a)
newNamedPtr = singleInj . NewPtr
ptrToArr :: (C_CMD :<: instr) => Ptr a -> ProgramT instr (Param2 exp pred) m (Arr i a)
ptrToArr = singleInj . PtrToArr
newObject :: (C_CMD :<: instr)
=> String
-> Bool
-> ProgramT instr (Param2 exp pred) m Object
newObject t p = newNamedObject "obj" t p
newNamedObject :: (C_CMD :<: instr)
=> String
-> String
-> Bool
-> ProgramT instr (Param2 exp pred) m Object
newNamedObject base t p = singleInj $ NewObject base t p
addInclude :: (C_CMD :<: instr) => String -> ProgramT instr (Param2 exp pred) m ()
addInclude = singleInj . AddInclude
addDefinition :: (C_CMD :<: instr) => Definition -> ProgramT instr (Param2 exp pred) m ()
addDefinition = singleInj . AddDefinition
addExternFun :: (pred res, C_CMD :<: instr)
=> String
-> proxy res
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m ()
addExternFun fun res args = singleInj $ AddExternFun fun res args
addExternProc :: (C_CMD :<: instr)
=> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m ()
addExternProc proc args = singleInj $ AddExternProc proc args
callFun :: (pred a, FreeExp exp, FreePred exp a, C_CMD :<: instr, Monad m)
=> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m (exp a)
callFun fun as = fmap valToExp $ singleInj $ CallFun fun as
callProc :: (C_CMD :<: instr)
=> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m ()
callProc fun as = singleInj $ CallProc (Nothing :: Maybe Object) fun as
callProcAssign :: (Assignable obj, C_CMD :<: instr)
=> obj
-> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m ()
callProcAssign obj fun as = singleInj $ CallProc (Just obj) fun as
externFun :: forall instr m exp pred res
. (pred res, FreeExp exp, FreePred exp res, C_CMD :<: instr, Monad m)
=> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m (exp res)
externFun fun args = do
addExternFun fun (Proxy :: Proxy res) args
callFun fun args
externProc :: (C_CMD :<: instr, Monad m)
=> String
-> [FunArg exp pred]
-> ProgramT instr (Param2 exp pred) m ()
externProc proc args = do
addExternProc proc args
callProc proc args
inModule :: (C_CMD :<: instr)
=> String
-> ProgramT instr (Param2 exp pred) m ()
-> ProgramT instr (Param2 exp pred) m ()
inModule mod prog = singleInj $ InModule mod prog
getTime
:: (pred Double, FreeExp exp, FreePred exp Double, C_CMD :<: instr, Monad m)
=> ProgramT instr (Param2 exp pred) m (exp Double)
getTime = do
addInclude "<sys/time.h>"
addInclude "<sys/resource.h>"
addDefinition getTimeDef
callFun "get_time" []
where
getTimeDef = [cedecl|
double get_time()
{
struct timeval t;
struct timezone tzp;
gettimeofday(&t, &tzp);
return t.tv_sec + t.tv_usec*1e-6;
}
|]
valArg :: pred a => exp a -> FunArg exp pred
valArg = ValArg
refArg :: (pred a, Arg RefArg pred) => Ref a -> FunArg exp pred
refArg = FunArg . RefArg
arrArg :: (pred a, Arg ArrArg pred) => Arr i a -> FunArg exp pred
arrArg = FunArg . ArrArg
iarrArg :: (pred a, Arg IArrArg pred) => IArr i a -> FunArg exp pred
iarrArg = FunArg . IArrArg
ptrArg :: (pred a, Arg PtrArg pred) => Ptr a -> FunArg exp pred
ptrArg = FunArg . PtrArg
objArg :: Object -> FunArg exp pred
objArg = FunArg . ObjArg
strArg :: String -> FunArg exp pred
strArg = FunArg . StrArg
constArg
:: String
-> String
-> FunArg exp pred
constArg t n = FunArg $ ConstArg t n
addr :: FunArg exp pred -> FunArg exp pred
addr = AddrArg
deref :: FunArg exp pred -> FunArg exp pred
deref = DerefArg
offset :: Integral i => FunArg exp pred -> exp i -> FunArg exp pred
offset = OffsetArg
runIO :: (EvalExp exp, InterpBi instr IO (Param1 pred), HBifunctor instr) =>
Program instr (Param2 exp pred) a -> IO a
runIO = interpretBi (return . evalExp)
captureIO :: (EvalExp exp, InterpBi instr IO (Param1 pred), HBifunctor instr)
=> Program instr (Param2 exp pred) a
-> String
-> IO String
captureIO = fakeIO . runIO