-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt -- | Utilities to modify events in tracks. module Cmd.ModifyEvents where import qualified Data.Either as Either import qualified Data.IntMap as IntMap import qualified Data.List as List import qualified Data.String as String import qualified Data.Text as Text import qualified Util.Lists as Lists import qualified Cmd.Cmd as Cmd import qualified Cmd.Selection as Selection import qualified Derive.Parse as Parse import qualified Derive.ParseTitle as ParseTitle import qualified Ui.Block as Block import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.Sel as Sel import qualified Ui.Ui as Ui import Global import Types -- | Map a function over multiple tracks. It has access to all selected -- events. Omit a TrackId from the output to leave it unchanged. type Tracks m = BlockId -> [(TrackId, [Event.Event])] -> m [(TrackId, [Event.Event])] -- | Map a function over events on a certain track. Returning Nothing will -- leave the track unchanged. type Track m = BlockId -> TrackId -> [Event.Event] -> m (Maybe [Event.Event]) -- | Map a Track transformer over multiple tracks. track :: Monad m => Track m -> Tracks m track :: forall (m :: * -> *). Monad m => Track m -> Tracks m track Track m modify = \BlockId block_id [(TrackId, [Event])] track_events -> do [Maybe [Event]] outs <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry (Track m modify BlockId block_id)) [(TrackId, [Event])] track_events forall (m :: * -> *) a. Monad m => a -> m a return [ (TrackId track_id, [Event] events) | (TrackId track_id, Just [Event] events) <- forall a b. [a] -> [b] -> [(a, b)] zip (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(TrackId, [Event])] track_events) [Maybe [Event]] outs ] -- | Map a function over a set of events. events :: Monad m => ([Event.Event] -> m [Event.Event]) -> Track m events :: forall (m :: * -> *). Monad m => ([Event] -> m [Event]) -> Track m events [Event] -> m [Event] f BlockId _ TrackId _ = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . [Event] -> m [Event] f -- | Map a function over a single event. event :: Monad m => (Event.Event -> Event.Event) -> Track m event :: forall (m :: * -> *). Monad m => (Event -> Event) -> Track m event Event -> Event f = forall (m :: * -> *). Monad m => ([Event] -> m [Event]) -> Track m events (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Event -> Event f) text :: Monad m => (Text -> Text) -> Track m text :: forall (m :: * -> *). Monad m => (Token -> Token) -> Track m text = forall (m :: * -> *). Monad m => (Event -> Event) -> Track m event forall b c a. (b -> c) -> (a -> b) -> a -> c . (\Token -> Token f -> Lens Event Token Event.text_ forall f a. Lens f a -> (a -> a) -> f -> f %= Token -> Token f) -- | Split up a pipeline and lex the calls. pipeline :: ([[Text]] -> [[Text]]) -> Text -> Text pipeline :: ([[Token]] -> [[Token]]) -> Token -> Token pipeline [[Token]] -> [[Token]] modify = [[Token]] -> Token Parse.join_pipeline forall b c a. (b -> c) -> (a -> b) -> a -> c . [[Token]] -> [[Token]] modify forall b c a. (b -> c) -> (a -> b) -> a -> c . Token -> [[Token]] Parse.split_pipeline -- | Take a text transformation that can fail to a Track transformation that -- transforms all the events and throws if any of the text transformations -- failed. failable_text :: Cmd.M m => (Text -> Either Text Text) -> Track m failable_text :: forall (m :: * -> *). M m => (Token -> Either Token Token) -> Track m failable_text Token -> Either Token Token f BlockId block_id TrackId track_id [Event] events = do let ([(Token, Event)] failed, [Event] ok) = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall {a}. (Token -> Either a Token) -> Event -> Either (a, Event) Event failing_text Token -> Either Token Token f) [Event] events errs :: [Token] errs = [Token err forall a. Semigroup a => a -> a -> a <> Token ": " forall a. Semigroup a => a -> a -> a <> BlockId -> TrackId -> Event -> Token Cmd.log_event BlockId block_id TrackId track_id Event evt | (Token err, Event evt) <- [(Token, Event)] failed] forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [Token] errs) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (Stack, M m) => Token -> m a Cmd.throw forall a b. (a -> b) -> a -> b $ Token "transformation failed: " forall a. Semigroup a => a -> a -> a <> Token -> [Token] -> Token Text.intercalate Token ", " [Token] errs forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just [Event] ok where failing_text :: (Token -> Either a Token) -> Event -> Either (a, Event) Event failing_text Token -> Either a Token f Event event = case Token -> Either a Token f (Event -> Token Event.text Event event) of Left a err -> forall a b. a -> Either a b Left (a err, Event event) Right Token text -> forall a b. b -> Either a b Right forall a b. (a -> b) -> a -> b $ Lens Event Token Event.text_ forall f a. Lens f a -> a -> f -> f #= Token text forall a b. (a -> b) -> a -> b $ Event event -- * modify selections selection_tracks :: Cmd.M m => Tracks m -> m () selection_tracks :: forall (m :: * -> *). M m => Tracks m -> m () selection_tracks Tracks m modify = forall (m :: * -> *). M m => Collapsed -> Tracks m -> [(TrackId, [Event])] -> m () modify_selected Collapsed IncludeCollapsed Tracks m modify forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m [(TrackId, [Event])] Selection.events -- | Map a function over the selected events, as per 'Selection.events'. selection :: Cmd.M m => Track m -> m () selection :: forall (m :: * -> *). M m => Track m -> m () selection Track m modify = forall (m :: * -> *). M m => Collapsed -> Tracks m -> [(TrackId, [Event])] -> m () modify_selected Collapsed IncludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m track Track m modify) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m [(TrackId, [Event])] Selection.events -- | Like 'selection', but don't apply to collapsed tracks. This is -- appropriate for operations that often apply to note tracks. If you select -- multiple note tracks, then the intervening collapsed pitch tracks will also -- be selected and if you accidentally modify those you won't see the -- modifications. selection_visible :: Cmd.M m => Track m -> m () selection_visible :: forall (m :: * -> *). M m => Track m -> m () selection_visible Track m modify = forall (m :: * -> *). M m => Track m -> Context -> m () ctx_selection_visible Track m modify forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m Context Selection.context ctx_selection_visible :: Ui.M m => Track m -> Selection.Context -> m () ctx_selection_visible :: forall (m :: * -> *). M m => Track m -> Context -> m () ctx_selection_visible Track m modify Context ctx = forall (m :: * -> *). M m => Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m () modify_selected_block Collapsed ExcludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m track Track m modify) (Context -> BlockId Selection.ctx_block_id Context ctx) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => Context -> m [(TrackId, [Event])] Selection.ctx_events Context ctx -- | Like 'selection', but only operate on the 'Selection.point_track'. selected_track :: Cmd.M m => Track m -> m () selected_track :: forall (m :: * -> *). M m => Track m -> m () selected_track Track m modify = forall (m :: * -> *). M m => Collapsed -> Tracks m -> [(TrackId, [Event])] -> m () modify_selected Collapsed ExcludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m track Track m modify) forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. a -> [a] -> [a] :[]) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m (TrackId, [Event]) Selection.track_events -- Don't affect collapsed tracks because why would the point selection be -- on one of those? data Collapsed = ExcludeCollapsed | IncludeCollapsed deriving (Int -> Collapsed -> ShowS [Collapsed] -> ShowS Collapsed -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Collapsed] -> ShowS $cshowList :: [Collapsed] -> ShowS show :: Collapsed -> String $cshow :: Collapsed -> String showsPrec :: Int -> Collapsed -> ShowS $cshowsPrec :: Int -> Collapsed -> ShowS Show, Collapsed -> Collapsed -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Collapsed -> Collapsed -> Bool $c/= :: Collapsed -> Collapsed -> Bool == :: Collapsed -> Collapsed -> Bool $c== :: Collapsed -> Collapsed -> Bool Eq) modify_selected :: Cmd.M m => Collapsed -> Tracks m -> Selection.SelectedEvents -> m () modify_selected :: forall (m :: * -> *). M m => Collapsed -> Tracks m -> [(TrackId, [Event])] -> m () modify_selected Collapsed collapsed Tracks m modify [(TrackId, [Event])] selected = do BlockId block_id <- forall (m :: * -> *). M m => m BlockId Cmd.get_focused_block forall (m :: * -> *). M m => Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m () modify_selected_block Collapsed collapsed Tracks m modify BlockId block_id [(TrackId, [Event])] selected -- It would be nice to make this a ctx_ function, but modify_selected is called -- with different selections. modify_selected_block :: Ui.M m => Collapsed -> Tracks m -> BlockId -> Selection.SelectedEvents -> m () modify_selected_block :: forall (m :: * -> *). M m => Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m () modify_selected_block Collapsed collapsed Tracks m modify BlockId block_id [(TrackId, [Event])] selected = do [(TrackId, [Event])] selected <- forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterM (forall {m :: * -> *}. M m => TrackId -> m Bool wanted forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) [(TrackId, [Event])] selected [(TrackId, [Event])] new <- Tracks m modify BlockId block_id [(TrackId, [Event])] selected forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(TrackId, [Event])] new forall a b. (a -> b) -> a -> b $ \(TrackId track_id, [Event] new_events) -> do let events :: [Event] events = forall a. a -> Maybe a -> a fromMaybe [] forall a b. (a -> b) -> a -> b $ forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup TrackId track_id [(TrackId, [Event])] selected forall (m :: * -> *). M m => TrackId -> [Event] -> m () Ui.remove_events TrackId track_id [Event] events forall (m :: * -> *). M m => BlockId -> TrackId -> [Event] -> m () Ui.insert_block_events BlockId block_id TrackId track_id [Event] new_events where wanted :: TrackId -> m Bool wanted TrackId track_id = case Collapsed collapsed of Collapsed IncludeCollapsed -> forall (m :: * -> *) a. Monad m => a -> m a return Bool True Collapsed ExcludeCollapsed -> do Int tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m Int Ui.get_tracknum_of BlockId block_id TrackId track_id Bool -> Bool not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> Int -> m Bool Ui.track_collapsed BlockId block_id Int tracknum -- | Advance the selection if it was a point. This is convenient for applying -- a transformation repeatedly. advance_if_point :: Cmd.M m => m () advance_if_point :: forall (m :: * -> *). M m => m () advance_if_point = forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM (Selection -> Bool Sel.is_point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => m Selection Selection.get) forall (m :: * -> *). M m => m () Selection.advance -- | Map a function over the events that overlap the selection point. overlapping :: Cmd.M m => Track m -> m () overlapping :: forall (m :: * -> *). M m => Track m -> m () overlapping Track m f = do (BlockId block_id, [Int] _, [TrackId] track_ids, Range _) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range) Selection.tracks TrackTime pos <- forall (m :: * -> *). M m => m TrackTime Selection.point forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [TrackId] track_ids forall a b. (a -> b) -> a -> b $ \TrackId track_id -> do Maybe Event maybe_event <- TrackTime -> Events -> Maybe Event Events.overlapping TrackTime pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events TrackId track_id forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Maybe Event maybe_event forall a b. (a -> b) -> a -> b $ \Event old_event -> forall (m :: * -> *) a. Monad m => m (Maybe a) -> (a -> m ()) -> m () whenJustM (Track m f BlockId block_id TrackId track_id [Event old_event]) forall a b. (a -> b) -> a -> b $ \[Event] new_events -> do forall (m :: * -> *). M m => TrackId -> Event -> m () Ui.remove_event TrackId track_id Event old_event forall (m :: * -> *). M m => BlockId -> TrackId -> [Event] -> m () Ui.insert_block_events BlockId block_id TrackId track_id [Event] new_events -- | Map over tracks whose name matches the predicate. tracks_named :: Cmd.M m => (Text -> Bool) -> Track m -> Track m tracks_named :: forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m tracks_named Token -> Bool wanted Track m f = \BlockId block_id TrackId track_id [Event] events -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM (Token -> Bool wanted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => TrackId -> m Token Ui.get_track_title TrackId track_id) (Track m f BlockId block_id TrackId track_id [Event] events) (forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing) selected_note :: Cmd.M m => Track m -> m () selected_note :: forall (m :: * -> *). M m => Track m -> m () selected_note = forall (m :: * -> *). M m => Track m -> m () selection forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m tracks_named Token -> Bool ParseTitle.is_note_track selected_control :: Cmd.M m => Track m -> m () selected_control :: forall (m :: * -> *). M m => Track m -> m () selected_control = forall (m :: * -> *). M m => Track m -> m () selection forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m tracks_named Token -> Bool ParseTitle.is_signal_track selected_pitch :: Cmd.M m => Track m -> m () selected_pitch :: forall (m :: * -> *). M m => Track m -> m () selected_pitch = forall (m :: * -> *). M m => Track m -> m () selection forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m tracks_named Token -> Bool ParseTitle.is_pitch_track -- * block tracks -- | Like 'selection', but maps over an entire block. block :: Cmd.M m => BlockId -> Track m -> m () block :: forall (m :: * -> *). M m => BlockId -> Track m -> m () block BlockId block_id Track m f = do [TrackId] track_ids <- Block -> [TrackId] Block.block_track_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [TrackId] track_ids forall a b. (a -> b) -> a -> b $ \TrackId track_id -> do [Event] events <- Events -> [Event] Events.ascending forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events TrackId track_id forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return ()) (forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m () Ui.modify_events TrackId track_id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> b -> a const forall b c a. (b -> c) -> (a -> b) -> a -> c . [Event] -> Events Events.from_list) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Track m f BlockId block_id TrackId track_id [Event] events all_blocks :: Cmd.M m => Track m -> m () all_blocks :: forall (m :: * -> *). M m => Track m -> m () all_blocks Track m f = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c flip forall (m :: * -> *). M m => BlockId -> Track m -> m () block Track m f) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m [BlockId] Ui.all_block_ids all_tracks_named :: Cmd.M m => (Text -> Bool) -> Track m -> m () all_tracks_named :: forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m () all_tracks_named Token -> Bool wanted = forall (m :: * -> *). M m => Track m -> m () all_blocks forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m tracks_named Token -> Bool wanted note_tracks :: Cmd.M m => Track m -> m () note_tracks :: forall (m :: * -> *). M m => Track m -> m () note_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m () all_tracks_named Token -> Bool ParseTitle.is_note_track control_tracks :: Cmd.M m => Track m -> m () control_tracks :: forall (m :: * -> *). M m => Track m -> m () control_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m () all_tracks_named Token -> Bool ParseTitle.is_control_track pitch_tracks :: Cmd.M m => Track m -> m () pitch_tracks :: forall (m :: * -> *). M m => Track m -> m () pitch_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m () all_tracks_named Token -> Bool ParseTitle.is_pitch_track -- * misc -- | Move everything at or after @start@ by @shift@. move_track_events :: Ui.M m => ScoreTime -> ScoreTime -> ScoreTime -> TrackId -> m () move_track_events :: forall (m :: * -> *). M m => TrackTime -> TrackTime -> TrackTime -> TrackId -> m () move_track_events TrackTime block_end TrackTime start TrackTime shift TrackId track_id = forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m () Ui.modify_events TrackId track_id forall a b. (a -> b) -> a -> b $ \Events events -> TrackTime -> TrackTime -> TrackTime -> Events -> Events move_events TrackTime block_end TrackTime start TrackTime shift Events events -- | All events starting at and after a point to the end are shifted by the -- given amount. move_events :: ScoreTime -- ^ events past the block end are shortened or removed -> ScoreTime -> ScoreTime -> Events.Events -> Events.Events move_events :: TrackTime -> TrackTime -> TrackTime -> Events -> Events move_events TrackTime block_end TrackTime point TrackTime shift Events events = Events merged where shifted :: [Event] shifted = Bool -> TrackTime -> [Event] -> [Event] Events.clip_list Bool False TrackTime block_end forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Lens Event TrackTime Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f %= (forall a. Num a => a -> a -> a +TrackTime shift)) (TrackTime -> Events -> [Event] Events.at_after TrackTime point Events events) -- +1 in case the last event is +0 duration. merged :: Events merged = [Event] -> Events -> Events Events.insert [Event] shifted forall a b. (a -> b) -> a -> b $ Range -> Events -> Events Events.remove (TrackTime -> TrackTime -> Range Events.Range TrackTime point (Events -> TrackTime Events.time_end Events events forall a. Num a => a -> a -> a + TrackTime 1)) Events events -- * replace tokens data Replacement = RLiteral !Text -- ^ literal text | F !Int -- ^ field from match deriving (Replacement -> Replacement -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Replacement -> Replacement -> Bool $c/= :: Replacement -> Replacement -> Bool == :: Replacement -> Replacement -> Bool $c== :: Replacement -> Replacement -> Bool Eq, Int -> Replacement -> ShowS [Replacement] -> ShowS Replacement -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Replacement] -> ShowS $cshowList :: [Replacement] -> ShowS show :: Replacement -> String $cshow :: Replacement -> String showsPrec :: Int -> Replacement -> ShowS $cshowsPrec :: Int -> Replacement -> ShowS Show) instance String.IsString Replacement where fromString :: String -> Replacement fromString = Token -> Replacement RLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Token txt -- | Regex-like substitution on tracklang tokens. -- -- Short names and IsString instances attempt to make it concise enough for -- inline use. If the pattern doesn't match, the input is returned unchanged. substitute :: Parser -> [Replacement] -> Text -> Either Text Text substitute :: Parser -> [Replacement] -> Token -> Either Token Token substitute Parser parser [Replacement] replacements Token text = case Maybe (IntMap Token) match of Maybe (IntMap Token) Nothing -> forall a b. b -> Either a b Right Token text Just IntMap Token matches -> [Token] -> Token Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . Token -> Bool Text.null) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (IntMap Token -> Replacement -> Either Token Token replace IntMap Token matches) [Replacement] replacements where match :: Maybe (IntMap Token) match = forall a. [(Int, a)] -> IntMap a IntMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser -> Token -> Maybe [Token] parse_tokens Parser parser Token text replace :: IntMap Token -> Replacement -> Either Token Token replace IntMap Token matches Replacement r = case Replacement r of RLiteral Token text -> forall a b. b -> Either a b Right Token text F Int n -> forall err a. err -> Maybe a -> Either err a justErr (Token "no match for field " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Token showt Int n) forall a b. (a -> b) -> a -> b $ forall a. Int -> IntMap a -> Maybe a IntMap.lookup Int n IntMap Token matches -- ** parser -- | Yet another \"list of successes\" style parser. newtype Parser = Parser ([Token] -> [([Match], [Token])]) type Token = Text type Match = [Token] parse_tokens :: Parser -> Text -> Maybe [Text] parse_tokens :: Parser -> Token -> Maybe [Token] parse_tokens Parser parser = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. (a -> b) -> [a] -> [b] map [Token] -> Token Text.unwords) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . Parser -> [Token] -> [[[Token]]] parse Parser parser forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Token -> Token Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c . Token -> [Token] Parse.lex parse :: Parser -> [Token] -> [[Match]] parse :: Parser -> [Token] -> [[[Token]]] parse (Parser [Token] -> [([[Token]], [Token])] p) = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter (forall (t :: * -> *) a. Foldable t => t a -> Bool null forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall b c a. (b -> c) -> (a -> b) -> a -> c . [Token] -> [([[Token]], [Token])] p instance Semigroup Parser where Parser [Token] -> [([[Token]], [Token])] p1 <> :: Parser -> Parser -> Parser <> Parser [Token] -> [([[Token]], [Token])] p2 = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> do ([[Token]] matches1, [Token] rest1) <- [Token] -> [([[Token]], [Token])] p1 [Token] tokens ([[Token]] matches2, [Token] rest2) <- [Token] -> [([[Token]], [Token])] p2 [Token] rest1 forall (m :: * -> *) a. Monad m => a -> m a return ([[Token]] matches1 forall a. [a] -> [a] -> [a] ++ [[Token]] matches2, [Token] rest2) instance Monoid Parser where mempty :: Parser mempty = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> [([], [Token] tokens)] mappend :: Parser -> Parser -> Parser mappend = forall a. Semigroup a => a -> a -> a (<>) instance String.IsString Parser where fromString :: String -> Parser fromString = Token -> Parser literal forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Token txt -- | Match a literal token. literal :: Text -> Parser literal :: Token -> Parser literal Token token = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> case [Token] tokens of Token t : [Token] ts | Token t forall a. Eq a => a -> a -> Bool == Token token -> [([], [Token] ts)] | Bool otherwise -> [] [] -> [] -- | Match one token. w :: Parser w :: Parser w = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> case [Token] tokens of Token t : [Token] ts -> [([[Token t]], [Token] ts)] [] -> [] -- | Match 0 or more tokens. ws :: Parser ws :: Parser ws = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> [([[Token] pre], [Token] post) | ([Token] pre, [Token] post) <- forall a. [a] -> [a] reverse forall a b. (a -> b) -> a -> b $ forall a. [a] -> [([a], [a])] splits [Token] tokens] -- | Match 1 or more tokens. ws1 :: Parser ws1 :: Parser ws1 = ([Token] -> [([[Token]], [Token])]) -> Parser Parser forall a b. (a -> b) -> a -> b $ \[Token] tokens -> [([[Token] pre], [Token] post) | ([Token] pre, [Token] post) <- forall a. [a] -> [a] reverse forall a b. (a -> b) -> a -> b $ forall a. Int -> [a] -> [a] drop Int 1 forall a b. (a -> b) -> a -> b $ forall a. [a] -> [([a], [a])] splits [Token] tokens] splits :: [a] -> [([a], [a])] splits :: forall a. [a] -> [([a], [a])] splits [a] xs = forall a b. [a] -> [b] -> [(a, b)] zip (forall a. [a] -> [[a]] List.inits [a] xs) (forall a. [a] -> [[a]] List.tails [a] xs)