diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index ded684dfc..37ad9c3ba 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -119,7 +119,7 @@ data AssignmentF ast grammar a where Project :: HasCallStack => (forall x. Base ast x -> a) -> AssignmentF ast grammar a Source :: HasCallStack => AssignmentF ast grammar ByteString Children :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar a - Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF ast grammar a + Choose :: HasCallStack => IntMap.IntMap a -> Maybe a -> AssignmentF ast grammar a Many :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar [a] Alt :: HasCallStack => a -> a -> AssignmentF ast grammar a Throw :: HasCallStack => Error grammar -> AssignmentF ast grammar a @@ -141,7 +141,7 @@ project projection = Project projection `Then` return -- -- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. @many (symbol A *> b)@ is fine, but @many (symbol A)@ is not. symbol :: (Enum grammar, Eq grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location) -symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location) +symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) Nothing `Then` (const location) -- | A rule to produce a node’s source as a ByteString. source :: HasCallStack => Assignment ast grammar ByteString @@ -288,11 +288,12 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req Children child -> do (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) - Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state + Choose choices _ | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state _ -> anywhere (Just node) anywhere node = case assignment of Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state + Choose _ (Just atEnd) -> yield atEnd state Many rule -> uncurry yield (runMany rule state) Alt a b -> yield a state `catchError` (\ err -> yield b state { stateError = Just err }) Throw e -> Left e @@ -301,7 +302,7 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState - expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices + expectedSymbols | Choose choices _ <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices | otherwise = [] runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) @@ -343,18 +344,22 @@ makeState = State 0 (Info.Pos 1 1) Nothing 0 instance Enum grammar => Alternative (Assignment ast grammar) where empty :: HasCallStack => Assignment ast grammar a - empty = Choose mempty `Then` return + empty = Choose mempty Nothing `Then` return (<|>) :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a Return a <|> _ = Return a (Children l `Then` continueL) <|> (Children r `Then` continueR) = Children (Left <$> l <|> Right <$> r) `Then` either continueL continueR (Location `Then` continueL) <|> (Location `Then` continueR) = Location `Then` uncurry (<|>) . (continueL &&& continueR) (Source `Then` continueL) <|> (Source `Then` continueR) = Source `Then` uncurry (<|>) . (continueL &&& continueR) - l <|> r | Just c <- (liftA2 (IntMap.unionWith (<|>)) `on` choices) l r = Choose c `Then` identity + l <|> r | Just c <- (liftA2 (IntMap.unionWith (<|>)) `on` choices) l r = Choose c (atEnd l <|> atEnd r) `Then` identity | otherwise = wrap $ Alt l r where choices :: Assignment ast grammar a -> Maybe (IntMap (Assignment ast grammar a)) - choices (Choose choices `Then` continue) = Just (continue <$> choices) + choices (Choose choices _ `Then` continue) = Just (continue <$> choices) choices (Many rule `Then` continue) = ((Many rule `Then` continue) <$) <$> choices rule choices _ = Nothing + atEnd :: Assignment ast grammar a -> Maybe (Assignment ast grammar a) + atEnd (Choose _ atEnd `Then` continue) = continue <$> atEnd + atEnd (Many rule `Then` continue) = Just (Many rule `Then` continue) + atEnd _ = Nothing many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] many a = Many a `Then` return @@ -364,7 +369,7 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where Project projection -> showsUnaryWith (const (const (showChar '_'))) "Project" d projection Source -> showString "Source" . showChar ' ' . sp d "" Children a -> showsUnaryWith (liftShowsPrec sp sl) "Children" d a - Choose choices -> showsUnaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) "Choose" d (IntMap.toList choices) + Choose choices atEnd -> showsBinaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) (liftShowsPrec sp sl) "Choose" d (IntMap.toList choices) atEnd Many a -> showsUnaryWith (liftShowsPrec (\ d a -> sp d [a]) (sl . pure)) "Many" d a Alt a b -> showsBinaryWith sp sp "Alt" d a b Throw e -> showsUnaryWith showsPrec "Throw" d e