preparing for release
[maximus:gulcii.git] / src / gulcii.hs
1 {-
2     gulcii -- graphical untyped lambda calculus interpreter
3     Copyright (C) 2011, 2013  Claude Heiland-Allen
4
5     This program is free software; you can redistribute it and/or modify
6     it under the terms of the GNU General Public License as published by
7     the Free Software Foundation; either version 2 of the License, or
8     (at your option) any later version.
9
10     This program is distributed in the hope that it will be useful,
11     but WITHOUT ANY WARRANTY; without even the implied warranty of
12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13     GNU General Public License for more details.
14
15     You should have received a copy of the GNU General Public License along
16     with this program; if not, write to the Free Software Foundation, Inc.,
17     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18 -}
19
20 module Main (main) where
21
22 import Control.Applicative ((<$>), (<*>))
23 import Control.Concurrent (forkIO, killThread, threadDelay, Chan, newChan, readChan, writeChan)
24 import Control.Monad (forever, when)
25 import qualified Data.Map.Strict as M
26 import Data.Map.Strict (Map)
27 import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef)
28 import System.IO (hSetBuffering, BufferMode(LineBuffering), stdout)
29 import System.IO.Error (catchIOError)
30 import System.FilePath ((<.>))
31 import Graphics.UI.Gtk hiding (Meta)
32 import Graphics.Rendering.Cairo
33
34 import Paths_gulcii (getDataFileName)
35
36 import qualified Command as C
37 import qualified Meta as M
38 import qualified Sugar as S
39 import qualified Bruijn as B
40 import qualified Graph as G
41 import qualified Layout as L
42 import qualified Draw as D
43 import qualified Parse as P
44
45 data Interpret = Fail | Skip | Define String G.Term | Pure G.Term | Run G.Term | Meta M.Meta
46   deriving (Read, Show, Eq, Ord)
47
48 interpret :: String -> Interpret
49 interpret l =
50   case P.unP C.parse `fmap` P.tokenize (P.decomment l) of
51     Just ((C.Define d sterm, []):_) ->
52       case S.desugar sterm of
53         Just term -> Define d . G.graph . B.bruijn $ term
54         _ -> Fail
55     Just ((C.Evaluate sterm, []):_) ->
56       case S.desugar sterm of
57         Just term -> Pure . G.graph . B.bruijn $ term
58         _ -> Fail
59     Just ((C.Execute sterm, []):_) ->
60       case S.desugar sterm of
61         Just term -> Run . G.graph . B.bruijn $ term
62         _ -> Fail
63     Just ((C.Meta m, []):_) -> Meta m
64     Just [] -> Skip
65     _ -> Fail
66
67 main :: IO ()
68 main = do
69   _args <- initGUI
70   envR <- newIORef M.empty
71   lRef <- newIORef Nothing
72   evalR <- newIORef Nothing
73   outC <- newChan
74   _ <- forkIO $ outputter outC
75   let out = writeChan outC
76   win <- windowNew
77   _ <- onDestroy win mainQuit
78   windowSetDefaultSize win 1024 720
79   vb <- vBoxNew False 0
80   hb <- hPanedNew
81   tt <- textTagTableNew
82   tagInputRem   <- textTagNew Nothing
83   tagInputDef   <- textTagNew Nothing
84   tagInputPure  <- textTagNew Nothing
85   tagInputRun   <- textTagNew Nothing
86   tagInputMeta  <- textTagNew Nothing
87   tagOutput     <- textTagNew Nothing
88   tagOutputMeta <- textTagNew Nothing
89   tagError      <- textTagNew Nothing
90   set tagInputRem   [ textTagForeground := "cyan"    ]
91   set tagInputDef   [ textTagForeground := "green"   ]
92   set tagInputPure  [ textTagForeground := "yellow"  ]
93   set tagInputRun   [ textTagForeground := "orange"  ]
94   set tagInputMeta  [ textTagForeground := "blue"    ]
95   set tagOutput     [ textTagForeground := "magenta" ]
96   set tagOutputMeta [ textTagForeground := "pink"    ]
97   set tagError      [ textTagForeground := "red"     ]
98   textTagTableAdd tt tagInputRem
99   textTagTableAdd tt tagInputDef
100   textTagTableAdd tt tagInputPure
101   textTagTableAdd tt tagInputRun
102   textTagTableAdd tt tagInputMeta
103   textTagTableAdd tt tagOutput
104   textTagTableAdd tt tagOutputMeta
105   textTagTableAdd tt tagError
106   tf <- textBufferNew (Just tt)
107   tb <- textBufferNew (Just tt)
108   tv <- textViewNewWithBuffer tf
109   mk <- textMarkNew Nothing False
110   it <- textBufferGetIterAtOffset tf (-1)
111   textBufferAddMark tf mk it
112   textViewSetEditable tv False
113   textViewSetWrapMode tv WrapWord
114   da <- drawingAreaNew
115   _ <- da `on` exposeEvent $ do
116     dw <- eventWindow
117     liftIO $ do
118       ml <- atomicModifyIORef lRef (\m -> (m, m))
119       case ml of
120         Nothing -> return ()
121         Just l -> do
122           (ww, hh) <- drawableGetSize dw
123           renderWithDrawable dw $ do
124             D.draw (fromIntegral ww) (fromIntegral hh) l
125     return True
126   en <- entryNew
127   entrySetWidthChars en 24
128   font <- fontDescriptionFromString "Monospaced 18"
129   widgetModifyFont tv (Just font)
130   widgetModifyFont en (Just font)
131   sw <- scrolledWindowNew Nothing Nothing
132   scrolledWindowSetPolicy sw PolicyAutomatic PolicyAlways
133   containerAdd sw tv
134   al <- alignmentNew 1 0 1 1
135   set al [ containerChild := da ]
136   boxPackStart vb en PackNatural 0
137   boxPackStart vb sw PackGrow 0
138   panedPack1 hb vb False True
139   panedPack2 hb al True True
140   set win [ containerChild := hb ]
141   containerSetFocusChain vb [toWidget en]
142   let scrollDown = do
143         textViewScrollToMark tv mk 0 Nothing
144       addText tag txt = do
145         start' <- textBufferGetIterAtOffset tb 0
146         end' <- textBufferGetIterAtOffset tb (-1)
147         textBufferDelete tb start' end'
148         textBufferInsert tb start' (unlines [txt])
149         start <- textBufferGetIterAtOffset tb 0
150         end <- textBufferGetIterAtOffset tb (-1)
151         textBufferApplyTag tb tag start end
152         pos <- textBufferGetIterAtOffset tf (-1)
153         textBufferInsertRange tf pos start end
154         textBufferMoveMark tf mk pos
155   _ <- en `onEntryActivate` do
156     let exec echo txt =
157           case interpret txt of
158             Fail -> addText tagError txt
159             Skip -> when echo $ do
160               addText tagInputRem txt
161               entrySetText en ""
162             Define def term -> do
163               when echo $ do
164                 addText tagInputDef txt
165                 entrySetText en ""
166               atomicModifyIORef envR (\defs -> (M.insert def term defs, ()))
167             Pure term -> do
168               when echo $ do
169                 addText tagInputPure txt
170                 entrySetText en ""
171               mtid <- readIORef evalR
172               case mtid of
173                 Nothing -> return ()
174                 Just tid -> killThread tid
175               tid <- forkIO $ evaluator 10000 lRef out envR M.empty term goPure
176               writeIORef evalR (Just tid)
177             Run term -> do
178               when echo $ do
179                 addText tagInputRun txt
180                 entrySetText en ""
181               mtid <- readIORef evalR
182               case mtid of
183                 Nothing -> return ()
184                 Just tid -> killThread tid
185               tid <- forkIO $ evaluator 10000 lRef out envR M.empty term (goRun (postGUIAsync . addText tagOutput))
186               writeIORef evalR (Just tid)
187             Meta M.Quit -> do
188               _ <- forkIO $ do
189                 out "quit ;"
190                 postGUISync mainQuit
191               return ()
192             Meta M.Clear -> do
193               when echo $ do
194                 addText tagInputMeta txt
195                 entrySetText en ""
196               atomicModifyIORef envR (\_ -> (M.empty, ()))
197             Meta M.Browse -> do
198               when echo $ do
199                 addText tagInputMeta txt
200                 entrySetText en ""
201               defs <- readIORef envR
202               addText tagOutputMeta(unwords (M.keys defs))
203             Meta (M.Load f) -> do
204               when echo $ do
205                 addText tagInputMeta txt
206               f' <- getDataFileName (lib </> f <.> "gu")
207               s <- (fmap Right (readFile f')) `catchIOError` (return . Left . show)
208               case s of
209                 Right t -> do
210                   when echo $ do
211                     entrySetText en ""
212                   mapM_ (exec False) (lines t)
213                 Left e ->
214                   addText tagError e
215     txt <- entryGetText en
216     exec True txt
217     scrollDown
218   _ <- flip timeoutAdd 100 $ widgetQueueDraw da >> return True
219   widgetShowAll win
220   mainGUI
221
222 type Go = G.References -> G.Term -> IO (G.Term, G.References)
223
224 goPure :: Go
225 goPure refs term = return (term, refs)
226
227 goRun :: (String -> IO ()) -> Go
228 goRun out refs term = do
229   out (G.pretty term)
230   return (term, refs)
231
232 gc :: G.References -> G.Term -> (G.Term, G.References)
233 gc refs term =
234   let keep = reachable refs term M.empty
235       (collapse, later) = M.partition (1 ==) keep
236   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 ])
237
238 reachable :: G.References -> G.Term -> Map Integer Integer -> Map Integer Integer
239 reachable r (G.Lambda _ t) m = reachable r t m
240 reachable r (G.Apply s t) m = reachable r s (reachable r t m)
241 reachable r (G.Reference p) m = (if p `M.member` m then id else reachable r (r M.! p)) (M.insertWith (+) p 1 m)
242 reachable r (G.Trace _ s t) m = reachable r s (reachable r t m)
243 reachable _ _ m = m
244
245 compact :: G.References -> G.Term -> G.Term
246 compact r (G.Reference p) = r M.! p
247 compact _ t = t
248
249 evaluator :: Int -> IORef (Maybe L.Layout) -> (String -> IO ()) -> IORef G.Definitions -> G.References -> G.Term -> Go -> IO ()
250 evaluator tick layout out defsR refs term go = do
251   defs <- readIORef defsR
252   let (term1, refs1) = gc refs term
253   (term0, refs0) <- go refs1 term1
254   case G.reduce defs refs0 term0 of
255     Nothing -> threadDelay tick >>        evaluator tick layout out defsR refs0 term0 go
256     Just (G.Reduced term' refs') ->       evaluator tick layout out defsR refs' term' go
257     Just (G.Rebound _var' term' refs') -> evaluator tick layout out defsR refs' term' go
258     Just (G.Traced k s term' refs') -> do
259       atomicModifyIORef layout $ \_ -> (Just $ L.layout term0 refs0, ())
260       case k of
261         "wait" -> case evalNatural (dereference refs0 s) of
262           Just n -> threadDelay (tick * fromInteger n)
263           _ -> return ()
264         "noteon" -> case evalList evalNatural (dereference refs0 s) of
265           Just msg@[_channel, _note, _velocity] ->
266             out $ "noteon " ++ unwords (map show msg) ++ " ;"
267           _ -> return ()
268         "noteoff" -> case evalList evalNatural (dereference refs0 s) of
269           Just msg@[_channel, _note, _velocity] ->
270             out $ "noteoff " ++ unwords (map show msg) ++ " ;"
271           _ -> return ()
272         "program" -> case evalList evalNatural (dereference refs0 s) of
273           Just msg@[_channel, _program] ->
274             out $ "program " ++ unwords (map show msg) ++ " ;"
275           _ -> return ()
276         "control" -> case evalList evalNatural (dereference refs0 s) of
277           Just msg@[_channel, _control, _value] ->
278             out $ "control " ++ unwords (map show msg) ++ " ;"
279           _ -> return ()
280         _ -> print (k, G.pretty (dereference refs0 s))
281       evaluator tick layout out defsR refs' term' go
282
283 dereference :: G.References -> G.Term -> G.Term
284 dereference r (G.Reference p) = dereference r (r M.! p)
285 dereference r (G.Lambda k t) = G.Lambda k (dereference r t)
286 dereference r (G.Apply a b) = G.Apply (dereference r a) (dereference r b)
287 dereference r (G.Trace k a b) = G.Trace k (dereference r a) (dereference r b)
288 dereference _ t = t
289
290 evalNatural :: G.Term -> Maybe Integer
291 evalNatural (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just 0
292 evalNatural (G.Lambda _ (G.Lambda _ (G.Apply (G.Bound 1) t))) = (1 +) `fmap` evalNatural t
293 evalNatural _ = Nothing
294
295 evalList :: (G.Term -> Maybe a) -> G.Term -> Maybe [a]
296 evalList _ (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just []
297 evalList f (G.Lambda _ (G.Lambda _ (G.Apply (G.Apply (G.Bound 1) s) t))) = (:) <$> f s <*> evalList f t
298 evalList _ _ = Nothing
299
300 outputter :: Chan String -> IO ()
301 outputter out = do
302   hSetBuffering stdout LineBuffering
303   forever $ do
304     s <- readChan out
305     putStrLn s