module Hardware.KansasLava.Simulators.Polyester (
Polyester
, outPolyester
, outPolyesterEvents
, outPolyesterCount
, writeSocketPolyester
, inPolyester
, readSocketPolyester
, getPolyesterExecMode
, getPolyesterClkSpeed
, getPolyesterSimSpeed
, runPolyester
, ExecMode(..)
, generic_init
, ANSI(..)
, Color(..)
, 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
data PolyesterEnv = PolyesterEnv
{ pExecMode :: ExecMode
, pFindSocket :: String -> IO Handle
, pClkSpeed :: Integer
, pSimSpeed :: Integer
}
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
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,[])
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 _ [] = []
outPolyesterEvents :: (Graphic g) => [Maybe g] -> Polyester ()
outPolyesterEvents ogs = Polyester $ \ _ _ -> return ((),[stepper ogs])
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
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
inPolyester :: a
-> (Char -> a -> a)
-> 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 :: String -> Polyester [Maybe Word8]
readSocketPolyester filename = Polyester $ \ inp st -> do
h <- pFindSocket st filename
ss <- hGetContentsStepwise h
return (map (fmap (fromIntegral . ord)) ss,[])
data ExecMode
= Fast
| Friendly
deriving (Eq, Show)
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
createDirectoryIfMissing True "dev"
inputs <- hGetContentsStepwise stdin
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)
generic_init :: (Graphic g1,Graphic g2) => g1 -> (Integer -> g2) -> Polyester ()
generic_init board clock = do
outPolyester (\ _ -> board) [()]
mode <- getPolyesterExecMode
when (mode /= Fast) $ do
outPolyester (clock) [0..]
return ()
class Graphic g where
drawGraphic :: g -> ANSI ()
data Stepper = Stepper (IO (Stepper))
runStepper :: Stepper -> IO Stepper
runStepper (Stepper m) = m
runSteppers :: [Stepper] -> IO ()
runSteppers ss = do
ss' <- sequence [ runStepper m
| m <- ss
]
runSteppers ss'
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)
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)
instance Graphic (ANSI a) where
drawGraphic g = do g ; return ()
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)
data PolyesterException = PolyesterException String
deriving Typeable
instance Show PolyesterException where
show (PolyesterException msg) = msg
instance Exception PolyesterException