{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Char
import Data.List
import Control.Monad
import Control.Monad.Loops
import Control.Monad.State
import System.Console.GetOpt
import System.Console.Haskeline
import System.Environment
import System.Exit
import System.IO

import Glam.Run

instance MonadState s m => MonadState s (InputT m) where
    get :: InputT m s
get = m s -> InputT m s
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
    put :: s -> InputT m ()
put = m () -> InputT m ()
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> InputT m ()) -> (s -> m ()) -> s -> InputT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

err :: String -> m ()
err = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr

usage :: a
usage = a
"usage: glam [options...] files..."

options :: [OptDescr ()]
options = [String -> [String] -> ArgDescr () -> String -> OptDescr ()
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'i'] [String
"interactive"] (() -> ArgDescr ()
forall a. a -> ArgDescr a
NoArg ()) String
"run in interactive mode (default if no files are provided)"]

parseArgs :: IO (Bool, [String])
parseArgs = do
    [String]
args <- IO [String]
getArgs
    (Bool
i, [String]
fs) <- case ArgOrder ()
-> [OptDescr ()] -> [String] -> ([()], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder ()
forall a. ArgOrder a
Permute [OptDescr ()]
options [String]
args of
        ([()]
o, [String]
fs, [])  -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not ([()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()]
o), [String]
fs)
        ([()]
_, [String]
_, [String]
errs) -> String -> IO (Bool, [String])
forall a. String -> IO a
die (String -> IO (Bool, [String])) -> String -> IO (Bool, [String])
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [OptDescr ()] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
forall {a}. IsString a => a
usage [OptDescr ()]
options
    let interactive :: Bool
interactive = Bool
i Bool -> Bool -> Bool
|| [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fs
    (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
interactive, [String]
fs)

comp :: CompletionFunc m
comp = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord Maybe Char
forall a. Maybe a
Nothing String
" \t" \String
p -> do
    [String]
defined <- m [String]
forall (m :: * -> *). MonadGlam m => m [String]
getWords
    let words :: [String]
words = [String]
defined [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"fst", String
"snd", String
"abort", String
"left", String
"right", String
"fold", String
"unfold", String
"box", String
"unbox", String
"next", String
"prev"]
    [Completion] -> m [Completion]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Completion
simpleCompletion String
w | String
w <- [String]
words, String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
w]

settings :: Settings m
settings = Settings { complete :: CompletionFunc m
complete = CompletionFunc m
forall {m :: * -> *}. MonadState GlamState m => CompletionFunc m
comp
                    , historyFile :: Maybe String
historyFile = String -> Maybe String
forall a. a -> Maybe a
Just String
".glam_history"
                    , autoAddHistory :: Bool
autoAddHistory = Bool
True }

prompt :: a
prompt = a
"> "

IO ()
forall {m :: * -> *}. (MonadIO m, MonadMask m) => m ()
main = StateT GlamState m () -> m ()
forall (m :: * -> *) a. Monad m => StateT GlamState m a -> m a
runGlamT do
    (Bool
interactive, [String]
fs) <- IO (Bool, [String]) -> StateT GlamState m (Bool, [String])
forall a. IO a -> StateT GlamState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Bool, [String])
parseArgs
    IO () -> StateT GlamState m ()
forall a. IO a -> StateT GlamState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT GlamState m ()) -> IO () -> StateT GlamState m ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
    [String]
-> (String -> StateT GlamState m ()) -> StateT GlamState m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
fs \String
f -> do
        let (String
name, IO String
contents) | String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"  = (String
"", IO String
getContents)
                             | Bool
otherwise = (String
f, String -> IO String
readFile String
f)
        String
contents <- IO String -> StateT GlamState m String
forall a. IO a -> StateT GlamState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
contents
        IO () -> StateT GlamState m ()
