~jojo/Carth

9449ab28c3742bcfbd7b371953481b9d42eef014 — JoJo 1 year, 10 months ago e3dddf9
Read env vars of lib path and module path at runtime

Before they were compiled into the `carth` binary, but to work with
Guix in the future, I feel it's better to allow the paths to be
changed arbitrarily by the user/system without recompilation.
11 files changed, 80 insertions(+), 82 deletions(-)

M Makefile
M README.org
M app/Config.hs
M app/Main.hs
M package.yaml
M src/Compile.hs
D src/CompiletimeEnv.hs
D src/CompiletimeVars.hs
A src/EnvVars.hs
M src/Misc.hs
M src/Parse.hs
M Makefile => Makefile +16 -21
@@ 1,14 1,14 @@
CARTH_DIR=~/.carth
BIN_DIR=$(CARTH_DIR)/bin
LIB_DIR=$(CARTH_DIR)/lib
MOD_DIR=$(CARTH_DIR)/mod
prefix=~/.carth
bin_dir=$(prefix)/bin
lib_dir=$(prefix)/lib
mod_dir=$(prefix)/mod

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

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

.PHONY: install


@@ 16,32 16,27 @@ install: install-bin install-lib install-mods

.PHONY: install-bin
install-bin: carth-bin bin-dir
	stack install --local-bin-path $(BIN_DIR)
	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)
install-lib: foreign-core lib-dir
	cp foreign-core/target/release/libcarth_foreign_core.a $(lib_dir)

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

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

.PHONY: lib-dir
lib-dir: carth-dir
	mkdir -p $(LIB_DIR)
lib-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)
mod-dir:
	mkdir -p $(mod_dir)

.PHONY: clean-stack
clean-stack:

