~jojo/Carth

ref: 2219ea535f4a0fd0afd9000ba5c6918c6b276210 Carth/src/Macro.hs -rw-r--r-- 4.8 KiB
2219ea53JoJo remove no longer applicable TODOs 7 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
{-# LANGUAGE LambdaCase #-}

module Macro (expandMacros) where

import Control.Applicative
import Control.Monad.Except
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 (Literals, Rules)
type Bindings = Map String TokenTree'
type Expand = ReaderT (Bindings, Maybe SrcPos) (StateT Macros (Except (SrcPos, String)))

expandMacros :: [TokenTree] -> Except (SrcPos, String) [TokenTree]
expandMacros tts = evalStateT (runReaderT (toplevels tts) (Map.empty, Nothing)) Map.empty

toplevels :: [TokenTree] -> Expand [TokenTree]
toplevels = fmap concat . mapM toplevel

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

pdefmacro :: Parser (String, Literals, Rules)
pdefmacro = liftA3 (,,) small' (fmap Set.fromList (parens (many small'))) (some prule)
  where
    prule = parens $ do
        reserved Kcase
        params <- parens (many anyToken)
        template <- many anyToken
        pure (params, template)

expand :: TokenTree -> Expand [TokenTree]
expand (WithPos tpos tt') = do
    (bs, expPos) <- ask
    ms <- get
    let tpos' = tpos { inExpansion = expPos }
    let tt = WithPos tpos' tt'
    let par ctor tts = fmap (pure . WithPos tpos' . ctor) (expands tts)
    case tt' of
        Lit _ -> pure [tt]
        Small x -> case Map.lookup x bs of
            Just xtt -> pure [WithPos tpos' xtt]
            Nothing -> pure [tt]
        Big _ -> pure [tt]
        Keyword _ -> pure [tt]
        Parens (WithPos _ (Small x) : tts1) | Just m <- Map.lookup x ms -> do
            tts2 <- expands tts1
            local (second (const (Just tpos'))) $ do
                tts3 <- uncurry (applyMacro tpos' tts2) m
                expands tts3
        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")

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

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 bindings)) (expands template)
        Nothing -> applyMacro appPos args lits rules
  where
    matchRule :: ([TokenTree'], [TokenTree]) -> Maybe (Map String TokenTree')
    matchRule = \case
        ([], []) -> 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)