~jojo/Carth

d09e75d2aee08fb372c5e5eba38fc16f308c2ec7 — JoJo 1 year, 1 month ago 27587c1
Add macro rules and ellipsis (...) macro operator
M app/Main.hs => app/Main.hs +1 -0
@@ 62,6 62,7 @@ frontend cfg f = do
    when d $ writeFile ".dbg.lexd" (show tts)
    verbose cfg ("   Expanding macros")
    tts' <- expandMacros f tts
    when d $ writeFile ".dbg.expanded" (show tts')
    verbose cfg ("   Parsing")
    ast <- parse f tts'
    when d $ writeFile ".dbg.parsed" (pretty ast)

M src/Lex.hs => src/Lex.hs +6 -4
@@ 93,7 93,11 @@ toplevel = getSrcPos >>= \p -> parens
    where import' = keyword' "import" *> small

tokentree :: Lexer TokenTree
tokentree = withPos tokentree'
tokentree = do
    p <- getSrcPos
    tt <- tokentree'
    tt' <- option tt (ellipsis $> Ellipsis (WithPos p tt))
    pure (WithPos p tt')
  where
    tokentree' = choice
        [ fmap Small smallSpecial


@@ 106,6 110,7 @@ tokentree = withPos tokentree'
        , fmap Brackets (brackets (many tokentree))
        , fmap Braces (braces (many tokentree))
        ]
    ellipsis = try (string "..." *> notFollowedBy identLetter *> space)
    lit = try num <|> fmap Str strlit
    num = andSkipSpaceAfter ns_num
    ns_num = do


@@ 202,9 207,6 @@ symbol = Lexer.symbol space
space :: Lexer ()
space = Lexer.space Char.space1 (Lexer.skipLineComment ";") empty

withPos :: Lexer a -> Lexer (WithPos a)
withPos = liftA2 WithPos getSrcPos

getSrcPos :: Lexer SrcPos
getSrcPos = fmap
    (\(SourcePos f l c) -> SrcPos f (fromIntegral (unPos l)) (fromIntegral (unPos c)))

M src/Lexd.hs => src/Lexd.hs +1 -0
@@ 33,6 33,7 @@ data TokenTree'
    | Parens [TokenTree]
    | Brackets [TokenTree]
    | Braces [TokenTree]
    | Ellipsis TokenTree
    deriving (Show)

type TokenTree = WithPos TokenTree'

M src/Macro.hs => src/Macro.hs +42 -20
@@ 13,8 13,9 @@ import SrcPos
import Lexd
import Parser

type Macros = Map String ([String], [TokenTree])
type Bindings = Map String TokenTree
type Rules = [([TokenTree], [TokenTree])]
type Macros = Map String Rules
type Bindings = Map String TokenTree'
type Expand = ReaderT Bindings (StateT Macros (Except (SrcPos, String)))

expandMacros :: [TokenTree] -> Except (SrcPos, String) [TokenTree]


@@ 25,17 26,25 @@ toplevels = fmap concat . mapM toplevel

toplevel :: TokenTree -> Expand [TokenTree]
toplevel = \case
    WithPos _ (Parens (WithPos _ (Keyword Kdefmacro) : tts)) -> do
        def <- lift $ lift $ runParser pdefmacro tts
    WithPos mpos (Parens (WithPos _ (Keyword Kdefmacro) : tts)) -> do
        def <- lift $ lift $ runParser pdefmacro mpos tts
        validateRules (snd def)
        modify (uncurry Map.insert def)
        pure []
    tt -> expand tt

pdefmacro :: Parser (String, ([String], [TokenTree]))
pdefmacro = do
    (x, params) <- parens (liftA2 (,) small' (many small'))
    template <- many anyToken
    pure (x, (params, template))
pdefmacro :: Parser (String, Rules)
pdefmacro = liftA2 (,) small' (some prule)
  where
    prule = parens $ do
        reserved Kcase
        params <- parens (many anyToken)
        template <- many anyToken
        pure (params, template)

-- TODO: Check for example that there's max one ellipses in the params.
validateRules :: Rules -> Expand ()
validateRules _ = pure ()

expand :: TokenTree -> Expand [TokenTree]
expand tt@(WithPos tpos tt') = do


@@ 44,27 53,40 @@ expand tt@(WithPos tpos tt') = do
    case tt' of
        Lit _ -> pure [tt]
        Small x -> case Map.lookup x bs of
            Just xtt -> pure [xtt]
            Just xtt -> pure [WithPos tpos xtt]
            Nothing -> pure [tt]
        Big _ -> pure [tt]
        Keyword _ -> pure [tt]
        Parens (WithPos _ (Small x) : tts) | Just m <- Map.lookup x ms -> do
            tts' <- expands tts
            applyMacro tpos m tts'
            applyMacro tpos tts' m
        Parens tts -> par Parens tts
        Brackets tts -> par Brackets tts
        Braces tts -> par Braces tts
        Ellipsis (WithPos epos (Small x)) -> case Map.lookup x bs of
            Just (Parens xtts) -> expands xtts
            Just (Brackets xtts) -> expands xtts
            Just (Braces xtts) -> expands xtts
            Just _ -> throwError
                (epos, "Cannot ellipsis splice non-sequence macro pattern variable")
            Nothing -> throwError (epos, "Unbound macro pattern variable")
        Ellipsis (WithPos epos _) ->
            throwError (epos, "Can only ellipsis splice macro pattern variable")
    where par ctor tts = fmap (pure . WithPos tpos . ctor) (expands tts)

expands :: [TokenTree] -> Expand [TokenTree]
expands = fmap concat . mapM expand

applyMacro :: SrcPos -> ([String], [TokenTree]) -> [TokenTree] -> Expand [TokenTree]
applyMacro appPos (params, template) args = if length params /= length args
    then throwError
        ( appPos
        , "Arity mismatch in application of macro.\n"
        ++ ("Expected " ++ show (length params))
        ++ (", found " ++ show (length args))
        )
    else local (Map.union (Map.fromList (zip params args))) (expands template)
applyMacro :: SrcPos -> [TokenTree] -> Rules -> Expand [TokenTree]
applyMacro appPos args = \case
    [] -> throwError (appPos, "No rule matched in application of macro")
    (params, template) : rules -> case matchRule (map unpos params, args) of
        Just bindings -> local (Map.union (Map.fromList bindings)) (expands template)
        Nothing -> applyMacro appPos args rules
  where
    matchRule = \case
        ([], []) -> Just []
        (Ellipsis (WithPos _ (Small x)) : _, args) -> Just [(x, Parens args)]
        (Small x : params, arg : args) ->
            fmap ((x, unpos arg) :) (matchRule (params, args))
        _ -> Nothing

M src/Parse.hs => src/Parse.hs +1 -1
@@ 21,7 21,7 @@ import Parsed hiding (Lit)
import qualified Parsed

parse :: [TokenTree] -> Except (SrcPos, String) Program
parse tts = fmap (\(ds, ts, es) -> Program ds ts es) (runParser toplevels tts)
parse tts = fmap (\(ds, ts, es) -> Program ds ts es) (runParser' toplevels tts)

toplevels :: Parser ([Def], [TypeDef], [Extern])
toplevels = fmap mconcat (manyTill toplevel end)

M src/Parser.hs => src/Parser.hs +6 -4
@@ 51,10 51,12 @@ instance Alternative Parser where
            then throwError e
            else catchError mb (throwError . (e <>))

runParser :: Parser a -> [TokenTree] -> Except (SrcPos, String) a
runParser (Parser ma) tts =
    let noPos = ice "read SrcPos in parser state at top level"
        initSt = St 0 noPos tts
runParser' :: Parser a -> [TokenTree] -> Except (SrcPos, String) a
runParser' ma = runParser ma (ice "read SrcPos in parser state at top level")

runParser :: Parser a -> SrcPos -> [TokenTree] -> Except (SrcPos, String) a
runParser (Parser ma) surroundingPos tts =
    let initSt = St 0 surroundingPos tts
        formatExpecteds es = case Set.toList es of
            [] -> ice "empty list of expecteds in formatExpecteds"
            [e] -> "Expected " ++ e

M std/iter.carth => std/iter.carth +4 -4
@@ 1,5 1,4 @@
(import std)
(import list)
(import macros)
(import maybe)

(data (Iter a)


@@ 23,8 22,9 @@
(define (next (Iter it)) (it Unit))
(define next! (<o unwrap! next))

(define (iter/nth n)
  (<o (maybe/map car) (<o next (skip n))))
(define: (iter/nth n)
    (forall (a) (Fun Nat (Iter a) (Maybe a)))
  (apps <o (maybe/map car) next (skip n)))

(define: (xrange a b) (Fun Int Int (Iter Int))
  (take (- b a)       (range-from a)))

M std/list.carth => std/list.carth +0 -13
@@ 49,19 49,6 @@
(define (list/cons x xs)
  (LCons (box [x xs])))

(define (list1 x)
  (list/cons x Nil))
(define (list2 x0 x1)
  (list/cons x0 (list1 x1)))
(define (list3 x0 x1 x2)
  (list/cons x0 (list2 x1 x2)))
(define (list4 x0 x1 x2 x3)
  (list/cons x0 (list3 x1 x2 x3)))
(define (list5 x0 x1 x2 x3 x4)
  (list/cons x0 (list4 x1 x2 x3 x4)))
(define (list6 x0 x1 x2 x3 x4 x5)
  (list/cons x0 (list5 x1 x2 x3 x4 x5)))

(define (list/iter xs)
  (Iter (fun (Unit)
          (match xs

A std/macros.carth => std/macros.carth +12 -0
@@ 0,0 1,12 @@
(defmacro apps
  (case (op x) x)
  (case (op x1 x2 xs ...) (apps op (op x1 x2) xs ...)))

(defmacro appsr
  (case (op x) x)
  (case (op x xs ...) (op x (appsr op xs ...))))

(defmacro list
  (case (xs ...) (appsr list/cons xs ... Nil)))

(defmacro +s (case (xs ...) (apps + xs ...)))

M std/std.carth => std/std.carth +3 -8
@@ 1,3 1,4 @@
(import macros)
(import iter)
(import list)
(import maybe)


@@ 68,22 69,16 @@
(define (uncurry f [a b]) (f a b))
(define (curry f a b) (f [a b]))

(define (<| f a) (f a))
(define (|> a f) (f a))
(define (app f a) (f a))
(define (rapp a f) (f a))

(define (const a b) a)
(define (seq   a b) b)

(define (<o f g a) (f (g a)))
(define (<o3 f1 f2 f3 a) (f1 (f2 (f3 a))))
(define (<o4 f1 f2 f3 f4 a) (f1 (f2 (f3 (f4 a)))))
(define (<o5 f1 f2 f3 f4 f5 a) (f1 (f2 (f3 (f4 (f5 a))))))
(define (<oo f g a b) (f (g a b)))
(define (<ooo f g a b c) (f (g a b c)))
(define (o> f g a) (g (f a)))
(define (o3> f1 f2 f3 a) (f3 (f2 (f1 a))))
(define (o4> f1 f2 f3 f4 a) (f4 (f3 (f2 (f1 a)))))
(define (o5> f1 f2 f3 f4 f5 a) (f5 (f4 (f3 (f2 (f1 a))))))
(define (oo> f g a b) (g (f a b)))
(define (ooo> f g a b c) (g (f a b c)))


M test/SystemSpec.hs => test/SystemSpec.hs +3 -1
@@ 16,6 16,7 @@ import System.IO.Silently

import Misc
import Lex
import Macro
import Parse
import qualified Parsed
import Check


@@ 78,7 79,8 @@ frontend f = lexAndParse f <&> \case
    Just ast -> fmap (optimize . monomorphize) (rightToMaybe (typecheck ast))

lexAndParse :: FilePath -> IO (Maybe Parsed.Program)
lexAndParse f = fmap rightToMaybe (runExceptT (lex' f >>= parse''))
lexAndParse f = fmap rightToMaybe (runExceptT (lex' f >>= expandMacros' >>= parse''))
  where
    lex' = withExceptT (const ()) . lex
    expandMacros' = withExceptT (const ()) . liftEither . runExcept . expandMacros
    parse'' = withExceptT (const ()) . liftEither . runExcept . parse