{-
    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