11 files changed, 79 insertions(+), 55 deletions(-)

M app/Main.hs
M src/Lex.hs
M src/Lexd.hs
M src/Macro.hs
M src/Parse.hs
M src/Parser.hs
M std/iter.carth
M std/list.carth
A std/macros.carth
M std/std.carth
M test/SystemSpec.hs

@@ 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)

@@ 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)))

@@ 33,6 33,7 @@ data TokenTree'
     | Parens [TokenTree]
     | Brackets [TokenTree]
     | Braces [TokenTree]
+    | Ellipsis TokenTree
     deriving (Show)
 
 type TokenTree = WithPos TokenTree'

@@ 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

@@ 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)

@@ 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

@@ 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)))

@@ 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

@@ 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 ...)))

@@ 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)))
 

@@ 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