gulcii-0.2.0.1: src/Main.hs
{-
gulcii -- graphical untyped lambda calculus interpreter
Copyright (C) 2011, 2013 Claude Heiland-Allen
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}
module Main (main) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO, killThread, threadDelay, Chan, newChan, readChan, writeChan)
import Control.Monad (forever, when)
import qualified Data.Map.Strict as M
import Data.Map.Strict (Map)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef)
import System.IO (hSetBuffering, BufferMode(LineBuffering), stdout)
import System.IO.Error (catchIOError)
import System.FilePath ((</>), (<.>))
import Graphics.UI.Gtk hiding (Meta)
import Graphics.Rendering.Cairo
import Paths_gulcii (getDataFileName)
import qualified Command as C
import qualified Meta as M
import qualified Sugar as S
import qualified Bruijn as B
import qualified Graph as G
import qualified Layout as L
import qualified Draw as D
import qualified Parse as P
data Interpret = Fail | Skip | Define String G.Term | Pure G.Term | Run G.Term | Meta M.Meta
deriving (Read, Show, Eq, Ord)
interpret :: String -> Interpret
interpret l =
case P.unP C.parse `fmap` P.tokenize (P.decomment l) of
Just ((C.Define d sterm, []):_) ->
case S.desugar sterm of
Just term -> Define d . G.graph . B.bruijn $ term
_ -> Fail
Just ((C.Evaluate sterm, []):_) ->
case S.desugar sterm of
Just term -> Pure . G.graph . B.bruijn $ term
_ -> Fail
Just ((C.Execute sterm, []):_) ->
case S.desugar sterm of
Just term -> Run . G.graph . B.bruijn $ term
_ -> Fail
Just ((C.Meta m, []):_) -> Meta m
Just [] -> Skip
_ -> Fail
main :: IO ()
main = do
_args <- initGUI
envR <- newIORef M.empty
lRef <- newIORef Nothing
evalR <- newIORef Nothing
outC <- newChan
_ <- forkIO $ outputter outC
let out = writeChan outC
win <- windowNew
_ <- onDestroy win mainQuit
windowSetDefaultSize win 1024 720
vb <- vBoxNew False 0
hb <- hPanedNew
tt <- textTagTableNew
tagInputRem <- textTagNew Nothing
tagInputDef <- textTagNew Nothing
tagInputPure <- textTagNew Nothing
tagInputRun <- textTagNew Nothing
tagInputMeta <- textTagNew Nothing
tagOutput <- textTagNew Nothing
tagOutputMeta <- textTagNew Nothing
tagError <- textTagNew Nothing
set tagInputRem [ textTagForeground := "cyan" ]
set tagInputDef [ textTagForeground := "green" ]
set tagInputPure [ textTagForeground := "yellow" ]
set tagInputRun [ textTagForeground := "orange" ]
set tagInputMeta [ textTagForeground := "blue" ]
set tagOutput [ textTagForeground := "magenta" ]
set tagOutputMeta [ textTagForeground := "pink" ]
set tagError [ textTagForeground := "red" ]
textTagTableAdd tt tagInputRem
textTagTableAdd tt tagInputDef
textTagTableAdd tt tagInputPure
textTagTableAdd tt tagInputRun
textTagTableAdd tt tagInputMeta
textTagTableAdd tt tagOutput
textTagTableAdd tt tagOutputMeta
textTagTableAdd tt tagError
tf <- textBufferNew (Just tt)
tb <- textBufferNew (Just tt)
tv <- textViewNewWithBuffer tf
mk <- textMarkNew Nothing False
it <- textBufferGetIterAtOffset tf (-1)
textBufferAddMark tf mk it
textViewSetEditable tv False
textViewSetWrapMode tv WrapWord
da <- drawingAreaNew
_ <- da `on` exposeEvent $ do
dw <- eventWindow
liftIO $ do
ml <- atomicModifyIORef lRef (\m -> (m, m))
case ml of
Nothing -> return ()
Just l -> do
(ww, hh) <- drawableGetSize dw
renderWithDrawable dw $ do
D.draw (fromIntegral ww) (fromIntegral hh) l
return True
en <- entryNew
entrySetWidthChars en 24
font <- fontDescriptionFromString "Monospaced 18"
widgetModifyFont tv (Just font)
widgetModifyFont en (Just font)
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAlways
containerAdd sw tv
al <- alignmentNew 1 0 1 1
set al [ containerChild := da ]
boxPackStart vb en PackNatural 0
boxPackStart vb sw PackGrow 0
panedPack1 hb vb False True
panedPack2 hb al True True
set win [ containerChild := hb ]
containerSetFocusChain vb [toWidget en]
let scrollDown = do
textViewScrollToMark tv mk 0 Nothing
addText tag txt = do
start' <- textBufferGetIterAtOffset tb 0
end' <- textBufferGetIterAtOffset tb (-1)
textBufferDelete tb start' end'
textBufferInsert tb start' (unlines [txt])
start <- textBufferGetIterAtOffset tb 0
end <- textBufferGetIterAtOffset tb (-1)
textBufferApplyTag tb tag start end
pos <- textBufferGetIterAtOffset tf (-1)
textBufferInsertRange tf pos start end
textBufferMoveMark tf mk pos
_ <- en `onEntryActivate` do
let exec echo txt =
case interpret txt of
Fail -> addText tagError txt
Skip -> when echo $ do
addText tagInputRem txt
entrySetText en ""
Define def term -> do
when echo $ do
addText tagInputDef txt
entrySetText en ""
atomicModifyIORef envR (\defs -> (M.insert def term defs, ()))
Pure term -> do
when echo $ do
addText tagInputPure txt
entrySetText en ""
mtid <- readIORef evalR
case mtid of
Nothing -> return ()
Just tid -> killThread tid
tid <- forkIO $ evaluator 10000 lRef out envR M.empty term goPure
writeIORef evalR (Just tid)
Run term -> do
when echo $ do
addText tagInputRun txt
entrySetText en ""
mtid <- readIORef evalR
case mtid of
Nothing -> return ()
Just tid -> killThread tid
tid <- forkIO $ evaluator 10000 lRef out envR M.empty term (goRun (postGUIAsync . addText tagOutput))
writeIORef evalR (Just tid)
Meta M.Quit -> do
_ <- forkIO $ do
out "quit ;"
postGUISync mainQuit
return ()
Meta M.Clear -> do
when echo $ do
addText tagInputMeta txt
entrySetText en ""
atomicModifyIORef envR (\_ -> (M.empty, ()))
Meta M.Browse -> do
when echo $ do
addText tagInputMeta txt
entrySetText en ""
defs <- readIORef envR
addText tagOutputMeta(unwords (M.keys defs))
Meta (M.Load f) -> do
when echo $ do
addText tagInputMeta txt
f' <- getDataFileName ("lib" </> f <.> "gu")
s <- (fmap Right (readFile f')) `catchIOError` (return . Left . show)
case s of
Right t -> do
when echo $ do
entrySetText en ""
mapM_ (exec False) (lines t)
Left e ->
addText tagError e
txt <- entryGetText en
exec True txt
scrollDown
_ <- flip timeoutAdd 100 $ widgetQueueDraw da >> return True
widgetShowAll win
mainGUI
type Go = G.References -> G.Term -> IO (G.Term, G.References)
goPure :: Go
goPure refs term = return (term, refs)
goRun :: (String -> IO ()) -> Go
goRun out refs term = do
out (G.pretty term)
return (term, refs)
gc :: G.References -> G.Term -> (G.Term, G.References)
gc refs term =
let keep = reachable refs term M.empty
(collapse, later) = M.partition (1 ==) keep
in (compact refs term, M.fromList [ (k, compact refs (refs M.! k)) | k <- M.keys collapse ] `M.union` M.fromList [ (k, refs M.! k) | k <- M.keys later ])
reachable :: G.References -> G.Term -> Map Integer Integer -> Map Integer Integer
reachable r (G.Lambda _ t) m = reachable r t m
reachable r (G.Apply s t) m = reachable r s (reachable r t m)
reachable r (G.Reference p) m = (if p `M.member` m then id else reachable r (r M.! p)) (M.insertWith (+) p 1 m)
reachable r (G.Trace _ s t) m = reachable r s (reachable r t m)
reachable _ _ m = m
compact :: G.References -> G.Term -> G.Term
compact r (G.Reference p) = r M.! p
compact _ t = t
evaluator :: Int -> IORef (Maybe L.Layout) -> (String -> IO ()) -> IORef G.Definitions -> G.References -> G.Term -> Go -> IO ()
evaluator tick layout out defsR refs term go = do
defs <- readIORef defsR
let (term1, refs1) = gc refs term
(term0, refs0) <- go refs1 term1
case G.reduce defs refs0 term0 of
Nothing -> threadDelay tick >> evaluator tick layout out defsR refs0 term0 go
Just (G.Reduced term' refs') -> evaluator tick layout out defsR refs' term' go
Just (G.Rebound _var' term' refs') -> evaluator tick layout out defsR refs' term' go
Just (G.Traced k s term' refs') -> do
atomicModifyIORef layout $ \_ -> (Just $ L.layout term0 refs0, ())
case k of
"wait" -> case evalNatural (dereference refs0 s) of
Just n -> threadDelay (tick * fromInteger n)
_ -> return ()
"noteon" -> case evalList evalNatural (dereference refs0 s) of
Just msg@[_channel, _note, _velocity] ->
out $ "noteon " ++ unwords (map show msg) ++ " ;"
_ -> return ()
"noteoff" -> case evalList evalNatural (dereference refs0 s) of
Just msg@[_channel, _note, _velocity] ->
out $ "noteoff " ++ unwords (map show msg) ++ " ;"
_ -> return ()
"program" -> case evalList evalNatural (dereference refs0 s) of
Just msg@[_channel, _program] ->
out $ "program " ++ unwords (map show msg) ++ " ;"
_ -> return ()
"control" -> case evalList evalNatural (dereference refs0 s) of
Just msg@[_channel, _control, _value] ->
out $ "control " ++ unwords (map show msg) ++ " ;"
_ -> return ()
_ -> print (k, G.pretty (dereference refs0 s))
evaluator tick layout out defsR refs' term' go
dereference :: G.References -> G.Term -> G.Term
dereference r (G.Reference p) = dereference r (r M.! p)
dereference r (G.Lambda k t) = G.Lambda k (dereference r t)
dereference r (G.Apply a b) = G.Apply (dereference r a) (dereference r b)
dereference r (G.Trace k a b) = G.Trace k (dereference r a) (dereference r b)
dereference _ t = t
evalNatural :: G.Term -> Maybe Integer
evalNatural (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just 0
evalNatural (G.Lambda _ (G.Lambda _ (G.Apply (G.Bound 1) t))) = (1 +) `fmap` evalNatural t
evalNatural _ = Nothing
evalList :: (G.Term -> Maybe a) -> G.Term -> Maybe [a]
evalList _ (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just []
evalList f (G.Lambda _ (G.Lambda _ (G.Apply (G.Apply (G.Bound 1) s) t))) = (:) <$> f s <*> evalList f t
evalList _ _ = Nothing
outputter :: Chan String -> IO ()
outputter out = do
hSetBuffering stdout LineBuffering
forever $ do
s <- readChan out
putStrLn s