forall a. IO a -> StateT GlamState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT GlamState m ())
-> (Either String [String] -> IO ())
-> Either String [String]
-> StateT GlamState m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ())
-> ([String] -> IO ()) -> Either String [String] -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ()
forall a. String -> IO a
die ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn) (Either String [String] -> StateT GlamState m ())
-> StateT GlamState m (Either String [String])
-> StateT GlamState m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> StateT GlamState m (Either String [String])
forall (m :: * -> *).
MonadGlam m =>
String -> String -> m (Either String [String])
runFile String
name String
contents
    Bool -> StateT GlamState m () -> StateT GlamState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive do
        Settings (StateT GlamState m)
-> InputT (StateT GlamState m) () -> StateT GlamState m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings (StateT GlamState m)
forall {m :: * -> *}. MonadState GlamState m => Settings m
settings InputT (StateT GlamState m) ()
forall {m :: * -> *}.
(MonadMask m, MonadIO m, MonadState GlamState m) =>
InputT m ()
repl

commands :: [(a, String -> m ())]
commands =
    [ a
"type" a -> (String -> m ()) -> (a, String -> m ())
forall {a} {b}. a -> b -> (a, b)
==> \String
s -> do
        Either String Polytype
ty <- String -> m (Either String Polytype)
forall (m :: * -> *).
MonadGlam m =>
String -> m (Either String Polytype)
getType String
s
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO case Either String Polytype
ty of
            Right Polytype
ty -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Polytype -> String
forall a. Show a => a -> String
show Polytype
ty
            Left String
e -> String -> IO ()
forall {m :: * -> *}. MonadIO m => String -> m ()
err String
e
    , a
"quit" a -> (String -> m ()) -> (a, String -> m ())
forall {a} {b}. a -> b -> (a, b)
==> \String
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitSuccess
    ] where ==> :: a -> b -> (a, b)
(==>) = (,)

repl :: InputT m ()
repl = InputT m () -> InputT m () -> InputT m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
handleInterrupt InputT m ()
repl (InputT m () -> InputT m ()) -> InputT m () -> InputT m ()
forall a b. (a -> b) -> a -> b
$ InputT m () -> InputT m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
withInterrupt (InputT m () -> InputT m ()) -> InputT m () -> InputT m ()
forall a b. (a -> b) -> a -> b
$
    InputT m (Maybe String) -> (String -> InputT m ()) -> InputT m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whileJust_ (String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
forall {a}. IsString a => a
prompt) \((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace -> String
line) -> case String
line of
        Char
':':((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace -> (String
cmd, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace -> String
args)) ->
            case [(String, String -> InputT m ())
c | c :: (String, String -> InputT m ())
c@(String
name, String -> InputT m ()
_) <- [(String, String -> InputT m ())]
forall {a} {m :: * -> *}.
(IsString a, MonadState GlamState m, MonadIO m) =>
[(a, String -> m ())]
commands, String
cmd String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
name] of
                [(String
_, String -> InputT m ()
action)] -> String -> InputT m ()
action String
args
                [] -> String -> InputT m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
err (String -> InputT m ()) -> String -> InputT m ()
forall a b. (a -> b) -> a -> b
$ String
"unknown command :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd
                [(String, String -> InputT m ())]
cs -> String -> InputT m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
err (String -> InputT m ()) -> String -> InputT m ()
forall a b. (a -> b) -> a -> b
$ String
"ambiguous command :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" could refer to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " (((String, String -> InputT m ()) -> String)
-> [(String, String -> InputT m ())] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String -> InputT m ()) -> String
forall a b. (a, b) -> a
fst [(String, String -> InputT m ())]
cs)
        String
_ -> IO () -> InputT m ()
forall a. IO a -> InputT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT m ())
-> (Either String [String] -> IO ())
-> Either String [String]
-> InputT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ())
-> ([String] -> IO ()) -> Either String [String] -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ()
forall {m :: * -> *}. MonadIO m => String -> m ()
err ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn) (Either String [String] -> InputT m ())
-> InputT m (Either String [String]) -> InputT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> InputT m (Either String [String])
forall (m :: * -> *).
MonadGlam m =>
String -> String -> m (Either String [String])
runFile String
"" String
line