Main.hs

-- bruc, The BruSKI Compiler
-- Maintainer:      Nicklas Botö
-- Contact:         bruski@nicklasbotö.se
-- Latest Revision: 17 October 2020

{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

---- src Import
import Lib
import Paths_BruSKI (version)

---- Unlambda Language Import
import Unlambda.AST (Eλ)
import Unlambda.Run (run)

---- Language Import
import AST
import Parser
import Config
import Encoding
import Generator
import Translator
import qualified Sexy
import MacroHandler

---- Parsing and CLI Import
import Turtle
import System.IO
import System.Directory

---- REPL Import
import Control.Monad
import Data.Functor (($>))
import Control.Monad.State
import System.Console.Repline
import System.Console.Haskeline.MonadException

---- Format Import
import Data.List
import Data.Char

---- Misc Import
import Data.Version (showVersion)


-- save version as string
ver :: String
ver = showVersion version

-- main parser
mainSubroutine :: IO ()
mainSubroutine = Sexy.welcome

parseMain :: Parser (IO ())
parseMain = pure mainSubroutine

-- compile parser
getOutputPath :: Parser (Turtle.FilePath, Maybe Turtle.FilePath)
getOutputPath = (,) <$> argPath "source" "Input file of compiler"
                    <*> optional (optPath "target" 'o' "Output file of compiler")

compileToFile :: Turtle.FilePath -> Maybe Turtle.FilePath -> IO ()
compileToFile source Nothing = writeToFile (encodeString source) (generateFileName ".")
compileToFile source (Just target)
  | filename target == emptyPath = writeToFile fSource (generateFileName fTarget)
  | otherwise                    = writeToFile fSource                   fTarget
    where fSource   = encodeString source
          fTarget   = encodeString target
          emptyPath = decodeString ""

compString :: String
compString = "### GENERATED BY THE BRUSKI COMPILER ###\n"

writeToFile :: System.IO.FilePath -> System.IO.FilePath -> IO ()
writeToFile source target = do
        file <- openFile target WriteMode 
        compiled <- fmap fst . genFile $ source
        hPutStrLn file (compString ++ compiled)
        hClose file

-- generateFileName :: System.IO.FilePath -> String
generateFileName folder = "out.unl"

compileParser :: Parser (IO ())
compileParser = fmap (uncurry compileToFile) (subcommand "compile" "Compile BruSKI source code to Unlambda file" getOutputPath)

-- run parser
getInputPath :: Parser Turtle.FilePath
getInputPath = argPath "source" "Input file of compiler"

runFromFile :: Turtle.FilePath -> IO ()
runFromFile source = print =<< Generator.runFile (encodeString source)

runParser :: Parser (IO ())
runParser = fmap runFromFile (subcommand "run" "Run BruSKI source code without saving it to a file" getInputPath)

-- gen parser
genFromFile :: Turtle.FilePath -> IO ()
genFromFile source = do
        (unl, table) <- Generator.genFile (encodeString source)
        putStrLn "--- symbol table at compile time"
        print $ reverse table
        putStrLn "\n--- compiler output"
        print unl

genParser :: Parser (IO ())
genParser = fmap genFromFile (subcommand "gen" "Generate symbol table and compiler output to terminal" getInputPath)

-- version parser
version' :: IO()
version' = putStrLn ver

verboseVersion :: IO()
verboseVersion = do
                 version'
                 echo "This compiler is currently in development! Please notify me at [bruski@nicklasbotö.se], or open an issue at [bruski.nicklasbotö.se] if you want a certain feature."

parseVersion :: Parser (IO ())
parseVersion = subcommand "version" "Show compiler version" (pure verboseVersion)

-- Bruce Wayne parser
bat = [ "       _,    _   _    ,_       "
      , "  .o888P     Y8o8Y     Y888o.  "
      , " d88888      88888      88888b "
      , "d888888b_  _d88888b_  _d888888b"
      , "8888888888888888888888888888888"
      , "8888888888888888888888888888888"
      , "YJGS8PYY888PYY888PYY888PYY8888P"
      , " Y888   '8'   Y8P   '8'   888Y "
      , "  '8o          V          o8'  "]
      

wayne :: IO ()
wayne = putStrLn $ intercalate "\n" bat

parseWayne :: Parser (IO ())
parseWayne = subcommand "wayne" "Nanananananananananan" (pure wayne)

-- Bruce Lee parser
lee :: IO ()
lee = echo "Lee Jun-fan (Chinese: 李振藩; November 27, 1940 – July 20, 1973), known professionally as Bruce Lee (Chinese: 李小龍), was a Hong Kong American[3] martial artist, martial arts instructor, actor, director, and philosopher.[4] He was the founder of Jeet Kune Do, a hybrid martial arts philosophy drawing from different combat disciplines that is often credited with paving the way for modern mixed martial arts (MMA). Lee is considered by commentators, critics, media, and other martial artists to be the most influential martial artist of all time and a pop culture icon of the 20th century, who bridged the gap between East and West. He is credited with helping to change the way Asians were presented in American films.[5] "

parseLee :: Parser (IO ())
parseLee = subcommand "lee" "Facts about Bruce Lee" (pure lee)

--------------------------------------------------------------
-- REPL PARSER AND RUNNER
--------------------------------------------------------------

-- eval :: String -> InputT IO ()
-- eval input = outputStr $ case parseString input of
--                [Assign v e a] -> show e ++ "\n"
--                [Express    b] -> ""
--                [Import     f] -> "--- import successful\n"
--                []             -> ""
--                _              -> "--- too many lines\n"
-- 
-- repl :: IO ()
-- repl = runInputT defaultSettings (loop [])
--    where 
--        loop :: [String] -> InputT IO ()
--        loop env = do
--            minput <- getInputLine "λ> "
--            case minput of
--                Nothing            ->  return ()
--                Just ":quit"       ->  return ()
--                Just ":help"       ->  outputStrLn helpList *> loop env
--                Just ":import"     ->  outputStrLn "--- import successful" *> loop env
-- --               Just m@('{':'+':s) -> (outputStrLn . show . parseMacro $ m)*> loop env
--                Just (':':s)       ->  outputStrLn ("--- unkown command: " ++ s) *> loop env
--                Just input         ->  catch (eval input)
--                                       (\e -> outputStrLn (show (e :: SomeException))) 
--                                       *> loop []

-- Main type synonyms for the REPL
-- RState is bound to change when macros are added
type RState = Sequence
type Repl a = HaskelineT (StateT RState IO) a

-- Needed to run in Haskeline monad
instance MonadException (StateT RState IO) where
    controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let
                    run' = RunIO (fmap (StateT . const) . run . flip runStateT s)
                    in (`runStateT` s) <$> f run'

-- like putStrLn, but lifted for transformer use
-- because I used the so often
printr :: MonadIO m => String -> m ()
printr = liftIO . putStrLn

-- Funny name, yes...
-- Removes a assignment statement of a given name
-- from the current environment.
removeAss :: String -> Sequence -> Sequence
removeAss _ [] = []
removeAss n (Assign s e a : ss)
  | s == n    =                removeAss n ss
  | otherwise = Assign s e a : removeAss n ss
removeAss n (e : ss) = e     : removeAss n ss

-- Returns a assignment statement of a given name
-- from the current environment.
getAss :: String -> Sequence -> Maybe Stmt
getAss n [] = Nothing
getAss n (Assign s e a : ss)
  | s == n    = Just $ Assign s e a
  | otherwise = getAss n ss
getAss n (e : ss) = getAss n ss

-- Same as getAss but extracts the expression
getBλ :: String -> Sequence -> Maybe Bλ
getBλ n ss = case getAss n ss of
                Just (Assign _ e _) -> Just e
                _                    -> Nothing

-- Appends values to the state table
appendTable s@[Assign n _ _] = state $ \ss -> ((), removeAss n ss ++ s)
appendTable s = state $ \ss -> ((), ss ++ s) 

-- Calls the code generator and outputs the results
-- after running them through the Unlambda interpreter
runWithCurrent :: Sequence -> StateT RState IO ()
runWithCurrent exp = do
        curr <- get
        prog <- liftIO $ evalStateT (generateTable (curr ++ exp)) []
        var  <- liftIO $ run prog 
        printr . show $ var

genWithCurrent :: Sequence -> StateT RState IO ()
genWithCurrent exp = do
        curr <- get
        prog <- liftIO $ evalStateT (generateTable (curr ++ exp)) []
        printr . show $ prog

tableFromFile :: String -> StateT RState IO ()
tableFromFile f = do
        handle   <- liftIO $ openFile (preludePath ++ f ++ ".bru") ReadMode
        contents <- liftIO $ hGetContents handle
        printr contents

addToTable :: Sequence -> Repl ()
addToTable (Import     f : rs) = do
        lib <- liftIO $ parseFile (Config.preludePath ++ f ++ ".bru")
        addToTable lib *> addToTable rs
addToTable (Assign n λ a : rs) = do
        curr <- get
        let reduced = expandExpression λ (toST curr)
        appendTable [Assign n reduced a] *> addToTable rs
                where toST (Assign n λ a : ss) = (n, (λ,fromInteger a)) : toST ss
                      toST (           _ : ss) = toST ss
                      toST                 []  = []
addToTable [] = return ()

-- Evaluates the given REPL inputs
-- Parses and appends statements in the case of assignments.
-- Parses and passes the current environment to the code generator,
-- in the case of expressions.
-- Also handles imports, which might not be needed here later...
eval :: String -> Repl ()
eval input = case parseString input of
               -- FIXME only allow multiple assignment 
               as@(Assign {} : ass) -> addToTable as
               ex@[Express _] -> lift (runWithCurrent ex)
               im@[Import  f] -> addToTable im
               []             -> return ()
               _              -> printr "--- the parser is confused\n(??)"

mapλ :: Stmt -> (Bλ -> Bλ) -> Stmt
mapλ (Assign n λ a) f = Assign n (f λ) a
mapλ             x  _ = x

-- The first and last things 
-- that are presented to the user
-- when you start/end the REPL
ini, fin :: Repl ()
ini = liftIO Sexy.welcome
fin = printr "Leaving bruci."


-- These are all the commands that are available in the REPL

-- Here are the help text for the commands
-- if you wish to add a command yourself, please add a help text for it here
helpCmd [] = printr $ "Available commands:\n" ++ intercalate "\n" [fst x | x <- ops] ++ "\n\nFor info on a specific command, type :help COMMAND (or :? COMMAND)"
helpCmd ["help"  ] = printr "Usage: help [COMMAND]\nshow available commands, or info about certain commands"
helpCmd ["?"     ] = printr "Usage: ? [COMMAND]\nshow available commands, or info about certain commands"
helpCmd ["quit"  ] = printr "Usage: quit\nquits the repl"
helpCmd ["import"] = printr "Usage: import FILENAME\nshorthand for '{! import FILENAME !}'"
helpCmd ["format"] = printr "Usage: format VARNAME\nshorthand for '{! format VARNAME !}'"
helpCmd ["env"   ] = printr "Usage: env [ENV]\nshows the current environment, or sets the current environment\n\tENV ::= church | num | bool"
helpCmd ["clear" ] = printr "Usage: clear\nclear the current environment"
helpCmd ["delete"] = printr "Usage: delete VARNAME\ndeletes a statement from the environment"
helpCmd ["info"  ] = printr "Usage: info VARNAME\nshow the definition of VARNAME"
helpCmd ["int"   ] = printr "Usage: int VARNAME\nshow the value of VARNAME, as an int\nNOTE: This is WIP"
helpCmd ["chr"   ] = printr "Usage: chr VARNAME\nshow the value of VARNAME, as a char\nNOTE: This is WIP"
helpCmd ["sexy"  ] = printr "Usage: sexy\ndisplays the terminal greeting"
helpCmd ["gen"   ] = printr "Usage: gen VARNAME\ngenerate the Unlambda code of a certain function"
helpCmd ["browse"] = printr "Usage: browse FILENAME\nsee the contents of a prelude library"
helpCmd ["libs"  ] = printr "Usage: libs [FILENAME]\ninformation on a specific prelude library\npassing no arguments lists all prelude libraries"
helpCmd [x       ] = printr $ "--- no such command :" ++ x
helpCmd  _         = printr "--- invalid arguments"

-- Quits the REPL
quitCmd :: [String] -> Repl ()
quitCmd    _   = fin *> abort

-- Shorthand for the import language definition
-- It might be better to actually import all the 
-- function from the wanted library here...
-- And then append them to the state table
importCmd :: [String] -> Repl () 
importCmd [f] = eval $ "{! import " ++ f ++ "!}"
importCmd  _  = printr "--- one import at a time, please"

-- Also a shorthand for a language definition
formatCmd :: [String] -> Repl ()
formatCmd [        ] = infoCmd   ["__FORMATTER__"] 
formatCmd ["none"  ] = deleteCmd ["__FORMATTER__"]
formatCmd ["int"   ] = formatCmd ["formatNumLst" ]
formatCmd ["church"] = formatCmd ["formatChurch" ]
formatCmd ["bool"  ] = formatCmd ["formatBool"   ]
formatCmd         λ  = eval $ "{! format " ++ concat λ ++ "!}"

-- Shows the current environment
envCmd :: [String] -> Repl ()
envCmd ["church"] = importCmd ["church"] *> formatCmd ["formatChurch"]
envCmd ["num"   ] = importCmd ["std"   ] *> formatCmd ["formatNumLst"]
envCmd ["bool"  ] = importCmd ["bool"  ] *> formatCmd ["formatBool"  ]
envCmd     _      = get >>= printr . show

-- Cleares the current environment
clearCmd :: [String] -> Repl ()
clearCmd   _  = state $ const ((),[])

-- Deletes a statement from the environment
deleteCmd :: [String] -> Repl ()
deleteCmd [n] = state $ \ss -> ((), removeAss n ss)  
deleteCmd  _  = printr "--- one delete at a time, damn..."

-- Shows info about a given statement
infoCmd :: [String] -> Repl ()
infoCmd   [n] = do
        curr <- get
        case getBλ n curr of
          Just e  -> (printr . show) e
          Nothing -> printr $ "--- no function named " ++ n
infoCmd    _  = printr "--- Invalid arguments"

-- Decodes a Bλ statement into an int.
-- This is very buggy though....
-- Statements should be β-reduced before being
-- decoded like this.
intCmd :: [String] -> Repl ()
intCmd    [n] = do 
        curr <- get
        case getBλ n curr of
          Just s  -> case decode s of
                       Just i  -> (printr . show) i
                       Nothing -> printr "--- not an int"
          Nothing -> printr $ "--- no function named " ++ n
intCmd     _  = printr "--- invalid arguments"

-- Same as the int command, but for chars.
-- Also buggy, in the same way.
chrCmd :: [String] -> Repl ()
chrCmd    [n] = do
        curr <- get
        case getBλ n curr of
          Just s  -> case decode s of 
                       Just c  -> (printr . show . chr) c
                       Nothing -> printr "--- not a char"
          Nothing -> printr $ "--- no function named " ++ n
chrCmd     _  = printr "--- invalid arguments"

-- B)
-- print a nice terminal greeting
sexyCmd :: [String] -> Repl ()
sexyCmd    _  = liftIO Sexy.welcome

