module Feldspar.Run.Marshal where
import qualified Prelude
import Prelude hiding (length)
import Data.Typeable
import Feldspar
import Feldspar.Run.Representation
import Feldspar.Run.Compile
import Feldspar.Run.Frontend
import Language.Embedded.Backend.C (ExternalCompilerOpts (..), Default (..))
newtype Parser a = Parser {runParser :: String -> (a, String)}
deriving (Functor)
instance Applicative Parser
where
pure = return
(<*>) = ap
instance Monad Parser
where
return a = Parser $ \s -> (a,s)
p >>= k = Parser $ \s -> let (a,s') = runParser p s in runParser (k a) s'
readParser :: forall a . (Read a, Typeable a) => Parser a
readParser = Parser $ \s -> case reads s of
[(a,s')] -> (a,s')
_ -> error $ unwords
[ "toHaskell: cannot read"
, show s
, "as type"
, show (typeOf (undefined :: a))
]
parse :: Parser a -> String -> a
parse = (fst .) . runParser
class MarshalHaskell a
where
fromHaskell :: a -> String
default fromHaskell :: Show a => a -> String
fromHaskell = show
toHaskell :: Parser a
default toHaskell :: (Read a, Typeable a) => Parser a
toHaskell = readParser
instance MarshalHaskell Int
instance MarshalHaskell Int8
instance MarshalHaskell Int16
instance MarshalHaskell Int32
instance MarshalHaskell Int64
instance MarshalHaskell Word8
instance MarshalHaskell Word16
instance MarshalHaskell Word32
instance MarshalHaskell Word64
instance MarshalHaskell Float
instance MarshalHaskell Double
instance MarshalHaskell (Complex Float)
where
fromHaskell (r :+ i) = fromHaskell (r,i)
toHaskell = fmap (uncurry (:+)) toHaskell
instance MarshalHaskell (Complex Double)
where
fromHaskell (r :+ i) = fromHaskell (r,i)
toHaskell = fmap (uncurry (:+)) toHaskell
instance (MarshalHaskell a, MarshalHaskell b) => MarshalHaskell (a,b)
where
fromHaskell (a,b) = unwords [fromHaskell a, fromHaskell b]
toHaskell = (,) <$> toHaskell <*> toHaskell
instance (MarshalHaskell a, MarshalHaskell b, MarshalHaskell c) => MarshalHaskell (a,b,c)
where
fromHaskell (a,b,c) = unwords [fromHaskell a, fromHaskell b, fromHaskell c]
toHaskell = (,,) <$> toHaskell <*> toHaskell <*> toHaskell
instance (MarshalHaskell a, MarshalHaskell b, MarshalHaskell c, MarshalHaskell d) => MarshalHaskell (a,b,c,d)
where
fromHaskell (a,b,c,d) = unwords [fromHaskell a, fromHaskell b, fromHaskell c, fromHaskell d]
toHaskell = (,,,) <$> toHaskell <*> toHaskell <*> toHaskell <*> toHaskell
instance MarshalHaskell a => MarshalHaskell [a]
where
fromHaskell as = unwords $ show (Prelude.length as) : map fromHaskell as
toHaskell = do
len <- toHaskell
replicateM len toHaskell
class (MarshalHaskell (HaskellRep a)) => MarshalFeld a
where
type HaskellRep a
fwrite :: Handle -> a -> Run ()
default fwrite :: (PrimType b, Formattable b, a ~ Data b) =>
Handle -> a -> Run ()
fwrite hdl i = fput hdl "" i ""
fread :: Handle -> Run a
default fread :: (PrimType b, Formattable b, a ~ Data b) => Handle -> Run a
fread = fget
writeStd :: MarshalFeld a => a -> Run ()
writeStd = fwrite stdout
readStd :: MarshalFeld a => Run a
readStd = fread stdin
instance MarshalFeld (Data Int8) where type HaskellRep (Data Int8) = Int8
instance MarshalFeld (Data Int16) where type HaskellRep (Data Int16) = Int16
instance MarshalFeld (Data Int32) where type HaskellRep (Data Int32) = Int32
instance MarshalFeld (Data Int64) where type HaskellRep (Data Int64) = Int64
instance MarshalFeld (Data Word8) where type HaskellRep (Data Word8) = Word8
instance MarshalFeld (Data Word16) where type HaskellRep (Data Word16) = Word16
instance MarshalFeld (Data Word32) where type HaskellRep (Data Word32) = Word32
instance MarshalFeld (Data Word64) where type HaskellRep (Data Word64) = Word64
instance MarshalFeld (Data Float) where type HaskellRep (Data Float) = Float
instance MarshalFeld (Data Double) where type HaskellRep (Data Double) = Double
instance MarshalFeld (Data (Complex Float))
where
type HaskellRep (Data (Complex Float)) = Complex Float
fwrite hdl c = fwrite hdl (realPart c, imagPart c)
fread = fmap (uncurry complex) . fread
instance MarshalFeld (Data (Complex Double))
where
type HaskellRep (Data (Complex Double)) = Complex Double
fwrite hdl c = fwrite hdl (realPart c, imagPart c)
fread = fmap (uncurry complex) . fread
instance (MarshalFeld a, MarshalFeld b) => MarshalFeld (a,b)
where
type HaskellRep (a,b) = (HaskellRep a, HaskellRep b)
fwrite hdl (a,b) = fwrite hdl a >> fprintf hdl " " >> fwrite hdl b
fread hdl = (,) <$> fread hdl <*> fread hdl
instance (MarshalFeld a, MarshalFeld b, MarshalFeld c) => MarshalFeld (a,b,c)
where
type HaskellRep (a,b,c) = (HaskellRep a, HaskellRep b, HaskellRep c)
fwrite hdl (a,b,c)
= fwrite hdl a >> fprintf hdl " "
>> fwrite hdl b >> fprintf hdl " "
>> fwrite hdl c
fread hdl = (,,) <$> fread hdl <*> fread hdl <*> fread hdl
instance (MarshalFeld a, MarshalFeld b, MarshalFeld c, MarshalFeld d) => MarshalFeld (a,b,c,d)
where
type HaskellRep (a,b,c,d) = (HaskellRep a, HaskellRep b, HaskellRep c, HaskellRep d)
fwrite hdl (a,b,c,d)
= fwrite hdl a >> fprintf hdl " "
>> fwrite hdl b >> fprintf hdl " "
>> fwrite hdl c >> fprintf hdl " "
>> fwrite hdl d
fread hdl = (,,,) <$> fread hdl <*> fread hdl <*> fread hdl <*> fread hdl
instance (MarshalHaskell (Internal a), MarshalFeld a, Syntax a) =>
MarshalFeld (Arr a)
where
type HaskellRep (Arr a) = [Internal a]
fwrite hdl arr = do
len <- shareM $ length arr
fput hdl "" len " "
for (0,1,Excl len) $ \i -> do
a <- getArr arr i
fwrite hdl a
fprintf hdl " "
fread hdl = do
len <- fget hdl
arr <- newArr len
for (0,1,Excl len) $ \i -> do
a <- fread hdl
setArr arr i a
return arr
instance (MarshalHaskell (Internal a), MarshalFeld a, Syntax a) =>
MarshalFeld (IArr a)
where
type HaskellRep (IArr a) = [Internal a]
fwrite hdl arr = do
len <- shareM $ length arr
fput hdl "" len " "
for (0,1,Excl len) $ \i -> do
fwrite hdl $ arrIx arr i
fprintf hdl " "
fread hdl = do
len <- fget hdl
arr <- newArr len
for (0,1,Excl len) $ \i -> do
a <- fread hdl
setArr arr i a
iarr <- unsafeFreezeArr arr
return iarr
connectStdIO :: (MarshalFeld a, MarshalFeld b) => (a -> Run b) -> Run ()
connectStdIO f = (readStd >>= f) >>= writeStd
streamStdIO :: (MarshalFeld a, MarshalFeld b) => (a -> Run b) -> Run ()
streamStdIO f = do
n :: Data Length <- readStd
writeStd n
for (0,1,Excl n) $ \_ ->
connectStdIO $ \a -> printf " " >> f a
marshalled' :: (MarshalFeld a, MarshalFeld b)
=> CompilerOpts
-> ExternalCompilerOpts
-> (a -> Run b)
-> ((HaskellRep a -> IO (HaskellRep b)) -> IO c)
-> IO c
marshalled' opts eopts f body =
withCompiled' opts eopts (connectStdIO f) $ \g ->
body (fmap (parse toHaskell) . g . fromHaskell)
marshalled :: (MarshalFeld a, MarshalFeld b)
=> (a -> Run b)
-> ((HaskellRep a -> IO (HaskellRep b)) -> IO c)
-> IO c
marshalled = marshalled' def def
marshalledStream' :: (MarshalFeld a, MarshalFeld b)
=> CompilerOpts
-> ExternalCompilerOpts
-> (a -> Run b)
-> (([HaskellRep a] -> IO [HaskellRep b]) -> IO c)
-> IO c
marshalledStream' opts eopts f body =
withCompiled' opts eopts (streamStdIO f) $ \g ->
body $ \is -> do
parse toHaskell <$> g (fromHaskell is)
marshalledStream :: (MarshalFeld a, MarshalFeld b)
=> (a -> Run b)
-> (([HaskellRep a] -> IO [HaskellRep b]) -> IO c)
-> IO c
marshalledStream = marshalledStream' def def