{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE UndecidableInstances #-} -- Front end for imperative instructions -- -- These instructions are general imperative constructs independent of the back -- end, except for the stuff under \"External function calls\" which is -- C-specific. 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 -------------------------------------------------------------------------------- -- * References -------------------------------------------------------------------------------- -- | Create an uninitialized reference newRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) => ProgramT instr m (Ref a) newRef = singleE NewRef -- | Create an initialized reference initRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) => IExp instr a -> ProgramT instr m (Ref a) initRef = singleE . InitRef -- | Get the contents of a reference getRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) => Ref a -> ProgramT instr m (IExp instr a) getRef = singleE . GetRef -- | Set the contents of a reference setRef :: (VarPred (IExp instr) a, RefCMD (IExp instr) :<: instr) => Ref a -> IExp instr a -> ProgramT instr m () setRef r = singleE . SetRef r -- | Modify the contents of reference 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 -- | Read the value of a reference without returning in the monad -- -- WARNING: Don't use this function unless you really know what you are doing. -- It is almost always better to use 'unsafeFreezeRef' instead. -- -- 'veryUnsafeFreezeRef' behaves predictably when doing code generation, but it -- can give strange results when evaluating in 'IO', as explained here: -- -- veryUnsafeFreezeRef :: (VarPred exp a, EvalExp exp, CompExp exp) => Ref a -> exp a veryUnsafeFreezeRef (RefEval r) = litExp $! unsafePerformIO $! readIORef r veryUnsafeFreezeRef (RefComp v) = varExp v -- | Freeze the contents of reference (only safe if the reference is never -- written to after the freezing) unsafeFreezeRef :: (VarPred exp a, EvalExp exp, CompExp exp, Monad m) => Ref a -> ProgramT instr m (exp a) unsafeFreezeRef r = return $! veryUnsafeFreezeRef r -- Strict applications (here and in `veryUnsafeFreezeRef`) are needed when -- evaluating in `IO` to force `readIORef` to be performed before the next -- action. -- -- The `modifyRef` test case fails if the strict applications are removed, so -- this seems to work. If there's a problem, another possibility would be to -- make `unsafeFreezeRef` an instruction in `RefCMD`. This would avoid the -- need for `unsafePerformIO`. -------------------------------------------------------------------------------- -- * Arrays -------------------------------------------------------------------------------- -- | Create an uninitialized an array 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_ -- | Set the contents of an array 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 -- | Set the contents of an array 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) -------------------------------------------------------------------------------- -- * Control flow -------------------------------------------------------------------------------- -- | Conditional statement iff :: (ControlCMD (IExp instr) :<: instr) => IExp instr Bool -- ^ Condition -> ProgramT instr m () -- ^ True branch -> ProgramT instr m () -- ^ False branch -> ProgramT instr m () iff b t f = singleE $ If b t f -- | Conditional statement that returns an expression ifE :: ( VarPred (IExp instr) a , ControlCMD (IExp instr) :<: instr , RefCMD (IExp instr) :<: instr , Monad m ) => IExp instr Bool -- ^ Condition -> ProgramT instr m (IExp instr a) -- ^ True branch -> ProgramT instr m (IExp instr a) -- ^ False branch -> ProgramT instr m (IExp instr a) ifE b t f = do r <- newRef iff b (t >>= setRef r) (f >>= setRef r) getRef r -- | While loop while :: (ControlCMD (IExp instr) :<: instr) => ProgramT instr m (IExp instr Bool) -- ^ Continue condition -> ProgramT instr m () -- ^ Loop body -> ProgramT instr m () while b t = singleE $ While b t -- | While loop that returns an expression whileE :: ( VarPred (IExp instr) a , ControlCMD (IExp instr) :<: instr , RefCMD (IExp instr) :<: instr , Monad m ) => ProgramT instr m (IExp instr Bool) -- ^ Continue condition -> ProgramT instr m (IExp instr a) -- ^ Loop body -> ProgramT instr m (IExp instr a) whileE b t = do r <- newRef while b (t >>= setRef r) getRef r -- | For loop for :: (ControlCMD (IExp instr) :<: instr, Integral n, VarPred (IExp instr) n) => IExp instr n -- ^ Start index -> IExp instr n -- ^ Stop index -> (IExp instr n -> ProgramT instr m ()) -- ^ Loop body -> ProgramT instr m () for lo hi body = singleE $ For lo hi body -- | For loop forE :: ( Integral n , VarPred (IExp instr) n , VarPred (IExp instr) a , ControlCMD (IExp instr) :<: instr , RefCMD (IExp instr) :<: instr , Monad m ) => IExp instr n -- ^ Start index -> IExp instr n -- ^ Stop index -> (IExp instr n -> ProgramT instr m (IExp instr a)) -- ^ Loop body -> ProgramT instr m (IExp instr a) forE lo hi body = do r <- newRef for lo hi (body >=> setRef r) getRef r -- | Break out from a loop break :: (ControlCMD (IExp instr) :<: instr) => ProgramT instr m () break = singleE Break -------------------------------------------------------------------------------- -- * File handling -------------------------------------------------------------------------------- -- | Open a file fopen :: (FileCMD (IExp instr) :<: instr) => FilePath -> IOMode -> ProgramT instr m Handle fopen file = singleE . FOpen file -- | Close a file fclose :: (FileCMD (IExp instr) :<: instr) => Handle -> ProgramT instr m () fclose = singleE . FClose -- | Check for end of file 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) -- | Print to a handle. Accepts a variable number of arguments. fprintf :: PrintfType r => Handle -> String -> r fprintf h format = fprf h format [] -- | Put a single value to a handle fput :: forall instr a m . (Formattable a, VarPred (IExp instr) a, FileCMD (IExp instr) :<: instr) => Handle -> String -- ^ Prefix -> IExp instr a -- ^ Expression to print -> String -- ^ Suffix -> ProgramT instr m () fput hdl prefix a suffix = fprintf hdl (prefix ++ formatSpecifier (Proxy :: Proxy a) ++ suffix) a -- | Get a single value from a handle fget :: ( Formattable a , VarPred (IExp instr) a , FileCMD (IExp instr) :<: instr ) => Handle -> ProgramT instr m (IExp instr a) fget = singleE . FGet -- | Print to @stdout@. Accepts a variable number of arguments. printf :: PrintfType r => String -> r printf = fprintf stdout -------------------------------------------------------------------------------- -- * Abstract objects -------------------------------------------------------------------------------- -- | Create a pointer to an abstract object. The only thing one can do with such -- objects is to pass them to 'callFun' or 'callProc'. newObject :: (ObjectCMD (IExp instr) :<: instr) => String -- ^ Object type -> ProgramT instr m Object newObject = singleE . NewObject -- | Call a function to create a pointed object initObject :: (ObjectCMD (IExp instr) :<: instr) => String -- ^ Function name -> String -- ^ Object type -> [FunArg (IExp instr)] -- ^ Arguments -> ProgramT instr m Object initObject fun ty args = singleE $ InitObject fun True ty args -- | Call a function to create an object initUObject :: (ObjectCMD (IExp instr) :<: instr) => String -- ^ Function name -> String -- ^ Object type -> [FunArg (IExp instr)] -- ^ Arguments -> ProgramT instr m Object initUObject fun ty args = singleE $ InitObject fun False ty args -------------------------------------------------------------------------------- -- * External function calls (C-specific) -------------------------------------------------------------------------------- -- | Add an @#include@ statement to the generated code addInclude :: (CallCMD (IExp instr) :<: instr) => String -> ProgramT instr m () addInclude = singleE . AddInclude -- | Add a global definition to the generated code -- -- Can be used conveniently as follows: -- -- > {-# LANGUAGE QuasiQuotes #-} -- > -- > import Language.Embedded.Imperative -- > import Language.C.Quote.C -- > -- > prog = do -- > ... -- > addDefinition myCFunction -- > ... -- > where -- > myCFunction = [cedecl| -- > void my_C_function( ... ) -- > { -- > // C code -- > // goes here -- > } -- > |] addDefinition :: (CallCMD (IExp instr) :<: instr) => Definition -> ProgramT instr m () addDefinition = singleE . AddDefinition -- | Declare an external function addExternFun :: (VarPred exp res, CallCMD exp :<: instr, exp ~ IExp instr) => String -- ^ Function name -> proxy (exp res) -- ^ Proxy for expression and result type -> [FunArg exp] -- ^ Arguments (only used to determine types) -> ProgramT instr m () addExternFun fun res args = singleE $ AddExternFun fun res args -- | Declare an external procedure addExternProc :: (CallCMD exp :<: instr, exp ~ IExp instr) => String -- ^ Procedure name -> [FunArg exp] -- ^ Arguments (only used to determine types) -> ProgramT instr m () addExternProc proc args = singleE $ AddExternProc proc args -- | Call a function callFun :: (VarPred (IExp instr) a, CallCMD (IExp instr) :<: instr) => String -- ^ Function name -> [FunArg (IExp instr)] -- ^ Arguments -> ProgramT instr m (IExp instr a) callFun fun as = singleE $ CallFun fun as -- | Call a procedure callProc :: (CallCMD (IExp instr) :<: instr) => String -- ^ Procedure name -> [FunArg (IExp instr)] -- ^ Arguments -> ProgramT instr m () callProc fun as = singleE $ CallProc fun as -- | Declare and call an external function externFun :: forall instr m exp res . (VarPred exp res, CallCMD exp :<: instr, exp ~ IExp instr, Monad m) => String -- ^ Function name -> [FunArg exp] -- ^ Arguments -> ProgramT instr m (exp res) externFun fun args = do addExternFun fun (Proxy :: Proxy (exp res)) args callFun fun args -- | Declare and call an external procedure externProc :: (CallCMD exp :<: instr, exp ~ IExp instr, Monad m) => String -- ^ Procedure name -> [FunArg exp] -- ^ Arguments -> ProgramT instr m () externProc proc args = do addExternProc proc args callProc proc args -- | Get current time as number of seconds passed today getTime :: (VarPred (IExp instr) Double, CallCMD (IExp instr) :<: instr, Monad m) => ProgramT instr m (IExp instr Double) getTime = do addInclude "" addInclude "" 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; } |] -- From http://stackoverflow.com/questions/2349776/how-can-i-benchmark-c-code-easily -- Arguments -- | Constant string argument strArg :: String -> FunArg exp strArg = FunArg . StrArg -- | Value argument valArg :: VarPred exp a => exp a -> FunArg exp valArg = FunArg . ValArg -- | Reference argument refArg :: VarPred exp a => Ref a -> FunArg exp refArg = FunArg . RefArg -- | Array argument arrArg :: VarPred exp a => Arr n a -> FunArg exp arrArg = FunArg . ArrArg -- | Abstract object argument objArg :: Object -> FunArg exp objArg = FunArg . ObjArg -- | Modifier that takes the address of another argument addr :: FunArg exp -> FunArg exp addr = FunArg . Addr -------------------------------------------------------------------------------- -- * Running programs -------------------------------------------------------------------------------- -- | Run a program in 'IO'. Note that not all instructions are supported for -- running in 'IO'. For example, calls to external C functions are not -- supported. runIO :: (Interp instr IO, HFunctor instr) => Program instr a -> IO a runIO = interpret