genCmd :: [String] -> Repl ()
genCmd [f] = lift $ genWithCurrent (parseString f)
genCmd  _  = printr "--- invalid arguments"

-- shows the function in some library
browseCmd :: [String] -> Repl ()
browseCmd [l] = lift $ tableFromFile l
browseCmd  _  = printr "--- invalid arguments"

getLibs :: StateT RState IO ()
getLibs = do
        files <- liftIO $ listDirectory Config.preludePath
        let libs = intercalate "\n" $ map (takeWhile (/='.')) files 
        printr libs

libsCmd :: [String] -> Repl ()
libsCmd [        ] = printr "Available libraries:" *> lift getLibs
libsCmd ["comb"  ] = printr "common combinators and fixed points"
libsCmd ["list"  ] = printr "functions for creating and operating on lists\nthis is needed when using all syntactic sugar related to lists"
libsCmd ["church"] = printr "defines church numerals and arithmetic operators"
libsCmd ["std"   ] = printr "standard library, contains all other libraries and more"
libsCmd ["bool"  ] = printr "defines booleans and boolean operators"
libsCmd [l       ] = printr $ "--- no such library" ++ l

-- Collects the available REPL commands
ops :: [(String, [String] -> Repl ())]
ops = [ ("help"  , helpCmd  )
      , ("?"     , helpCmd  )
      , ("quit"  , quitCmd  )
      , ("import", importCmd)
      , ("format", formatCmd)
      , ("env"   , envCmd   )
      , ("clear" , clearCmd )
      , ("delete", deleteCmd)
      , ("info"  , infoCmd  )
      , ("int"   , intCmd   )
      , ("chr"   , chrCmd   )
      , ("sexy"  , sexyCmd  )
      , ("gen"   , genCmd   )
      , ("browse", browseCmd)
      , ("libs"  , libsCmd  )
      ]

-- Stateful word completion
-- Adds all the function names in the current environment
-- to the completion list.
compl :: (Monad m, MonadState RState m) => WordCompleter m
compl n = do
  ss <- get
  return $ filter (isPrefixOf n) ([n | (Assign n _ _ ) <- ss]
        ++ map ((':':).fst) ops
        ++ ["PRT", "UNL", "INT", "CHR"])

-- Main REPL runner
-- FIXME should handle errors better.
-- SomeException is not good...
repl :: IO ()
repl = flip evalStateT [] $ 
        evalRepl (pure "λ> ") eval' ops (Just ':') (Word compl) ini
          where eval' input  = catch (eval input) (\e -> printr (show (e :: SomeException)))

-- Parses the 'repl' command
replParser :: Parser (IO ())
replParser = subcommand "repl" "Interactive BruSKI prompt" (pure repl)

---- put it all together

parser :: Parser (IO ())
parser =  parseMain 
      <|> compileParser
      <|> replParser
      <|> runParser
      <|> genParser
      <|> parseVersion
--    <|> parseWayne
--    <|> parseLee

desc :: Description
desc = fromString Sexy.brewBeerText

main :: IO ()
main = join (Turtle.options desc parser)