~jojo/Carth

ee81b9201377e00dc01a0a1c48d11474deb61c8b — JoJo 1 year, 5 months ago 5db5a48
Un-hardcode lib and mod dir paths. Configurable at compiletime now

Compile lib and mod dirs into binary using TemplateHaskell & add
Makefile with installation targets. `make install` now compiles the
whole project and installs the `carth` binary, the
`libcarth_foreign_core.a` static lib, and the `std/std.carth` standard
library to a configurable path (default ~/.carth/bin, ~/.carth/lib,
and ~/.carth/mod respectively).
8 files changed, 176 insertions(+), 26 deletions(-)

A Makefile
M app/Main.hs
M package.yaml
M src/Compile.hs
A src/CompiletimeEnv.hs
A src/CompiletimeVars.hs
M src/Parse.hs
R examples/std.carth => std/std.carth
A Makefile => Makefile +47 -0
@@ 0,0 1,47 @@
CARTH_DIR=~/.carth
BIN_DIR=$(CARTH_DIR)/bin
LIB_DIR=$(CARTH_DIR)/lib
MOD_DIR=$(CARTH_DIR)/mod

.PHONY: carth-bin
carth-bin: bin-dir clean-stack
	(export CARTH_LIB_DIR=$(LIB_DIR); export CARTH_MOD_DIR=$(MOD_DIR); stack build)

.PHONY: foreign-core
foreign-core: lib-dir
	cd foreign-core; cargo build --release

.PHONY: install
install: install-bin install-lib install-mods

.PHONY: install-bin
install-bin: carth-bin
	stack install --local-bin-path $(BIN_DIR)

.PHONY: install-lib
install-lib: foreign-core
	cp foreign-core/target/release/libcarth_foreign_core.a $(LIB_DIR)