M README.org => README.org +7 -2
@@ 27,13 27,18 @@ Visit [[https://carth.jo.zone/][https://carth.jo.zone/]] for an overview of the 
  - Linear types

* Building
  The compiler is writtern in [[https://haskell.org][Haskell]] and uses the [[https://www.haskellstack.org/][Stack]] build system,
  The compiler is written in [[https://haskell.org][Haskell]] and uses the [[https://www.haskellstack.org/][Stack]] build system,
  while the core-library is written in [[https://rust-lang.org][Rust]]. The external dependencies
  required are [[https://llvm.org/][LLVM]] version 9.

  To build the project and install the ~carth~ binary, the core
  library, and the standard library, simply run ~make install~, which
  defaults to installing everything in ~~/.carth/~.
  defaults to installing everything in =~/.carth/=. Then add the
  directory of the installed core library (default =~/.carth/lib=) to
  your ~LIBRARY_PATH~ environment variable, so that the compiler can
  find it for the linking step, and add the directory of the installed
  standard library (default =~/.carth/mod=) your ~CARTH_MODULE_PATH~
  environment variable, so that the parser can find all Carth modules.

* Running
  #+BEGIN_EXAMPLE bash

M app/Config.hs => app/Config.hs +3 -1
@@ 4,7 4,6 @@
--    line options, config files, environment variables, etc.
module Config (getConfig, ModeConfig) where

import Compile
import System.Console.GetOpt
import System.Environment
import System.Exit


@@ 12,6 11,9 @@ import Data.List
import Data.Function
import Control.Monad

import Compile


type ModeConfig = (FilePath, CompileConfig)

getConfig :: IO ModeConfig

M app/Main.hs => app/Main.hs +7 -4
@@ 3,6 3,7 @@
module Main (main) where

import Data.Functor
import System.Environment

import Misc
import qualified TypeErr


@@ 14,7 15,7 @@ import Config
import Compile
import Mono
import qualified Parse
import CompiletimeVars
import EnvVars

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


@@ 22,9 23,11 @@ main = uncurry compileFile =<< getConfig
compileFile :: FilePath -> CompileConfig -> IO ()
compileFile f cfg = do
    putStrLn ("   Compiling " ++ f ++ "")
    putStrLn ("     Compiletime variables:")
    putStrLn ("       lib directory = " ++ libDir)
    putStrLn ("       mod directory = " ++ modDir)
    putStrLn ("     Environment variables:")
    lp <- lookupEnv "LIBRARY_PATH"
    mp <- modulePaths
    putStrLn ("       library path = " ++ show lp)
    putStrLn ("       module paths = " ++ show mp)
    putStrLn ("   Parsing")
    ast <- parse f
    putStrLn ("   Typechecking")

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

library:
  source-dirs: src

M src/Compile.hs => src/Compile.hs +4 -5
@@ 14,7 14,6 @@ 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


@@ 33,9 32,9 @@ 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 ".dbg.out.dbgll" (pretty mod)
    withModuleFromAST c mod (compileModule t cfg)
    let mod' = codegen layout f pgm
    writeFile ".dbg.out.dbgll" (pretty mod')
    withModuleFromAST c mod' (compileModule t cfg)

compileModule :: TargetMachine -> CompileConfig -> Module -> IO ()
compileModule t cfg m = do


@@ 52,7 51,7 @@ compileModule t cfg m = do
        [ "-o"
        , binfile
        , ofile
        , libDir </> "libcarth_foreign_core.a"
        , "-l:libcarth_foreign_core.a"
        , "-ldl"
        , "-lpthread"
        ]

D src/CompiletimeEnv.hs => src/CompiletimeEnv.hs +0 -13
@@ 1,13 0,0 @@
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)

D src/CompiletimeVars.hs => src/CompiletimeVars.hs +0 -11
@@ 1,11 0,0 @@
{-# 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")

A src/EnvVars.hs => src/EnvVars.hs +9 -0
@@ 0,0 1,9 @@
module EnvVars (modulePaths) where

import System.Environment (lookupEnv)

import Misc


modulePaths :: IO [FilePath]
modulePaths = fmap (maybe [] (splitOn ":")) (lookupEnv "CARTH_MODULE_PATH")

M src/Misc.hs => src/Misc.hs +12 -0
@@ 17,12 17,14 @@ module Misc
    , insertWith'
    , if'
    , abort
    , splitOn
    )
where

import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Data.Composition
import Control.Monad.Reader
import Control.Lens (Lens', locally)


@@ 32,6 34,10 @@ import LLVM.AST.Type (Type)
import LLVM.AST (Name, Module)
import LLVM.Pretty ()
import qualified Data.Text.Prettyprint.Doc as Prettyprint
import qualified Text.Megaparsec as Mega
import Text.Megaparsec hiding (parse, match)
import Text.Megaparsec.Char hiding (space, space1)
import Data.Void

ice :: String -> a
ice = error . ("Internal Compiler Error: " ++)


@@ 113,3 119,9 @@ abort f = do
    putStrLn "Error: Aborting due to previous error."
    putStrLn $ "Error: Could not compile " ++ f ++ "."
    exitFailure

splitOn :: String -> String -> [String]
splitOn sep = fromMaybe [] . Mega.parseMaybe (splitOn' sep)

splitOn' :: String -> Parsec Void String [String]
splitOn' sep = sepBy (many (noneOf [':'])) (string sep)

M src/Parse.hs => src/Parse.hs +22 -24
@@ 28,6 28,7 @@ where
import Control.Monad
import Data.Char (isMark, isPunctuation, isSymbol, isUpper)
import Data.Functor
import Data.Maybe
import Control.Applicative (liftA2)
import qualified Text.Megaparsec as Mega
import Text.Megaparsec hiding (parse, match)


@@ 48,7 49,7 @@ import Misc hiding (if')
import SrcPos
import Ast
import Literate
import CompiletimeVars
import EnvVars

type Parser = Parsec Void String
type Source = String


@@ 70,13 71,8 @@ parseModule
    -> [String]
    -> IO (Either String ([Def], [TypeDef], [Extern]))
parseModule filepath dir m visiteds nexts = do
    (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
    modPaths <- fmap (dir :) modulePaths
    (src, f) <- parseModule' modPaths
    let visiteds' = Set.insert m visiteds
    case parse' toplevels f src of
        Left e -> pure (Left e)


@@ 88,25 84,27 @@ parseModule filepath dir m visiteds nexts = do
                    (\(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
    parseModule' modPaths = do
        let fs = do
                p <- modPaths
                let pm = p </> m
                fmap (addExtension pm) [".carth", ".org"]
        fs' <- filterM doesFileExist fs
        f <- case listToMaybe fs' of
            Nothing -> do
                putStrLn
                    $ ("Error: File of module " ++ m)
                    ++ " is ambiguous. Both .org and .carth exist."
                    $ ("Error: No file for module " ++ m)
                    ++ (" exists.\nSearched paths: " ++ show modPaths)
                abort filepath
            (True, False) -> fmap (Just . (, carthf)) (readFile carthf)
            (False, True) -> do
                s <- readFile orgf
            Just f' -> pure f'
        s <- readFile f
        s' <- if takeExtension f == ".org"
            then do
                let s' = untangleOrg s
                writeFile (addExtension m "untangled") s
                pure (Just (s', orgf))
            (False, False) -> pure Nothing
                writeFile (addExtension m "untangled") s'
                pure s'
            else pure s
        pure (s', f)

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