~jojo/Carth

5cca538db17255b5554fd756768d45be1ada8a7a — JoJo 2 years ago 942c120
Remove interpreter. Won't be compatible with foreign functions

May re-add it later, but not for general usage, but just evaluation of
pure expressions when doing codegen for global, non-function variables
and in other constexpr contexts.
4 files changed, 5 insertions(+), 226 deletions(-)

M README.org
M app/Config.hs
M app/Main.hs
D src/Interp.hs
M README.org => README.org +0 -4
@@ 38,12 38,8 @@ Visit [[https://carth.jo.zone/][https://carth.jo.zone/]] for an overview of the 
  carth --help

  # Help for a specific subcommand
  carth help interpret
  carth help c

  # Interpret a file
  carth i examples/test.carth

  # Compile and run a program with default output filename
  carth c examples/test.carth
  ./out

M app/Config.hs => app/Config.hs +3 -34
@@ 2,7 2,7 @@

-- | Read all the different kinds of configurtion options for Carth. Command
--    line options, config files, environment variables, etc.
module Config (getConfig, ModeConfig(..)) where
module Config (getConfig, ModeConfig) where

import Compile
import System.Console.GetOpt


@@ 12,15 12,12 @@ import Data.List
import Data.Function
import Control.Monad

data ModeConfig
    = ModeInterp FilePath
    | ModeCompile FilePath CompileConfig
type ModeConfig = (FilePath, CompileConfig)

getConfig :: IO ModeConfig
getConfig = do
    as <- getArgs
    case as of
        a : as' | a == "i" || a == "interpret" -> interpCfg as'
        a : as' | a == "c" || a == "compile" -> compileCfg as'
        a : _ | a == "-h" || a == "--help" -> do
            putStrLn usageSubs


@@ 28,7 25,6 @@ getConfig = do
        "help" : [] -> do
            putStrLn usageSubs
            exitFailure
        "help" : a : _ | a == "i" || a == "interpret" -> usageInterp
        "help" : a : _ | a == "c" || a == "compile" -> usageCompile
        a : _ -> do
            putStrLn ("Error: `" ++ a ++ "` is not a valid subcommand\n")


@@ 44,45 40,23 @@ usageSubs = unlines
    [ "Usage: carth SUBCOMMAND ..."
    , ""
    , "Available subcommands are:"
    , "  i, interpret     Interpret a source file"
    , "  c, compile       Compile a source file"
    , ""
    , "See `carth help SUBCOMMAND` for help on a specific subcommand"
    ]

interpCfg :: [String] -> IO ModeConfig
interpCfg args = do
    let (_, extras, errs) = getOpt Permute interpOpts args
    when (not (null errs)) $ putStrLn (concat errs) *> usageInterp
    case extras of
        infile : [] -> pure (ModeInterp infile)
        _ : es -> do
            putStrLn ("Unexpected extra arguments: " ++ intercalate ", " es)
            exitFailure
        [] -> putStrLn "Missing input source file" *> usageInterp

compileCfg :: [String] -> IO ModeConfig
compileCfg args = do
    let (fs, extras, errs) = getOpt Permute compileOpts args
    when (not (null errs)) $ putStrLn (concat errs) *> usageCompile
    let cfg = foldl (&) defaultCompileConfig fs
    case extras of
        infile : [] -> pure (ModeCompile infile cfg)
        infile : [] -> pure (infile, cfg)
        _ : es -> do
            putStrLn ("Unexpected extra arguments: " ++ intercalate ", " es)
            exitFailure
        [] -> putStrLn "Missing input source file" *> usageCompile

usageInterp :: IO a
usageInterp = do
    putStrLn $ unlines
        [ "Carth interpreter"
        , "Run a Carth program by interpreting a source file"
        , ""
        , usageInfo "Usage: carth i [OPTIONS] SOURCE-FILE" interpOpts
        ]
    exitFailure

usageCompile :: IO a
usageCompile = do
    putStrLn $ unlines


@@ 93,11 67,6 @@ usageCompile = do
        ]
    exitFailure

-- getOpt :: ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])

