Main.hs

-- {-# LANGUAGE DeriveDataTypeable #-}
-- {-# LANGUAGE DeriveGeneric #-}
-- {-# LANGUAGE TemplateHaskell #-}
-- {-# LANGUAGE ViewPatterns #-}

module Main where

-- import Control.Applicative
-- import Control.Monad
-- import Control.Monad.Error.Lens
-- import Control.Monad.Trans.Either
-- import Control.Monad.Trans.RWS
import Data.Binary.Get
-- import Data.Bits
import qualified Data.ByteString.Lazy as BSL
-- import Data.Foldable (toList)
-- import Data.List
-- import Data.List.NonEmpty (NonEmpty(..))
-- import qualified Data.List.NonEmpty as NE
-- import qualified Data.Map as M
-- import Data.Maybe
-- import qualified Data.Sequence as Seq
-- import qualified Data.Set as S
-- import Data.Unique
import Network.Socket
import System.Environment
-- import System.Exit
-- import System.IO
-- import Text.PrettyPrint.GenericPretty

import Masque.AST
import Masque.Ejectors
import Masque.Equality
import Masque.Eval
import Masque.Monte
import Masque.Objects.Safe

-- -- | Lenses on other data types
-- -- These are destined for various upstreams at some point.
-- 
-- final :: Lens' (NonEmpty a) a
-- final = lens g s
--     where
--     g (a :| []) = a
--     g (_ :| as) = last as
--     s (a :| []) b = a :| [b]
--     s (a :| as) b = a :| init as ++ [b]
-- 
-- -- | Debugging
-- 
-- debug :: Out a => a -> Monte ()
-- debug = liftIO . pp
-- 
-- showEnv :: String -> Monte ()
-- showEnv s = do
--     envs <- use $ envStack . each . unEnv . to M.keys
--     debug (s, "Current environment names:", envs)
-- 
-- -- | Object message passing
-- 
-- cmp :: Ord a => a -> a -> Obj
-- cmp l r = IntObj c
--     where c = subtract 1 . fromIntegral . fromEnum $ compare l r
-- 
-- builtins :: [String]
-- builtins =
--     [ "__booleanFlow"
--     , "__equalizer"
--     , "__loop"
--     , "boolean"
--     , "connectTo"
--     , "stdout"
--     , "traceln"
--     ]
-- 
-- call (RefObj ref) verb args = do
--     target <- liftIO $ readIORef ref
--     maybe (left Unsettled) (\o -> call o verb args) target
-- 
-- call (ResObj ref) "resolve" [obj] = do
--     target <- liftIO $ readIORef ref
--     when (isJust target) $ left Unknown
--     liftIO . writeIORef ref $ Just obj
--     return NullObj
-- 
-- call f@(FountObj _ ref) "flowTo" [drain] = do
--     -- XXX what to do if the fount already has a drain?
--     liftIO $ writeIORef ref drain
--     case drain of
--         NullObj -> return NullObj
--         _       -> call drain "flowingFrom" [f]
-- 
-- call d@(DrainObj _) "flowingFrom" [_] = return d
-- call (DrainObj h) "receive" [StrObj s] = do
--     -- XXX blocks?
--     liftIO $ hPutStr h s
--     return NullObj
-- 
-- call (BuiltinObj "__booleanFlow") "failureList" [IntObj 0] =
--     return . ConstListObj . Seq.singleton $ BoolObj False
-- call (BuiltinObj "__equalizer") "sameEver" [x, y] =
--     return . BoolObj $ sameEver x y
-- call (BuiltinObj "__loop") "run" [iterable, consumer] = do
--     iterator <- call iterable "_makeIterator" []
--     -- Note that `forever` does not loop endlessly in EitherT, but only until
--     -- the state of the EitherT is Left. As a result, the Left state caused by
--     -- a firing ejector will break free of `forever` and return control to the
--     -- surrounding combinator. `withEjector` will catch the ejector that was
--     -- passed into the loop, which is conveniently the intended way to cleanly
--     -- exit the loop.
--     -- Also note `void`; we deliberately discard the result here, since it is
--     -- usually merely a string notifying us that the iterator is exhausted,
--     -- and we will return null anyway. ~ C.
--     void . withEjector $ \ej -> forever $ do
--         ConstListObj objs <- call iterator "next" [ej]
--         let (key:value:_) = toList objs
--         call consumer "run" [key, value]
--     return NullObj
-- call (BuiltinObj "boolean") "coerce" [obj@(BoolObj _), _] = return obj
-- call (BuiltinObj "boolean") "coerce" [obj, ej] = fire ej obj >> return NullObj
-- call (BuiltinObj "connectTo") "run" [StrObj host, IntObj port] = do
--     -- XXX needs to happen after the turn is finished
--     -- XXX blocks
--     addrInfo <- liftIO $ getAddrInfo Nothing (Just host) Nothing
--     case addrInfo ^? _head . to addrAddress of
--         Just (SockAddrInet _ ip) -> liftIO $ do
--             s <- socket AF_INET Stream defaultProtocol
--             -- XXX blocks
--             connect s $ SockAddrInet (fromIntegral port) ip
--             h <- socketToHandle s ReadWriteMode
--             ref <- newIORef NullObj
--             return . ConstListObj . Seq.fromList $ [FountObj h ref, DrainObj h]
--         _            -> left Unknown
-- call (BuiltinObj "stdout") "print" [StrObj s] = do
--     liftIO $ putStr s
--     return NullObj
-- call (BuiltinObj "traceln") "run" args = do
--     liftIO $ print args
--     return NullObj
-- 
-- call clo@(ConstListObj _) "_makeIterator" [] = do
--     listIterator <- getName "_listIterator"
--     call listIterator "run" [clo]
-- call (ConstListObj objs) "asMap" [] = let ints = map IntObj [0..] in
--     return . ConstMapObj $ zip ints (toList objs)
-- call clo@(ConstListObj _) "diverge" [] = do
--     flexList <- getName "_flexList"
--     call flexList "run" [clo]
-- call (ConstListObj objs) "get" [IntObj i]
--     | i' < Seq.length objs = return $ Seq.index objs i'
--     where i' = fromIntegral i
-- call (ConstListObj objs) "multiply" [IntObj i] =
--     return . ConstListObj . join $ Seq.replicate i' objs
--     where i' = fromIntegral i
-- call (ConstListObj objs) "size" [] =
--     return . IntObj . fromIntegral $ Seq.length objs
-- call (ConstListObj objs) "with" [obj] = return . ConstListObj $ objs |> obj
-- 
-- call (ConstMapObj pairs) "with" [k, v] = return . ConstMapObj $ pairs ++ [(k, v)]
-- 
-- call o@(UserObj _ _ env methodMap matchers) verb args =
--     stashingScope (env :| []) $ callMethod methods
--     where
--     methods = methodMap ^. ix verb
-- 
--     callMethod ((p, n):ms) = scoped $ do
--         success <- unify (ConstListObj $ Seq.fromList args) p
--         if success then eval n else callMethod ms
--     callMethod [] = callMatcher matchers
-- 
--     -- XXX This function is kind of a mess; bracket?
--     callMatcher ((p, n):ms) = flip catchError (\_ -> callMatcher ms) $ scoped $ do
--         void $ withEjector $ \ej -> do
--             unifyEject (ConstListObj $ Seq.fromList [StrObj verb, ConstListObj $ Seq.fromList args]) ej p
--             return NullObj
--         eval n
--     callMatcher [] = left $ Refused o verb args (M.keysSet methodMap)
-- 
-- call o v as = left $ Refused o v as S.empty
-- 
-- -- | Evaluation helpers
-- 
-- stashingScope :: NonEmpty Env -> Monte a -> Monte a
-- stashingScope es action = bracketEitherT open (envStack .=) (const action)
--     where
--     open = do
--         stashed <- use envStack
--         envStack .= es
--         return stashed
-- 
-- newEjector :: Monte Obj
-- newEjector = do
--     u <- liftIO newUnique
--     return $ EjectorObj u
-- 
-- fire :: Obj -> Obj -> Monte ()
-- fire (EjectorObj u) payload = left $ Ejecting u payload
-- fire _ _ = left Unknown
-- 
-- catchEjector :: Unique -> Monte Obj -> Monte Obj
-- catchEjector u action = catchError action $ \err ->
--     case err of
--         Ejecting u' obj | u == u' -> return obj
--         _                         -> left err
-- 
-- withEjector :: (Obj -> Monte Obj) -> Monte Obj
-- withEjector action = do
--     ej@(EjectorObj u) <- newEjector
--     catchEjector u $ action ej
-- 
-- bindToObj :: Binding -> Monte Obj
-- bindToObj (DefBind o) = return o
-- bindToObj (VarBind ref _) = liftIO $ readIORef ref
-- 
-- getName :: String -> Monte Obj
-- getName name = if name `elem` builtins then return (BuiltinObj name) else do
--     userBinding <- catching _BadName (liftM Just (getBinding name)) (\_ -> return Nothing)
--     preludeBinding <- preview $ unEnv . ix name
--     let binding = userBinding <|> preludeBinding
--     case binding of
--         Just b  -> bindToObj b
--         Nothing -> left $ BadName name S.empty
-- 
-- resolve :: Obj -> Monte Obj
-- resolve (RefObj ref) = do
--     mobj <- liftIO . readIORef $ ref
--     maybe (left Unsettled) resolve mobj
-- resolve obj = return obj
-- 
-- -- | Scope creation
-- 
-- coreScope :: M.Map String Obj
-- coreScope = M.fromList
--     [ ("null", NullObj)
--     , ("false", BoolObj False)
--     , ("true", BoolObj True)
--     ]
-- 
-- finalize :: M.Map String Obj -> Env
-- finalize scope = Env $ M.map DefBind scope
-- 
-- mapToScope :: Obj -> Env
-- mapToScope (ConstMapObj pairs) =
--     Env $ M.fromList [(k, DefBind v) | (StrObj k, v) <- pairs]
-- mapToScope _ = error "mapToScope was misused"
-- 
-- -- | Script evaluation
-- 
-- loadNode :: BSL.ByteString -> IO Node
-- loadNode bs = let node = runGet getNode bs in do
--     putStrLn "Loaded and optimized AST:"
--     pp node
--     return node
-- 
-- runAST :: Env -> NonEmpty Env -> BSL.ByteString -> IO (Either Err Obj, MonteState, ())
-- runAST prelude envs bs = do
--     node <- loadNode bs
--     runMonte (eval node) prelude envs
-- 
-- runFile :: Env -> NonEmpty Env -> FilePath -> IO (Either Err Obj, MonteState, ())
-- runFile prelude envs path = do
--     bs <- BSL.readFile path
--     runAST prelude envs bs

loadFile :: FilePath -> IO Expr
loadFile path = do
    bs <- BSL.readFile path
    return $ runGet getFullFile bs

main :: IO ()
main = withSocketsDo $ do
    [fileName] <- getArgs
    expr <- loadFile fileName
    print expr
    return ()

-- main = withSocketsDo $ do
--     let coreEnv = finalize coreScope :| []
--     (preludeOrErr, _, _) <- runFile (Env M.empty) coreEnv "prelude.mast"
--     prelude <- case preludeOrErr of
--         Right p  -> return p
--         Left err -> print err >> exitWith (ExitFailure 1)
--     [fileName] <- getArgs
--     result <- runFile (mapToScope prelude) coreEnv fileName
--     print $ result ^. _1