module Language.Embedded.Imperative.Frontend where
import Prelude hiding (break)
import Data.Array.IO
import Data.IORef
import Data.Typeable
import System.IO.Unsafe
#if __GLASGOW_HASKELL__ < 708
import Data.Proxy
#endif
import Language.C.Quote.C
import Control.Monad.Operational.Higher
import Language.Embedded.Expression
import Language.Embedded.Imperative.CMD
import Language.Embedded.Imperative.Frontend.General
import Language.Embedded.Imperative.Args
newRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) => ProgramT instr m (Ref a)
newRef = singleE NewRef
initRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) =>
IExp instr a -> ProgramT instr m (Ref a)
initRef = singleE . InitRef
getRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) =>
Ref a -> ProgramT instr m (IExp instr a)
getRef = singleE . GetRef
setRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) =>
Ref a -> IExp instr a -> ProgramT instr m ()
setRef r = singleE . SetRef r
modifyRef
:: ( VarPred (IExp instr) a
, EvalExp (IExp instr)
, CompExp (IExp instr)
, RefCMD (IExp instr) :<: instr
, Monad m
)
=> Ref a -> (IExp instr a -> IExp instr a) -> ProgramT instr m ()
modifyRef r f = setRef r . f =<< unsafeFreezeRef r
veryUnsafeFreezeRef :: (VarPred exp a, EvalExp exp, CompExp exp) =>
Ref a -> exp a
veryUnsafeFreezeRef (RefEval r) = litExp $! unsafePerformIO $! readIORef r
veryUnsafeFreezeRef (RefComp v) = varExp v
unsafeFreezeRef :: (VarPred exp a, EvalExp exp, CompExp exp, Monad m) =>
Ref a -> ProgramT instr m (exp a)
unsafeFreezeRef r = return $! veryUnsafeFreezeRef r
newArr
:: ( pred a
, pred i
, Integral i
, Ix i
, ArrCMD (IExp instr) :<: instr
, pred ~ VarPred (IExp instr)
)
=> IExp instr i -> ProgramT instr m (Arr i a)
newArr n = singleE $ NewArr n
newArr_
:: ( pred a
, pred i
, Integral i
, Ix i
, ArrCMD (IExp instr) :<: instr
, pred ~ VarPred (IExp instr)
)
=> ProgramT instr m (Arr i a)
newArr_ = singleE $ NewArr_
getArr
:: ( VarPred (IExp instr) a
, ArrCMD (IExp instr) :<: instr
, Integral i
, Ix i
)
=> IExp instr i -> Arr i a -> ProgramT instr m (IExp instr a)
getArr i arr = singleE $ GetArr i arr
setArr
:: ( VarPred (IExp instr) a
, ArrCMD (IExp instr) :<: instr
, Integral i
, Ix i
)
=> IExp instr i -> IExp instr a -> Arr i a -> ProgramT instr m ()
setArr i a arr = singleE (SetArr i a arr)
iff :: (ControlCMD (IExp instr) :<: instr)
=> IExp instr Bool
-> ProgramT instr m ()
-> ProgramT instr m ()
-> ProgramT instr m ()
iff b t f = singleE $ If b t f
ifE
:: ( VarPred (IExp instr) a
, ControlCMD (IExp instr) :<: instr
, RefCMD (IExp instr) :<: instr
, Monad m
)
=> IExp instr Bool
-> ProgramT instr m (IExp instr a)
-> ProgramT instr m (IExp instr a)
-> ProgramT instr m (IExp instr a)
ifE b t f = do
r <- newRef
iff b (t >>= setRef r) (f >>= setRef r)
getRef r
while :: (ControlCMD (IExp instr) :<: instr)
=> ProgramT instr m (IExp instr Bool)
-> ProgramT instr m ()
-> ProgramT instr m ()
while b t = singleE $ While b t
whileE
:: ( VarPred (IExp instr) a
, ControlCMD (IExp instr) :<: instr
, RefCMD (IExp instr) :<: instr
, Monad m
)
=> ProgramT instr m (IExp instr Bool)
-> ProgramT instr m (IExp instr a)
-> ProgramT instr m (IExp instr a)
whileE b t = do
r <- newRef
while b (t >>= setRef r)
getRef r
for :: (ControlCMD (IExp instr) :<: instr, Integral n, VarPred (IExp instr) n)
=> IExp instr n
-> IExp instr n
-> (IExp instr n -> ProgramT instr m ())
-> ProgramT instr m ()
for lo hi body = singleE $ For lo hi body
forE
:: ( Integral n
, VarPred (IExp instr) n
, VarPred (IExp instr) a
, ControlCMD (IExp instr) :<: instr
, RefCMD (IExp instr) :<: instr
, Monad m
)
=> IExp instr n
-> IExp instr n
-> (IExp instr n -> ProgramT instr m (IExp instr a))
-> ProgramT instr m (IExp instr a)
forE lo hi body = do
r <- newRef
for lo hi (body >=> setRef r)
getRef r
break :: (ControlCMD (IExp instr) :<: instr) => ProgramT instr m ()
break = singleE Break
fopen :: (FileCMD (IExp instr) :<: instr) => FilePath -> IOMode -> ProgramT instr m Handle
fopen file = singleE . FOpen file
fclose :: (FileCMD (IExp instr) :<: instr) => Handle -> ProgramT instr m ()
fclose = singleE . FClose
feof :: (VarPred (IExp instr) Bool, FileCMD (IExp instr) :<: instr) =>
Handle -> ProgramT instr m (IExp instr Bool)
feof = singleE . FEof
class PrintfType r
where
type PrintfExp r :: * -> *
fprf :: Handle -> String -> [PrintfArg (PrintfExp r)] -> r
instance (FileCMD (IExp instr) :<: instr, a ~ ()) => PrintfType (ProgramT instr m a)
where
type PrintfExp (ProgramT instr m a) = IExp instr
fprf h form as = singleE $ FPrintf h form (reverse as)
instance (Formattable a, VarPred exp 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 a m
. (Formattable a, VarPred (IExp instr) a, FileCMD (IExp instr) :<: instr)
=> Handle
-> String
-> IExp instr a
-> String
-> ProgramT instr m ()
fput hdl prefix a suffix =
fprintf hdl (prefix ++ formatSpecifier (Proxy :: Proxy a) ++ suffix) a
fget
:: ( Formattable a
, VarPred (IExp instr) a
, FileCMD (IExp instr) :<: instr
)
=> Handle -> ProgramT instr m (IExp instr a)
fget = singleE . FGet
printf :: PrintfType r => String -> r
printf = fprintf stdout
newObject :: (ObjectCMD (IExp instr) :<: instr)
=> String
-> ProgramT instr m Object
newObject = singleE . NewObject
initObject :: (ObjectCMD (IExp instr) :<: instr)
=> String
-> String
-> [FunArg (IExp instr)]
-> ProgramT instr m Object
initObject fun ty args = singleE $ InitObject fun True ty args
initUObject :: (ObjectCMD (IExp instr) :<: instr)
=> String
-> String
-> [FunArg (IExp instr)]
-> ProgramT instr m Object
initUObject fun ty args = singleE $ InitObject fun False ty args
addInclude :: (CallCMD (IExp instr) :<: instr) => String -> ProgramT instr m ()
addInclude = singleE . AddInclude
addDefinition :: (CallCMD (IExp instr) :<: instr) => Definition -> ProgramT instr m ()
addDefinition = singleE . AddDefinition
addExternFun :: (VarPred exp res, CallCMD exp :<: instr, exp ~ IExp instr)
=> String
-> proxy (exp res)
-> [FunArg exp]
-> ProgramT instr m ()
addExternFun fun res args = singleE $ AddExternFun fun res args
addExternProc :: (CallCMD exp :<: instr, exp ~ IExp instr)
=> String
-> [FunArg exp]
-> ProgramT instr m ()
addExternProc proc args = singleE $ AddExternProc proc args
callFun :: (VarPred (IExp instr) a, CallCMD (IExp instr) :<: instr)
=> String
-> [FunArg (IExp instr)]
-> ProgramT instr m (IExp instr a)
callFun fun as = singleE $ CallFun fun as
callProc :: (CallCMD (IExp instr) :<: instr)
=> String
-> [FunArg (IExp instr)]
-> ProgramT instr m ()
callProc fun as = singleE $ CallProc fun as
externFun :: forall instr m exp res
. (VarPred exp res, CallCMD exp :<: instr, exp ~ IExp instr, Monad m)
=> String
-> [FunArg exp]
-> ProgramT instr m (exp res)
externFun fun args = do
addExternFun fun (Proxy :: Proxy (exp res)) args
callFun fun args
externProc :: (CallCMD exp :<: instr, exp ~ IExp instr, Monad m)
=> String
-> [FunArg exp]
-> ProgramT instr m ()
externProc proc args = do
addExternProc proc args
callProc proc args
getTime :: (VarPred (IExp instr) Double, CallCMD (IExp instr) :<: instr, Monad m) =>
ProgramT instr m (IExp instr 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;
}
|]
strArg :: String -> FunArg exp
strArg = FunArg . StrArg
valArg :: VarPred exp a => exp a -> FunArg exp
valArg = FunArg . ValArg
refArg :: VarPred exp a => Ref a -> FunArg exp
refArg = FunArg . RefArg
arrArg :: VarPred exp a => Arr n a -> FunArg exp
arrArg = FunArg . ArrArg
objArg :: Object -> FunArg exp
objArg = FunArg . ObjArg
addr :: FunArg exp -> FunArg exp
addr = FunArg . Addr
runIO :: (Interp instr IO, HFunctor instr) => Program instr a -> IO a
runIO = interpret