~jojo/Carth

40f4f16504398a4b69fd27e797a482f50ff0d21d — JoJo 1 year, 10 months ago b2cf053
Add basic import system. Basically C-style include
10 files changed, 193 insertions(+), 141 deletions(-)

M app/Main.hs
M examples/fizzbuzz.carth
M examples/hello-world.carth
M examples/literate.org
D examples/sicp.carth
A examples/std.carth
M package.yaml
M src/Misc.hs
M src/Parse.hs
M src/TypeErr.hs
M app/Main.hs => app/Main.hs +9 -28
@@ 3,11 3,8 @@
module Main (main) where

import Data.Functor
import System.Exit
import System.FilePath

import Misc
import Literate
import qualified TypeErr
import qualified Ast
import qualified DesugaredAst


@@ 17,7 14,6 @@ import Config
import Compile
import Mono
import qualified Parse
import Parse (Source)

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


@@ 25,28 21,19 @@ main = uncurry compileFile =<< getConfig
compileFile :: FilePath -> CompileConfig -> IO ()
compileFile f cfg = do
    putStrLn ("   Compiling " ++ f ++ "\n")
    src <- readFile f
    parse' f src >>= typecheck' f src >>= monomorphize' >>= compile f cfg

parse' :: FilePath -> String -> IO Ast.Program
parse' f src = do
    src' <- if takeExtension f == ".org"
        then do
            putStrLn "Untangling org..."
            let s = untangleOrg src
            writeFile "out.untangled" s
            pure s
        else pure src
    case Parse.parse f src' of
        Left e -> putStrLn (formatParseErr e) >> abort f
        Right p -> writeFile "out.parsed" (pretty p) $> p
    parse f >>= typecheck' f >>= monomorphize' >>= compile f cfg

parse :: FilePath -> IO Ast.Program
parse f = Parse.parse f >>= \case
    Left e -> putStrLn (formatParseErr e) >> abort f
    Right p -> writeFile "out.parsed" (pretty p) $> p
  where
    formatParseErr e =
        let ss = lines e in (unlines ((head ss ++ " Error:") : tail ss))

typecheck' :: FilePath -> Source -> Ast.Program -> IO DesugaredAst.Program
typecheck' f src p = case typecheck p of
    Left e -> putStrLn (TypeErr.prettyErr e src) >> abort f
typecheck' :: FilePath -> Ast.Program -> IO DesugaredAst.Program
typecheck' f p = case typecheck p of
    Left e -> TypeErr.printErr e >> abort f
    Right p -> writeFile "out.checked" (show p) $> p

monomorphize' :: DesugaredAst.Program -> IO MonoAst.Program


@@ 54,9 41,3 @@ monomorphize' p = do
    let p' = monomorphize p
    writeFile "out.mono" (show p')
    pure p'

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

M examples/fizzbuzz.carth => examples/fizzbuzz.carth +1 -54
@@ 1,16 1,4 @@
(type (Pair a b)
  (Pair a b))

(type (Maybe a)
  None
  (Some a))

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

(type (Iter a)
  (Iter (Lazy (Maybe (Pair a (Iter a))))))

(import std)

(define (start _) (fizzbuzz unit))



@@ 30,44 18,3 @@
    [1 "one"]
    [2 "two"]
    [n (show-int n)]))

(define (display s)
  (display-inline (str-append s "\n")))

