kansas-lava-cores-0.1.2.1: Hardware/KansasLava/Simulators/Polyester.hs
{-# LANGUAGE ScopedTypeVariables, GADTs, DeriveDataTypeable #-}
-- | * Remember to call init_board for your specific board.
module Hardware.KansasLava.Simulators.Polyester (
-- * The (abstract) Fake Fabric Monad
Polyester -- abstract
-- * The Polyester non-proper morphisms
, outPolyester
, outPolyesterEvents
, outPolyesterCount
, writeSocketPolyester
, inPolyester
, readSocketPolyester
, getPolyesterExecMode
, getPolyesterClkSpeed
, getPolyesterSimSpeed
-- * Running the Fake Polyester
, runPolyester
, ExecMode(..)
-- * Support for building fake Boards
, generic_init
-- * Support for the (ANSI) Graphics
, ANSI(..)
, Color(..) -- from System.Console.ANSI
, Graphic(..)
) where
import System.Console.ANSI
import System.IO
import Data.Typeable
import Control.Exception
import Control.Concurrent
import Control.Applicative
import Control.Monad
import Data.Char
import Control.Monad.Fix
import Data.Word
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Concurrent
import Network
import System.Directory
-----------------------------------------------------------------------
-- Monad
-----------------------------------------------------------------------
-- | The simulator uses its own 'Fabric', which connects not to pins on the chip,
-- but rather an ASCII picture of the board.
data PolyesterEnv = PolyesterEnv
{ pExecMode :: ExecMode
, pFindSocket :: String -> IO Handle
, pClkSpeed :: Integer -- clock speed, in Hz
, pSimSpeed :: Integer -- how many cycles are we *actually* doing a second
}
data Polyester a = Polyester ([Maybe Char]
-> PolyesterEnv
-> IO (a,[Stepper]))
instance Functor Polyester where
fmap f (Polyester p) = Polyester $ \ inp st -> do
(x, s) <- p inp st
return (f x, s)
instance Applicative Polyester where
pure x = Polyester $ \ _ _ -> return (x, [])
(Polyester pf) <*> (Polyester px) = Polyester $ \ inp st -> do
(f, s1) <- pf inp st
(x, s2) <- px inp st
return (f x, s1 ++ s2)
instance Monad Polyester where
return = pure
(Polyester f) >>= k = Polyester $ \ inp st -> do
(a,s1) <- f inp st
let Polyester g = k a
(b,s2) <- g inp st
return (b,s1 ++ s2)
fail msg = error msg
instance MonadFix Polyester where
-- TODO: check this
mfix f = Polyester $ \ inp st ->
mfix (\ r -> let (Polyester g) = f (fst r)
in g inp st)
getPolyesterExecMode :: Polyester ExecMode
getPolyesterExecMode = Polyester $ \ _ st -> return (pExecMode st,[])
getPolyesterClkSpeed :: Polyester Integer
getPolyesterClkSpeed = Polyester $ \ _ st -> return (pClkSpeed st,[])
getPolyesterSimSpeed :: Polyester Integer
getPolyesterSimSpeed = Polyester $ \ _ st -> return (pSimSpeed st,[])
-----------------------------------------------------------------------
-- Ways out outputing from the Polyester
-----------------------------------------------------------------------
-- | Checks an input list for diffences between adjacent elements,
-- and for changes, maps a graphical event onto the internal stepper.
-- The idea is that sending a graphical event twice should be
-- idempotent, but internally the system only writes events
-- when things change.
outPolyester :: (Eq a, Graphic g) => (a -> g) -> [a] -> Polyester ()
outPolyester f = outPolyesterEvents . map (fmap f) . changed
changed :: (Eq a) => [a] -> [Maybe a]
changed (a:as) = Just a : f a as
where
f x (y:ys) | x == y = Nothing : f x ys
| otherwise = Just y : f y ys
f _ [] = []
-- | Turn a list of graphical events into a 'Polyester', without processing.
outPolyesterEvents :: (Graphic g) => [Maybe g] -> Polyester ()
outPolyesterEvents ogs = Polyester $ \ _ _ -> return ((),[stepper ogs])
-- | creates single graphical events, based on the number of Events,
-- when the first real event is event 1, and there is a beginning of time event 0.
-- Example of use: count the number of bytes send or recieved on a device.
outPolyesterCount :: (Graphic g) => (Integer -> g) -> [Maybe a] -> Polyester ()
outPolyesterCount f = outPolyester f . loop 0
where
loop n (Nothing:xs) = n : loop n xs
loop n (Just _:xs) = n : loop (succ n) xs
-- | write a socket from a clocked list input. Example of use is emulating
-- RS232 (which only used empty or singleton strings), for the inside of a list.
writeSocketPolyester :: String -> [Maybe String] -> Polyester ()
writeSocketPolyester filename contents = Polyester $ \ _ st -> do
h <- pFindSocket st filename
return ((),[ ioStepper (map (f h) contents) ])
where
f :: Handle -> Maybe String -> IO ()
f _ Nothing = return ()
f h (Just bs) = do
hPutStr h bs
hFlush h
{-
writeSocketPolyester :: String -> [Maybe String] -> Polyester ()
writeSocketPolyester socketname contents = Polyester $ \ _ _ -> do
-}
-----------------------------------------------------------------------
-- Ways out inputting to the Polyester
-----------------------------------------------------------------------
-- | Turn an observation of the keyboard into a list of values.
inPolyester :: a -- ^ initial 'a'
-> (Char -> a -> a) -- ^ how to interpreate a key press
-> Polyester [a]
inPolyester a interp = Polyester $ \ inp _ -> do
let f' a' Nothing = a'
f' a' (Just c) = interp c a'
vals = scanl f' a inp
return (vals,[])
-- | 'readSocketPolyester' reads from a socket.
-- The stream is on-demand, and is not controlled by any clock
-- inside the function. Typically would be read one cons per
-- clock, but slower reading is acceptable.
-- This does not make any attempt to register
-- what is being observed on the screen; another
-- process needs to do this.
readSocketPolyester :: String -> Polyester [Maybe Word8]
readSocketPolyester filename = Polyester $ \ inp st -> do
h <- pFindSocket st filename
ss <- hGetContentsStepwise h
return (map (fmap (fromIntegral . ord)) ss,[])
-----------------------------------------------------------------------
-- Running the Polyester
-----------------------------------------------------------------------
data ExecMode
= Fast -- ^ run as fast as possible, and do not display the clock
| Friendly -- ^ run in friendly mode, with 'threadDelay' to run slower, to be CPU friendly.
deriving (Eq, Show)
-- | 'runPolyester' executes the Polyester, never returns, and ususally replaces 'reifyPolyester'.
runPolyester :: ExecMode -> Integer -> Integer -> Polyester () -> IO ()
runPolyester mode clkSpeed simSpeed f = do
setTitle "Kansas Lava"
putStrLn "[Booting Spartan3e simulator]"
hSetBuffering stdin NoBuffering
hSetEcho stdin False
-- create the virtual device directory
createDirectoryIfMissing True "dev"
inputs <- hGetContentsStepwise stdin
-- let -- clockOut | mode == Fast = return ()
-- clockOut | mode == Friendly =
-- outPolyester clock [0..]
let extras = do
quit <- inPolyester False (\ c _ -> c == 'q')
outPolyester (\ b -> if b
then error "Simulation Quit"
else return () :: ANSI ()) quit
let Polyester h = (do extras ; f)
sockDB <- newMVar []
let findSock :: String -> IO Handle
findSock nm = do
sock_map <- takeMVar sockDB
case lookup nm sock_map of
Just h -> do
putMVar sockDB sock_map
return h
Nothing -> do
h <- finally
(do sock <- listenOn $ UnixSocket nm
putStrLn $ "* Waiting for client for " ++ nm
(h,_,_) <- accept sock
putStrLn $ "* Found client for " ++ nm
return h)
(removeFile nm)
hSetBuffering h NoBuffering
putMVar sockDB $ (nm,h) : sock_map
return h
(_,steps) <- h inputs $ PolyesterEnv
{ pExecMode = mode
, pFindSocket = findSock
, pClkSpeed = clkSpeed
, pSimSpeed = simSpeed
}
putStrLn "[Starting simulation]"
putStr "\ESC[2J\ESC[1;1H"
let slowDown | mode == Fast = []
| mode == Friendly =
[ ioStepper [ threadDelay (20 * 1000)
| _ <- [(0 :: Integer)..] ]]
runSteppers (steps ++ slowDown)
-----------------------------------------------------------------------
-- Utils for building boards
-----------------------------------------------------------------------
-- | 'generic_init' builds a generic board_init, including
-- setting up the drawing of the board, and printing the (optional) clock.
generic_init :: (Graphic g1,Graphic g2) => g1 -> (Integer -> g2) -> Polyester ()
generic_init board clock = do
-- a bit of a hack; print the board on the first cycle
outPolyester (\ _ -> board) [()]
mode <- getPolyesterExecMode
when (mode /= Fast) $ do
outPolyester (clock) [0..]
return ()
-----------------------------------------------------------------------
-- Abstaction for output (typically the screen)
-----------------------------------------------------------------------
class Graphic g where
drawGraphic :: g -> ANSI ()
-----------------------------------------------------------------------
-- Internal: The Stepper abstraction, which is just the resumption monad
-----------------------------------------------------------------------
-- The idea in the future is we can common up the changes to the
-- screen, removing needless movement of the cursor, allowing
-- a slight pause before updating, etc.
-- Do something, and return.
data Stepper = Stepper (IO (Stepper))
runStepper :: Stepper -> IO Stepper
runStepper (Stepper m) = m
-- | 'runSteppers' runs several steppers concurrently.
runSteppers :: [Stepper] -> IO ()
runSteppers ss = do
ss' <- sequence [ runStepper m
| m <- ss
]
-- threadDelay (10 * 1000)
runSteppers ss'
-- Stepper could be written in terms of ioStepper
stepper :: (Graphic g) => [Maybe g] -> Stepper
stepper = ioStepper
. map (\ o -> case o of
Nothing -> return ()
Just g -> showANSI (drawGraphic g))
ioStepper :: [IO ()] -> Stepper
ioStepper (m:ms) = Stepper (do m ; return (ioStepper ms))
ioStepper other = Stepper (return $ ioStepper other)
-----------------------------------------------------------------------
-- Helpers for printing to the screen
-----------------------------------------------------------------------
data ANSI a where
REVERSE :: ANSI () -> ANSI ()
COLOR :: Color -> ANSI () -> ANSI ()
PRINT :: String -> ANSI ()
AT :: ANSI () -> (Int,Int) -> ANSI ()
BIND :: ANSI b -> (b -> ANSI a) -> ANSI a
RETURN :: a -> ANSI a
instance Functor ANSI where
fmap f m = m `BIND` (RETURN . f)
instance Applicative ANSI where
pure = RETURN
mf <*> mx = BIND mf $ \f ->
BIND mx $ \x ->
RETURN (f x)
instance Monad ANSI where
return = pure
(>>=) = BIND
showANSI :: ANSI a -> IO a
showANSI (REVERSE ascii) = do
setSGR [SetSwapForegroundBackground True]
showANSI ascii
setSGR []
hFlush stdout
showANSI (COLOR col ascii) = do
setSGR [SetColor Foreground Vivid col]
showANSI ascii
setSGR []
hFlush stdout
showANSI (PRINT str) = putStr str
showANSI (AT ascii (row,col)) = do
setCursorPosition row col
showANSI ascii
setCursorPosition 24 0
hFlush stdout
showANSI (RETURN a) = return a
showANSI (BIND m k) = do
a <- showANSI m
showANSI (k a)
-- | Rather than use a data-structure for each action,
-- ANSI can be used instead. Not recommended, but harmless.
instance Graphic (ANSI a) where
drawGraphic g = do g ; return ()
-----------------------------------------------------------------------
-- Steping version of hGetContent, never blocks, returning
-- a stream of nothing after the end file.
-----------------------------------------------------------------------
hGetContentsStepwise :: Handle -> IO [Maybe Char]
hGetContentsStepwise h = do
opt_ok <- try (hReady h)
case opt_ok of
Right ok -> do
out <- if ok then do
ch <- hGetChar h
return (Just ch)
else do
return Nothing
rest <- unsafeInterleaveIO $ hGetContentsStepwise h
return (out : rest)
Left (e :: IOException) -> return (repeat Nothing)
-----------------------------------------------------------------------
-- Exception Magic
-----------------------------------------------------------------------
data PolyesterException = PolyesterException String
deriving Typeable
instance Show PolyesterException where
show (PolyesterException msg) = msg
instance Exception PolyesterException