~jojo/Carth: src/Selections.hs - sourcehut git


                                                                                
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
{-# LANGUAGE LambdaCase, TupleSections #-}

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

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

import Misc
import Optimized


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)