interpOpts :: [OptDescr ()]
interpOpts = []

compileOpts :: [OptDescr (CompileConfig -> CompileConfig)]
compileOpts =
    [ Option

M app/Main.hs => app/Main.hs +2 -14
@@ 14,21 14,13 @@ import qualified AnnotAst
import qualified MonoAst
import Check
import Config
import Interp
import Compile
import Mono
import qualified Parse
import Parse (Source)

main :: IO ()
main = do
    getConfig >>= \case
        ModeInterp infile -> interpretFile infile
        ModeCompile infile cfg -> compileFile infile cfg

interpretFile :: FilePath -> IO ()
interpretFile f = readFile f >>= \src ->
    parse' f src >>= typecheck' f src >>= monomorphize' >>= interpret'
main = uncurry compileFile =<< getConfig

compileFile :: FilePath -> CompileConfig -> IO ()
compileFile f cfg = do


@@ 63,12 55,8 @@ monomorphize' p = do
    writeFile "out.mono" (show p')
    pure p'

interpret' :: MonoAst.Program -> IO ()
interpret' pgm = do
    interpret pgm

abort :: FilePath -> IO a
abort f = do
    putStrLn "Error: Aborting due to previous error."
    putStrLn $ "Error: Could not compile/interpret " ++ f ++ "."
    putStrLn $ "Error: Could not compile " ++ f ++ "."
    exitFailure

D src/Interp.hs => src/Interp.hs +0 -174
@@ 1,174 0,0 @@
{-# LANGUAGE LambdaCase #-}

module Interp (interpret) where

import Control.Applicative (liftA3)
import Control.Monad.Reader
import Data.Functor
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import Data.Maybe
import Data.Word

import Misc
import MonoAst
import Selections

data Val
    = VConst Const
    | VFun (Val -> IO Val)
    | VConstruction VariantIx
                    [Val] -- ^ Arguments are in reverse order -- last arg first

type Env = Map TypedVar Val

type Eval = ReaderT Env IO


instance Show Val where
    show = \case
        VConst c -> "VConst " ++ show c ++ ""
        VFun _ -> "VFun"
        VConstruction c xs -> "VConstruction " ++ show c ++ " " ++ show xs

interpret :: Program -> IO ()
interpret p = runEval (evalProgram p)

runEval :: Eval a -> IO a
runEval m = runReaderT m builtinValues

builtinValues :: Map TypedVar Val
builtinValues = Map.fromList
    [ ( TypedVar "print-int" (TFun (TPrim TInt) (TPrim TUnit))
      , VFun (\v -> print (unwrapInt v) $> VConst Unit)
      )
    , ( TypedVar "+" (TFun (TPrim TInt) (TFun (TPrim TInt) (TPrim TInt)))
      , VFun (\a -> pure (VFun (\b -> pure (plus a b))))
      )
    ]

plus :: Val -> Val -> Val
plus a b = VConst (Int (unwrapInt a + unwrapInt b))

evalProgram :: Program -> Eval ()
evalProgram (Program main defs _) = do
    f <- evalLet defs main
    fmap unwrapUnit (unwrapFun' f (VConst Unit))

evalDefs :: Defs -> Eval (Map TypedVar Val)
evalDefs (Defs defs) = do
    let (defNames, defBodies) = unzip (Map.toList defs)
    mfix $ \(~defs') -> do
        defVals <- withLocals defs' (mapM eval defBodies)
        pure (Map.fromList (zip defNames defVals))

eval :: Expr -> Eval Val
eval = \case
    Lit c -> pure (VConst c)
    Var (TypedVar x t) -> lookupEnv (x, t)
    App ef ea -> evalApp ef ea
    If p c a -> liftA3 (if' . unwrapBool) (eval p) (eval c) (eval a)
    Fun p (b, _) -> do
        env <- ask
        pure (VFun (\v -> runEval (withLocals env (withLocal p v (eval b)))))
    Let defs body -> evalLet defs body
    Match e dt _ -> do
        v <- eval e
        evalDecisionTree dt (newSelections v)
    Ction (i, _, as) -> fmap (VConstruction i) (mapM eval as)

evalApp :: Expr -> Expr -> Eval Val
evalApp ef ea = eval ef >>= \case
    VFun f -> eval ea >>= lift . f
    v -> ice ("Application of non-function: " ++ showVariant v)

evalLet :: Defs -> Expr -> Eval Val
evalLet defs body = do
    defs' <- evalDefs defs
    withLocals defs' (eval body)

evalDecisionTree :: DecisionTree -> Selections Val -> Eval Val
evalDecisionTree = \case
    DSwitch selector cs def -> evalDecisionSwitch selector cs def
    DLeaf l -> evalDecisionLeaf l

evalDecisionSwitch
    :: Access
    -> Map VariantIx DecisionTree
    -> DecisionTree
    -> Selections Val
    -> Eval Val
evalDecisionSwitch selector cs def selections = do
    (m, selections') <- evalSelect selector selections
    case m of
        VConstruction ctor _ ->
            evalDecisionTree (fromMaybe def (Map.lookup ctor cs)) selections'
        _ -> ice "not VConstruction in evalDecisionSwitch"

evalDecisionLeaf :: (VarBindings, Expr) -> Selections Val -> Eval Val
evalDecisionLeaf (bs, e) selections = flip withLocals (eval e)
    =<< fmap Map.fromList (evalSelectVarBindings selections bs)

evalSelect :: Access -> Selections Val -> Eval (Val, Selections Val)
evalSelect = select evalAs evalSub

evalSelectVarBindings :: Selections Val -> VarBindings -> Eval [(TypedVar, Val)]
evalSelectVarBindings = selectVarBindings evalAs evalSub

evalAs :: [MonoAst.Type] -> Val -> Eval Val
evalAs _ = pure

evalSub :: Word32 -> Val -> Eval Val
evalSub i = \case
    v@(VConstruction _ xs) ->
        let
            i' = fromIntegral i
            msg = "i >= length xs in evalSub: " ++ (show i ++ ", " ++ show v)
        in pure (if i' < length xs then xs !! i' else ice msg)
    _ -> ice "evalSub of non VConstruction"

lookupEnv :: (String, Type) -> Eval Val
lookupEnv (x, t) = fmap
    (fromMaybe (ice ("Unbound variable: " ++ x ++ " of type " ++ show t)))
    (asks (Map.lookup (TypedVar x t)))

withLocals :: Map TypedVar Val -> Eval a -> Eval a
withLocals defs = local (Map.union defs)

withLocal :: TypedVar -> Val -> Eval a -> Eval a
withLocal var val = local (Map.insert var val)

unwrapFun' :: Val -> (Val -> Eval Val)
unwrapFun' v = \x -> lift (unwrapFun v x)

unwrapUnit :: Val -> ()
unwrapUnit = \case
    VConst Unit -> ()
    x -> ice ("Unwrapping unit, found " ++ showVariant x)

unwrapInt :: Val -> Int
unwrapInt = \case
    VConst (Int n) -> n
    x -> ice ("Unwrapping int, found " ++ showVariant x)

unwrapBool :: Val -> Bool
unwrapBool = \case
    VConst (Bool b) -> b
    x -> ice ("Unwrapping bool, found " ++ showVariant x)

unwrapFun :: Val -> (Val -> IO Val)
unwrapFun = \case
    VFun f -> f
    x -> ice ("Unwrapping function, found " ++ showVariant x)

showVariant :: Val -> String
showVariant = \case
    VConst c -> case c of
        Unit -> "unit"
        Int _ -> "int"
        Double _ -> "double"
        Str _ -> "string"
        Bool _ -> "bool"
        Char _ -> "character"
    VFun _ -> "function"
    VConstruction c _ -> "construction of variant " ++ show c