From 7a67a4ce8c207842d14414ed16587fe05cedafcc Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Tue, 16 Jan 2024 13:16:52 -0500
Subject: Support type variables in typechecker

---
 fig-bless/main/Main.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 67 insertions(+), 9 deletions(-)

(limited to 'fig-bless/main/Main.hs')

diff --git a/fig-bless/main/Main.hs b/fig-bless/main/Main.hs
index c3807c7..ea9531d 100644
--- a/fig-bless/main/Main.hs
+++ b/fig-bless/main/Main.hs
@@ -9,6 +9,10 @@ import Options.Applicative
 import Control.Exception.Safe (Handler(..), catches)
 
 import Data.Text.IO (putStrLn)
+import qualified Data.Text.IO as T.IO
+import qualified Data.ByteString.Lazy as B.L
+
+import qualified Data.Aeson as Aeson
 
 import Fig.Bless
 import qualified Fig.Bless.Syntax as Syn
@@ -18,29 +22,62 @@ data EvalOptions = EvalOptions
   , fuel :: Maybe Integer
   }
 
-newtype Command
-  = Eval EvalOptions
-
-newtype Options = Options
-  { cmd :: Command
-  }
-
 parseEvalOptions :: Parser EvalOptions
 parseEvalOptions = do
   fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run")
   src <- unwords <$> some (argument str (metavar "TERM..."))
   pure EvalOptions{..}
 
+newtype TypeOptions = TypeOptions
+  { src :: Text
+  }
+
+parseTypeOptions :: Parser TypeOptions
+parseTypeOptions = do
+  src <- unwords <$> some (argument str (metavar "TERM..."))
+  pure TypeOptions{..}
+
+data DictionaryOptions = DictionaryOptions
+  { path :: FilePath
+  , entrypoint :: Word
+  , fuel :: Maybe Integer
+  }
+
+parseDictionaryOptions :: Parser DictionaryOptions
+parseDictionaryOptions = do
+  fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run")
+  entrypoint <- fmap (fromMaybe "main") . optional $ strOption (long "entrypoint" <> short 'e' <> metavar "WORD" <> help "Word to evaluate")
+  path <- argument str (metavar "PATH")
+  pure DictionaryOptions{..}
+
+data Command
+  = Eval EvalOptions
+  | Type TypeOptions
+  | Dict DictionaryOptions
+
 parseCommand :: Parser Command
 parseCommand = subparser $ mconcat
   [ command "eval" $ info (Eval <$> parseEvalOptions) (progDesc "Evaluate a Bless program")
+  , command "type" $ info (Type <$> parseTypeOptions) (progDesc "Check the type of a Bless program")
+  , command "dictionary" $ info (Dict <$> parseDictionaryOptions) (progDesc "Load and run a Bless dictionary")
   ]
 
+data Options = Options
+  { cmd :: Command
+  , json :: Bool
+  }
+
 parseOptions :: Parser Options
 parseOptions = do
+  json <- flag False True (long "json" <> short 'j' <> help "Write output as JSON")
   cmd <- parseCommand
   pure Options{..}
 
+writeError :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m ()
+writeError o e
+  | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict $ Aeson.encode e
+  | otherwise = liftIO . hPutStrLn stderr $ pretty e
+
 main :: IO ()
 main = do
   opts <- execParser $ info (parseOptions <**> helper)
@@ -52,8 +89,28 @@ main = do
         Eval eo -> do
           prog <- parse "<input>" (programF spanning <* eof) eo.src
           let ?term = Nothing
-          let vm = initialize eo.fuel (Dictionary mempty) arithmetic
-          vm' <- runProgram (pure . unSpanning) prog vm
+          let ext = pure . unSpanning
+          _ty <- typeOfProgram (initializeEnv ext builtins) prog
+          let vm = initialize eo.fuel (Dictionary mempty) builtins
+          vm' <- runProgram ext prog vm
+          let
+            stack :: [ValueF Spanning (Fix (ValueF Spanning))]
+            stack = vm'.stack
+          forM_ stack $ putStrLn . pretty
+        Type to -> do
+          prog <- parse "<input>" (programF spanning <* eof) to.src
+          let ?term = Nothing
+          let ext = pure . unSpanning
+          ty <- typeOfProgram (initializeEnv ext builtins) prog
+          putStrLn $ pretty ty
+        Dict o -> do
+          src <- T.IO.readFile o.path
+          dict <- parse "<input>" (dictionaryF spanning <* eof) src
+          let ?term = Nothing
+          let ext = pure . unSpanning
+          _env <- checkDictionary (initializeEnv ext builtins) dict
+          let vm = initialize o.fuel dict builtins
+          vm' <- runWord ext o.entrypoint vm
           let
             stack :: [ValueF Spanning (Fix (ValueF Spanning))]
             stack = vm'.stack
@@ -61,4 +118,5 @@ main = do
     )
     [ Handler \(e :: Syn.ParseError) -> hPutStrLn stderr $ pretty e
     , Handler \(e :: RuntimeError Spanning) -> hPutStrLn stderr $ pretty e
+    , Handler \(e :: TypeError Spanning) -> hPutStrLn stderr $ pretty e
     ]
-- 
cgit v1.2.3