.PHONY: install-mods
install-mods: mod-dir
	cp carth-std/* $(MOD_DIR)/

.PHONY: bin-dir
bin-dir: carth-dir
	mkdir -p $(BIN_DIR)

.PHONY: lib-dir
lib-dir: carth-dir
	mkdir -p $(LIB_DIR)

.PHONY: mod-dir
mod-dir: carth-dir
	mkdir -p $(MOD_DIR)

.PHONY: carth-dir
carth-dir:
	mkdir -p $(CARTH_DIR)

.PHONY: clean-stack
clean-stack:
	stack clean

M app/Main.hs => app/Main.hs +13 -2
@@ 14,14 14,25 @@ import Config
import Compile
import Mono
import qualified Parse
import CompiletimeVars

main :: IO ()
main = uncurry compileFile =<< getConfig

compileFile :: FilePath -> CompileConfig -> IO ()
compileFile f cfg = do
    putStrLn ("   Compiling " ++ f ++ "\n")
    parse f >>= typecheck' f >>= monomorphize' >>= compile f cfg
    putStrLn ("   Compiling " ++ f ++ "")
    putStrLn ("     Compiletime variables:")
    putStrLn ("       lib directory = " ++ libDir)
    putStrLn ("       mod directory = " ++ modDir)
    putStrLn ("   Parsing")
    ast <- parse f
    putStrLn ("   Typechecking")
    ann <- typecheck' f ast
    putStrLn ("   Monomorphizing")
    mon <- monomorphize' ann
    compile f cfg mon
    putStrLn ""

parse :: FilePath -> IO Ast.Program
parse f = Parse.parse f >>= \case

M package.yaml => package.yaml +1 -0
@@ 40,6 40,7 @@ dependencies:
- prettyprinter
- process
- scientific
- template-haskell

library:
  source-dirs: src

M src/Compile.hs => src/Compile.hs +5 -1
@@ 14,6 14,7 @@ import qualified LLVM.CodeGenOpt as CodeGenOpt
import Misc
import qualified MonoAst
import Codegen
import CompiletimeVars

-- | Configuration for LLVM compilation and CC linking
data CompileConfig = CompileConfig


@@ 31,24 32,27 @@ defaultCompileConfig = CompileConfig { cc = "cc", outfile = Nothing }
compile :: FilePath -> CompileConfig -> MonoAst.Program -> IO ()
compile f cfg pgm = withContext $ \c -> withHostTargetMachinePIC $ \t -> do
    layout <- getTargetMachineDataLayout t
    putStrLn ("   Generating LLVM")
    let mod = codegen layout f pgm
    writeFile "out.dbgll" (pretty mod)
    withModuleFromAST c mod (compileModule t cfg)

compileModule :: TargetMachine -> CompileConfig -> Module -> IO ()
compileModule t cfg m = do
    putStrLn ("   Compiling LLVM")
    let binfile = fromMaybe "out" (outfile cfg)
        llfile = replaceExtension binfile "ll"
        ofile = replaceExtension binfile "o"
    writeLLVMAssemblyToFile' llfile m
    verify m
    writeObjectToFile t (File ofile) m
    putStrLn ("   Linking")
    callProcess
        (cc cfg)
        [ "-o"
        , binfile
        , ofile
        , "/home/jojo/Hack/carth/foreign-core/target/debug/libcarth_foreign_core.a"
        , libDir </> "libcarth_foreign_core.a"
        , "-ldl"
        , "-lpthread"
        ]

A src/CompiletimeEnv.hs => src/CompiletimeEnv.hs +13 -0
@@ 0,0 1,13 @@
module CompiletimeEnv (lookupCompileEnvOr) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import System.Environment (lookupEnv)
import Data.Maybe

-- | Looks up a compile-time environment variable.
lookupCompileEnvOr :: String -> String -> Q Exp
lookupCompileEnvOr key def = (lift . fromMaybe def) =<< lookupCompileEnvOr' key

lookupCompileEnvOr' :: String -> Q (Maybe String)
lookupCompileEnvOr' key = runIO (lookupEnv key)

A src/CompiletimeVars.hs => src/CompiletimeVars.hs +11 -0
@@ 0,0 1,11 @@
{-# LANGUAGE TemplateHaskell #-}

module CompiletimeVars (libDir, modDir) where

import CompiletimeEnv

libDir :: FilePath
libDir = $(lookupCompileEnvOr "CARTH_LIB_DIR" "~/.carth/lib")

modDir :: FilePath
modDir = $(lookupCompileEnvOr "CARTH_MOD_DIR" "~/.carth/mod")

M src/Parse.hs => src/Parse.hs +30 -22
@@ 49,6 49,7 @@ import SrcPos
import Ast
import NonEmpty
import Literate
import CompiletimeVars

type Parser = Parsec Void String
type Source = String


@@ 59,9 60,7 @@ parse :: FilePath -> IO (Either String Program)
parse filepath = do
    let (dir, file) = splitFileName filepath
    let moduleName = dropExtension file
    r <- withCurrentDirectory
        dir
        (parseModule filepath dir moduleName Set.empty [])
    r <- parseModule filepath dir moduleName Set.empty []
    pure (fmap (\(ds, ts, es) -> Program ds ts es) r)

parseModule


@@ 72,26 71,15 @@ parseModule
    -> [String]
    -> IO (Either String ([Def], [TypeDef], [Extern]))
parseModule filepath dir m visiteds nexts = do
    let (carthf, orgf) = (addExtension m ".carth", addExtension m ".org")
    dotCarth <- doesFileExist carthf
    dotOrg <- doesFileExist orgf
    (src, f) <- case (dotCarth, dotOrg) of
        (True, True) -> do
            putStrLn
                $ ("Error: File of module " ++ m)
                ++ " is ambiguous. Both .org and .carth exist."
            abort filepath
        (True, False) -> fmap (, carthf) (readFile carthf)
        (False, True) -> do
            s <- readFile orgf
            let s' = untangleOrg s
            writeFile (addExtension m "untangled") s
            pure (s', orgf)
        (False, False) -> do
            putStrLn $ "Error: No file for module " ++ m ++ " exists."
            abort filepath
    (src, f) <- parseModule' dir >>= \case
        Just x -> pure x
        Nothing -> parseModule' modDir >>= \case
            Just x -> pure x
            Nothing -> do
                putStrLn ("Error: No file for module " ++ m ++ " exists.")
                abort filepath
    let visiteds' = Set.insert m visiteds
    case parse' toplevels (dir </> f) src of
    case parse' toplevels f src of
        Left e -> pure (Left e)
        Right (is, ds, ts, es) -> case is ++ nexts of
            [] -> pure (Right (ds, ts, es))


@@ 100,6 88,26 @@ parseModule filepath dir m visiteds nexts = do
                pure $ fmap
                    (\(ds', ts', es') -> (ds ++ ds', ts ++ ts', es ++ es'))
                    r
  where
    parseModule' dir' = do
        let m' = dir' </> m
            carthf = addExtension m' ".carth"
            orgf = addExtension m' ".org"
        dotCarth <- doesFileExist carthf
        dotOrg <- doesFileExist orgf
        case (dotCarth, dotOrg) of
            (True, True) -> do
                putStrLn
                    $ ("Error: File of module " ++ m)
                    ++ " is ambiguous. Both .org and .carth exist."
                abort filepath
            (True, False) -> fmap (Just . (, carthf)) (readFile carthf)
            (False, True) -> do
                s <- readFile orgf
                let s' = untangleOrg s
                writeFile (addExtension m "untangled") s
                pure (Just (s', orgf))
            (False, False) -> pure Nothing

parse' :: Parser a -> FilePath -> Source -> Either String a
parse' p name src = mapLeft errorBundlePretty (Mega.parse p name src)

R examples/std.carth => std/std.carth +56 -1
@@ 13,6 13,10 @@
  None
  (Some a))

(define unwrap!
  (fun-match (case (Some x) x)
             (case None (panic "unwrap! of None"))))

(type (Lazy a)
  (Lazy (Fun Unit a)))



@@ 81,7 85,7 @@
  (Iter (Lazy (Maybe (Pair a (Iter a))))))

(define (next (Iter it)) (lively it))
(define (next! (Iter it)) (unwrap! (lively it)))
(define (next! it) (unwrap! (next it)))

(define (range a b)
  (Iter (Lazy (if (> a b)


@@ 93,3 97,54 @@
    (case None unit)
    (case (Some (Pair x xs'))
          (seq (f x) (for xs' f)))))

;;; List

(type (List a)
  (Cons a (Box (List a)))
  Nil)

(define first
  (fun-match
    (case (Cons x _) (Some x))
    (case Nil None)))
(define first!
  (fun-match
    (case (Cons x _) x)
    (case Nil (panic "first! of empty list"))))

(define rest
  (fun-match
    (case (Cons _ (Box xs)) (Some xs))
    (case Nil None)))
(define rest!
  (fun-match
    (case (Cons _ (Box xs)) xs)
    (case Nil (panic "rest! of empty list"))))

(define last
  (fun-match
    (case (Cons x (Box Nil)) (Some x))
    (case (Cons _ (Box xs)) (last xs))
    (case Nil None)))
(define last!
  (fun-match
    (case (Cons x (Box Nil)) x)
    (case (Cons _ (Box xs)) (last! xs))
    (case Nil (panic "last! of empty list"))))

(define init
  (fun-match
    (case Nil None)
    (case xs (Some (init! xs)))))
(define init!
  (fun-match
    (case (Cons _ (Box Nil)) Nil)
    (case (Cons x (Box xs)) (Cons x (box (init! xs))))
    (case Nil (panic "init! of empty list"))))

(define: (foldl f acc xs)
    (forall (a b) (Fun (Fun b a b) b (List a) b))
  (match xs
    (case (Cons x (Box xs')) (foldl f (f acc x) xs'))
    (case Nil acc)))