~jojo/Carth

ref: db87ea9bdce9470b546bb3098f5d79a9b1023af1 Carth/src/Selections.hs -rw-r--r-- 1.8 KiB
db87ea9bJoJo Disclaim WIP status in readme 1 year, 10 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
{-# LANGUAGE LambdaCase, TupleSections #-}

module Selections (Selections, newSelections, select, selectVarBindings) where

import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Word
import Control.Monad

import Misc
import MonoAst


type Selections a = Map Access a


newSelections :: a -> Selections a
newSelections x = Map.singleton Obj x

select
    :: (Show a, Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Access
    -> Selections a
    -> m (a, Selections a)
select conv sub deref selector selections =
    case Map.lookup selector selections of
        Just a -> pure (a, selections)
        Nothing -> do
            (a, selections') <- case selector of
                Obj -> ice "select: Obj not in selections"
                As x span' ts -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- conv span' ts a'
                    pure (a'', s')
                Sel i span' x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- sub span' i a'
                    pure (a'', s')
                ADeref x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- deref a'
                    pure (a'', s')
            pure (a, Map.insert selector a selections')

selectVarBindings
    :: (Show a, Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Selections a
    -> VarBindings
    -> m [(TypedVar, a)]
selectVarBindings conv sub deref selections = fmap fst . foldM
    (\(bs', ss) (x, s) -> do
        (a, ss') <- select conv sub deref s ss
        pure ((x, a) : bs', ss')
    )
    ([], selections)