(define (for xs f)
  (match (next xs)
    [None unit]
    [(Some (Pair x xs'))
     (seq (f x) (for xs' f))]))

(define (range a b)
  (Iter (Lazy (if (> a b)
                  (fun _ None)
                (fun _ (Some (Pair a (range (+ a 1) b))))))))

(define next (fun-match [(Iter it) (lively it)]))
(define lively (fun-match [(Lazy f) (f unit)]))
(define (seq a b) b)
(define (comp f g a) (f (g a)))
(define (and p q) (if p q false))
(define (divisible? n m) (= (rem n m) 0))


;;; Extern wrappers

(define (str-append s1 s2) (-str-append (Pair s1 s2)))
(define (> a b) (gt-int (Pair a b)))
(define (= a b) (eq-int (Pair a b)))
(define (+ a b) (add-int (Pair a b)))
(define (rem a b) (rem-int (Pair a b)))


;;; Externs

(extern display-inline (Fun Str Unit))
(extern -str-append (Fun (Pair Str Str) Str))
(extern show-int (Fun Int Str))
(extern gt-int (Fun (Pair Int Int) Bool))
(extern eq-int (Fun (Pair Int Int) Bool))
(extern add-int (Fun (Pair Int Int) Int))
(extern rem-int (Fun (Pair Int Int) Int))

M examples/hello-world.carth => examples/hello-world.carth +2 -8
@@ 1,10 1,4 @@
(type (Pair a b)
  (Pair a b))
(import std)

(define (start _)
  (display-inline (str-append "Hello, world!" "\n")))

(define (str-append s1 s2) (-str-append (Pair s1 s2)))

(extern display-inline (Fun Str Unit))
(extern -str-append (Fun (Pair Str Str) Str))
  (display (str-append "Hello, world!" "\n")))

M examples/literate.org => examples/literate.org +9 -3
@@ 2,12 2,18 @@

Literate programming is just really cool!

First we import the standard library.

#+BEGIN_SRC carth
(import std)
#+END_SRC

~carth~ will assume ~tangle~ = ~yes~ by default, but setting it
explicitly won't hurt.

#+BEGIN_SRC carth :tangle yes
(define (main _)
  (printInt (id 1337)))
(define (start _)
  (display (id "Literate programming rules!")))
#+END_SRC

* The ~id~ function


@@ 23,5 29,5 @@ explicitly won't hurt.
  but as ~tangle~ is ~no~, this source block will be ignored by carth.

  #+BEGIN_SRC carth :tangle no
  (printInt id)
  (display id)
  #+END_SRC

D examples/sicp.carth => examples/sicp.carth +0 -18
@@ 1,18 0,0 @@
(define main
  (display (concat (Cons "Hello" (Cons ", " (Cons "World!" Nil))))))

(define concat
  (foldr ++ ""))

(define (foldr f init)
  (fun-match
    [Nil init]
    [(Cons x xs) (Cons (f x) (foldr f init xs))]))

(define ++
  (fun-match
    [Nil snd]
    [(Cons x xs) (. (Cons x) (++ xs))]))

(define (const c x) c)
(define (snd a b) b)

A examples/std.carth => examples/std.carth +83 -0
@@ 0,0 1,83 @@
(type (Pair a b)
  (Pair a b))

(define fst
  (fun-match [(Pair a _) a]))
(define snd
  (fun-match [(Pair _ b) b]))

(type (Maybe a)
  None
  (Some a))

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

(define lively
  (fun-match [(Lazy f) (f unit)]))

;;; Math

(extern rem-int (Fun (Pair Int Int) Int))
(define (rem a b)
  (rem-int (Pair a b)))

(extern add-int (Fun (Pair Int Int) Int))
(define (+ a b)
  (add-int (Pair a b)))

(extern eq-int (Fun (Pair Int Int) Bool))
(define (= a b)
  (eq-int (Pair a b)))

(extern gt-int (Fun (Pair Int Int) Bool))
(define (> a b)
  (gt-int (Pair a b)))

(define (and p q)
  (if p q false))

(define (divisible? n m)
  (= (rem n m) 0))

;;; Strings

(extern show-int (Fun Int Str))

(extern -str-append (Fun (Pair Str Str) Str))
(define (str-append s1 s2)
  (-str-append (Pair s1 s2)))

;;; IO

(extern display-inline (Fun Str Unit))

(define (display s)
  (display-inline (str-append s "\n")))

;;; Function

(define (seq a b)
  b)

(define (comp f g a)
  (f (g a)))

;;; Iter

(type (Iter a)
  (Iter (Lazy (Maybe (Pair a (Iter a))))))

(define next
  (fun-match [(Iter it) (lively it)]))

(define (range a b)
  (Iter (Lazy (if (> a b)
                  (fun _ None)
                (fun _ (Some (Pair a (range (+ a 1) b))))))))

(define (for xs f)
  (match (next xs)
    [None unit]
    [(Some (Pair x xs'))
     (seq (f x) (for xs' f))]))

M package.yaml => package.yaml +1 -0
@@ 33,6 33,7 @@ dependencies:
- llvm-hs
- llvm-hs-pretty
- filepath
- directory
- bytestring
- utf8-string
- composition-extra

M src/Misc.hs => src/Misc.hs +8 -0
@@ 15,6 15,7 @@ module Misc
    , augment
    , insertWith'
    , if'
    , abort
    )
where



@@ 24,6 25,7 @@ import Data.Map (Map)
import Data.Composition
import Control.Monad.Reader
import Control.Lens (Lens', locally)
import System.Exit
import LLVM.AST.Type (Type)
import LLVM.AST (Name, Module)
import LLVM.Pretty ()


@@ 99,3 101,9 @@ insertWith' f = Map.insertWith (f .* flip const)

if' :: Bool -> a -> a -> a
if' p c a = if p then c else a

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

M src/Parse.hs => src/Parse.hs +71 -21
@@ 36,46 36,95 @@ import Text.Megaparsec hiding (parse, match)
import Text.Megaparsec.Char hiding (space, space1)
import qualified Text.Megaparsec.Char as Char
import qualified Text.Megaparsec.Char.Lexer as Lexer
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Either.Combinators
import Data.Void
import Data.Composition
import Data.List
import System.FilePath
import System.Directory

import Misc hiding (if')
import SrcPos
import Ast
import NonEmpty
import Literate

type Parser = Parsec Void String

type Source = String

parse :: FilePath -> Source -> Either String Program
parse = parse' program
type Import = String


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 [])
    pure (fmap (\(ds, ts, es) -> Program ds ts es) r)

parseModule
    :: FilePath
    -> FilePath
    -> String
    -> Set String
    -> [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
    let visiteds' = Set.insert m visiteds
    case parse' toplevels (dir </> f) src of
        Left e -> pure (Left e)
        Right (is, ds, ts, es) -> case is ++ nexts of
            [] -> pure (Right (ds, ts, es))
            next : nexts' -> do
                r <- parseModule filepath dir next visiteds' nexts'
                pure $ fmap
                    (\(ds', ts', es') -> (ds ++ ds', ts ++ ts', es ++ es'))
                    r

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

program :: Parser Program
program = do
toplevels :: Parser ([Import], [Def], [TypeDef], [Extern])
toplevels = do
    space
    (defs, typedefs, externs) <- toplevels
    r <- option ([], [], [], []) (toplevel >>= flip fmap toplevels)
    eof
    pure (Program defs typedefs externs)

toplevels :: Parser ([Def], [TypeDef], [Extern])
toplevels = option ([], [], []) (toplevel >>= flip fmap toplevels)

toplevel
    :: Parser (([Def], [TypeDef], [Extern]) -> ([Def], [TypeDef], [Extern]))
toplevel = do
    topPos <- getSrcPos
    parens $ choice
        [ fmap (\a (as, bs, cs) -> (a : as, bs, cs)) (def topPos)
        , fmap (\b (as, bs, cs) -> (as, b : bs, cs)) typedef
        , fmap (\c (as, bs, cs) -> (as, bs, c : cs)) extern
        ]
    pure r
  where
    toplevel = do
        topPos <- getSrcPos
        parens $ choice
            [ fmap (\i (is, ds, ts, es) -> (i : is, ds, ts, es)) import'
            , fmap
                (\d (is, ds, ts, es) -> (is, d : ds, ts, es))
                (def topPos)
            , fmap (\t (is, ds, ts, es) -> (is, ds, t : ts, es)) typedef
            , fmap (\e (is, ds, ts, es) -> (is, ds, ts, e : es)) extern
            ]

import' :: Parser Import
import' = reserved "import" *> fmap idstr small'

extern :: Parser Extern
extern = reserved "extern" *> liftA2 Extern small' type_


@@ 391,6 440,7 @@ reserveds =
    , "type"
    , "box"
    , "deref"
    , "import"
    ]

otherChar :: Parser Char

M src/TypeErr.hs => src/TypeErr.hs +9 -9
@@ 1,6 1,6 @@
{-# LANGUAGE LambdaCase, FlexibleContexts, DataKinds #-}

module TypeErr (TypeErr(..), prettyErr) where
module TypeErr (TypeErr(..), printErr) where

import Misc
import SrcPos


@@ 36,9 36,9 @@ data TypeErr

type Message = String

prettyErr :: TypeErr -> Parse.Source -> String
prettyErr = \case
    StartNotDefined -> const "Error: start not defined"
printErr :: TypeErr -> IO ()
printErr = \case
    StartNotDefined -> putStrLn "Error: start not defined"
    InvalidUserTypeSig p s1 s2 ->
        posd p scheme
            $ ("Invalid user type signature " ++ pretty s1)


@@ 119,10 119,10 @@ prettyErr = \case
    wholeLine = many Mega.anySingle
    (<||>) pa pb = (Mega.try pa $> ()) <|> (pb $> ())

posd :: SrcPos -> Parse.Parser a -> Message -> Parse.Source -> String
posd (SrcPos pos@(SourcePos _ lineN colN)) parser msg src =
    let
        (lineN', colN') = (unPos lineN, unPos colN)
posd :: SrcPos -> Parse.Parser a -> Message -> IO ()
posd (SrcPos pos@(SourcePos f lineN colN)) parser msg = do
    src <- readFile f
    let (lineN', colN') = (unPos lineN, unPos colN)
        lines' = lines src
        line = if (lineN' <= length lines')
            then lines' !! (lineN' - 1)


@@ 138,7 138,7 @@ posd (SrcPos pos@(SourcePos _ lineN colN)) parser msg src =
            (\e -> ice ("posd: msg=|" ++ msg ++ "|,err=|" ++ show e ++ "|"))
            id
            (Parse.parse' (fmap fst (Mega.match parser)) "" rest)
    in unlines
    putStrLn $ unlines
        [ sourcePosPretty pos ++ ": Error:"
        , indent pad ++ "|"
        , lineNS ++ " | " ++ line