~jojo/Carth

b95659b570d943610fba79d06fe263b4bdc23cea — JoJo 6 months ago 93e3575
Add patterns & declaration of literals in macros

Example of a do-notation-like macro using the new features:

    (defmacro do (<-)
      (case (do-bind ma) ma)
      (case (do-bind (<- a ma) mbs ...)
            (do-bind (fun (a) (do do-bind mbs ...)) ma))
      (case (do-bind ma mbs ...)
            (do-bind (fun (_) (do do-bind mbs ...)) ma)))

which can be used like

    (do list/bind
        (<- i (list 1 2 3))
        (<- j (list 1 2 3))
        (if (< i j)
            (list/singleton [i j])
          list/nil))
4 files changed, 59 insertions(+), 28 deletions(-)

M src/Lexd.hs
M src/Macro.hs
M src/Misc.hs
M std/macros.carth
M src/Lexd.hs => src/Lexd.hs +1 -1
@@ 34,6 34,6 @@ data TokenTree'
    | Brackets [TokenTree]
    | Braces [TokenTree]
    | Ellipsis TokenTree
    deriving (Show)
    deriving (Eq, Show)

type TokenTree = WithPos TokenTree'

M src/Macro.hs => src/Macro.hs +47 -21
@@ 8,14 8,18 @@ import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map

import Misc
import SrcPos
import Lexd
import Parser

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



@@ 28,14 32,13 @@ toplevels = fmap concat . mapM toplevel
toplevel :: TokenTree -> Expand [TokenTree]
toplevel = \case
    WithPos mpos (Parens (WithPos _ (Keyword Kdefmacro) : tts)) -> do
        def <- lift $ lift $ runParser pdefmacro mpos tts
        validateRules (snd def)
        modify (uncurry Map.insert def)
        (name, lits, rules) <- lift $ lift $ runParser pdefmacro mpos tts
        modify (Map.insert name (lits, rules))
        pure []
    tt -> expand tt

pdefmacro :: Parser (String, Rules)
pdefmacro = liftA2 (,) small' (some prule)
pdefmacro :: Parser (String, Literals, Rules)
pdefmacro = liftA3 (,,) small' (fmap Set.fromList (parens (many small'))) (some prule)
  where
    prule = parens $ do
        reserved Kcase


@@ 43,10 46,6 @@ pdefmacro = liftA2 (,) small' (some prule)
        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 (WithPos tpos tt') = do
    (bs, expPos) <- ask


@@ 64,7 63,7 @@ expand (WithPos tpos tt') = do
        Parens (WithPos _ (Small x) : tts1) | Just m <- Map.lookup x ms -> do
            tts2 <- expands tts1
            local (second (const (Just tpos'))) $ do
                tts3 <- applyMacro tpos' tts2 m
                tts3 <- uncurry (applyMacro tpos' tts2) m
                expands tts3
        Parens tts -> par Parens tts
        Brackets tts -> par Brackets tts


@@ 82,17 81,44 @@ expand (WithPos tpos tt') = do
expands :: [TokenTree] -> Expand [TokenTree]
expands = fmap concat . mapM expand

applyMacro :: SrcPos -> [TokenTree] -> Rules -> Expand [TokenTree]
applyMacro appPos args = \case
applyMacro :: SrcPos -> [TokenTree] -> Literals -> Rules -> Expand [TokenTree]
applyMacro appPos args lits = \case
    [] -> throwError (appPos, "No rule matched in application of macro")
    (params, template) : rules -> case matchRule (map unpos params, args) of
        Just bindings ->
            local (first (Map.union (Map.fromList bindings))) (expands template)
        Nothing -> applyMacro appPos args rules
        Just bindings -> local (first (Map.union bindings)) (expands template)
        Nothing -> applyMacro appPos args lits rules
  where
    matchRule :: ([TokenTree'], [TokenTree]) -> Maybe (Map String TokenTree')
    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
        ([], []) -> Just mempty
        (Ellipsis (WithPos _ x) : xs, ys) ->
            let ms = takeWhileJust (matchPat x) ys
                ys' = drop (length ms) ys
                -- By default, each pattern variable in an ellipsis pattern should be
                -- bound to an empty Parens, even if ys was empty
                ms' = Map.fromSet (const []) (fvPat x) : map (fmap pure) ms
                ms'' = fmap Parens (Map.unionsWith (++) ms')
            in  fmap (Map.union ms'') (matchRule (xs, ys'))
        (x : xs, y : ys) ->
            liftA2 (Map.union . fmap unpos) (matchPat x y) (matchRule (xs, ys))
        ([], _ : _) -> Nothing
        (_ : _, []) -> Nothing

    matchPat :: TokenTree' -> TokenTree -> Maybe (Map String TokenTree)
    matchPat p (WithPos apos a) = case (p, a) of
        (Small x, _) | not (Set.member x lits) -> Just (Map.singleton x (WithPos apos a))
        (Parens xs, Parens ys) -> par xs ys
        (Brackets xs, Brackets ys) -> par xs ys
        (Braces xs, Braces ys) -> par xs ys
        (_, _) | p == a -> Just mempty
               | otherwise -> Nothing
        where par xs ys = fmap Map.unions $ zipWithM matchPat (map unpos xs) ys

    fvPat = \case
        Small x | not (Set.member x lits) -> Set.singleton x
        Parens tts -> par tts
        Brackets tts -> par tts
        Braces tts -> par tts
        Ellipsis tt -> fvPat (unpos tt)
        _ -> Set.empty
        where par = Set.unions . map (fvPat . unpos)

M src/Misc.hs => src/Misc.hs +5 -0
@@ 121,3 121,8 @@ is3tup :: [a] -> Maybe (a, a, a)
is3tup = \case
    a1 : a2 : [a3] -> Just (a1, a2, a3)
    _ -> Nothing

takeWhileJust :: (a -> Maybe b) -> [a] -> [b]
takeWhileJust f = \case
    [] -> []
    a : as -> maybe [] (: takeWhileJust f as) (f a)

M std/macros.carth => std/macros.carth +6 -6
@@ 1,19 1,19 @@
(defmacro apps
(defmacro apps ()
  (case (op x) x)
  (case (op x1 x2 xs ...) (apps op (op x1 x2) xs ...)))

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

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

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

(defmacro io/wrap
(defmacro io/wrap ()
  (case (computation) (IO (fun (real-world) [computation real-world]))))

(defmacro lazy
(defmacro lazy ()
  (case (computation) (Lazy [(unsafe-perform-io mutex/new)
                             (box (Left (fun (Unit) computation)))])))