diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2017-12-20 15:29:54 +0100 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2017-12-20 15:29:54 +0100 |
commit | fc9bdae87b05d1d1c99265ec8b370b37422b01d4 (patch) | |
tree | 546cb2afe43225919a89897b823cfc36b5e4f3e1 /edit-lens/src/Control/Edit/Container/Transducer.lhs | |
parent | afc34d76c845f1be96818addcffb4f70d9d2ea9d (diff) | |
download | incremental-dfsts-fc9bdae87b05d1d1c99265ec8b370b37422b01d4.tar incremental-dfsts-fc9bdae87b05d1d1c99265ec8b370b37422b01d4.tar.gz incremental-dfsts-fc9bdae87b05d1d1c99265ec8b370b37422b01d4.tar.bz2 incremental-dfsts-fc9bdae87b05d1d1c99265ec8b370b37422b01d4.tar.xz incremental-dfsts-fc9bdae87b05d1d1c99265ec8b370b37422b01d4.zip |
Work on container transducers
Diffstat (limited to 'edit-lens/src/Control/Edit/Container/Transducer.lhs')
-rw-r--r-- | edit-lens/src/Control/Edit/Container/Transducer.lhs | 63 |
1 files changed, 63 insertions, 0 deletions
diff --git a/edit-lens/src/Control/Edit/Container/Transducer.lhs b/edit-lens/src/Control/Edit/Container/Transducer.lhs new file mode 100644 index 0000000..0173cc4 --- /dev/null +++ b/edit-lens/src/Control/Edit/Container/Transducer.lhs | |||
@@ -0,0 +1,63 @@ | |||
1 | \begin{code} | ||
2 | {-# LANGUAGE TemplateHaskell #-} | ||
3 | |||
4 | module Control.Edit.Container.Transducer | ||
5 | ( ContainerTransducer{..}, ctStates | ||
6 | , runCT, stepCT | ||
7 | ) where | ||
8 | |||
9 | import Control.Edit.Container | ||
10 | import Data.Map.Strict (Map, (!?)) | ||
11 | import qualified Data.Map.Strict as Map | ||
12 | import Data.Set (Set) | ||
13 | import qualified Data.Set as Set | ||
14 | |||
15 | import Control.Monad.RWS.Strict | ||
16 | |||
17 | import Control.Monad.Writer.Class | ||
18 | import Control.Monad.Reader.Class | ||
19 | import Control.Monad.State.Class | ||
20 | |||
21 | import Control.Lens | ||
22 | |||
23 | import Data.Maybe | ||
24 | |||
25 | |||
26 | data ContainerTransducer state input output = ContainerTransducer | ||
27 | { ctInitialState :: state | ||
28 | , ctTransition :: Map (state, Content input) (ContainerEdits output, state) | ||
29 | -- ^ States are stable (and produce no output) by default | ||
30 | } | ||
31 | |||
32 | ctStates :: Ord state => ContainerTransducer state input output -> Set state | ||
33 | ctStates ContainerTransducer{..} = Map.foldrWithKey' (\(s1, _) (_, s2) -> Set.insert s1 . Set.insert s2) (Set.singleton ctInitialState) ctTransition | ||
34 | |||
35 | stepCT :: ( Ord state, Ord (Content input) | ||
36 | , MonadReader (ContainerTransducer state input output) m | ||
37 | , MonadState state m | ||
38 | , MonadWriter (ContainerEdits output) m | ||
39 | ) => Content input -> m () | ||
40 | stepCT x = do | ||
41 | ContainerTransducer{ ctTransition } <- ask | ||
42 | state <- get | ||
43 | let (output, newState) = fromMaybe (mempty, state) $ ctTransition !? (state, x) | ||
44 | put newState | ||
45 | tell output | ||
46 | |||
47 | runCT :: ( Ord state, Ord (Content input) | ||
48 | , FoldableContainer input | ||
49 | ) => ContainerTransducer state input output | ||
50 | -> input | ||
51 | -> ContainerEdits output | ||
52 | runCT ct@ContainerTransducer{ ctInitialState } input = runRWS (forMOf_ containerContent input stepCT) ct ctInitialState ^. _3 | ||
53 | \end{code} | ||
54 | |||
55 | \begin{code} | ||
56 | |||
57 | data CTComplement state input output = CTComplement | ||
58 | { | ||
59 | } | ||
60 | |||
61 | -- Define edit-lens as span | ||
62 | |||
63 | \end{code} | ||