diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index c50180af8..230586482 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -119,11 +119,11 @@ 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 - Catch :: HasCallStack => a -> (Error grammar -> a) -> AssignmentF ast grammar a + Catch :: HasCallStack => Assignment ast grammar a -> (Error grammar -> Assignment ast grammar a) -> AssignmentF ast grammar a -- | Zero-width production of the current location. -- @@ -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,20 +288,21 @@ 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 - Catch during handler -> yield during state `catchError` (flip yield state . handler) + Catch during handler -> (go during state `catchError` (flip go state . handler)) >>= uncurry yield _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node) 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,15 +344,29 @@ 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 - a <|> b | Just c <- (liftA2 (<>) `on` choices) a b = Choose c `Then` identity - | otherwise = wrap $ Alt a b + (Throw err `Then` continue) <|> _ = Throw err `Then` continue + (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 (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 (Many rule `Then` continue) = fmap (const (Many rule `Then` continue)) <$> choices rule + choices (Choose choices _ `Then` continue) = Just (continue <$> choices) + choices (Many rule `Then` continue) = ((Many rule `Then` continue) <$) <$> choices rule + choices (Catch during handler `Then` continue) = ((Catch during handler `Then` continue) <$) <$> choices during + choices (Throw _ `Then` _) = Just IntMap.empty + choices (Return _) = Just IntMap.empty 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 (Catch during handler `Then` continue) = Just (Catch during handler `Then` continue) + atEnd (Throw err `Then` continue) = Just (Throw err `Then` continue) + atEnd (Return a) = Just (Return a) + atEnd _ = Nothing many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] many a = Many a `Then` return @@ -361,15 +376,15 @@ 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 - Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler + Catch during handler -> showsBinaryWith (liftShowsPrec sp sl) (const (const (showChar '_'))) "Catch" d during handler instance MonadError (Error grammar) (Assignment ast grammar) where throwError :: HasCallStack => Error grammar -> Assignment ast grammar a throwError error = withFrozenCallStack $ Throw error `Then` return catchError :: HasCallStack => Assignment ast grammar a -> (Error grammar -> Assignment ast grammar a) -> Assignment ast grammar a - catchError during handler = withFrozenCallStack $ Catch during handler `Then` identity + catchError during handler = withFrozenCallStack $ Catch during handler `Then` return diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 5f407290c..670a6b684 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -36,6 +36,81 @@ spec = do `shouldBe` Right [Out "hello"] + it "distributes through overlapping committed choices, matching the left alternative" $ + fst <$> runAssignment headF "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]]) + `shouldBe` + Right (Out "(green)") + + it "distributes through overlapping committed choices, matching the right alternative" $ + fst <$> runAssignment headF "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]]) + `shouldBe` + Right (Out "(blue)") + + it "distributes through overlapping committed choices, matching the left alternatives" $ + fst <$> runAssignment headF "magenta green green" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Green 8 13 [], node Green 14 19 []]) + `shouldBe` + Right [Out "green", Out "green"] + + it "distributes through overlapping committed choices, matching the right alternatives" $ + fst <$> runAssignment headF "magenta blue blue" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Blue 8 12 [], node Blue 13 17 []]) + `shouldBe` + Right [Out "blue", Out "blue"] + + it "distributes through overlapping committed choices, matching the empty list" $ + fst <$> runAssignment headF "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []]) + `shouldBe` + Right (Left []) + + it "distributes through overlapping committed choices, dropping anonymous nodes & matching the left alternative" $ + fst <$> runAssignment headF "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []]) + `shouldBe` + Right (Out "green") + + it "distributes through overlapping committed choices, dropping anonymous nodes & matching the right alternative" $ + fst <$> runAssignment headF "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []]) + `shouldBe` + Right (Out "blue") + + it "alternates repetitions, matching the left alternative" $ + fst <$> runAssignment headF "green green" (many green <|> many blue) (makeState [node Green 0 5 [], node Green 6 11 []]) + `shouldBe` + Right [Out "green", Out "green"] + + it "alternates repetitions, matching the right alternative" $ + fst <$> runAssignment headF "blue blue" (many green <|> many blue) (makeState [node Blue 0 4 [], node Blue 5 9 []]) + `shouldBe` + Right [Out "blue", Out "blue"] + + it "alternates repetitions, matching at the end of input" $ + fst <$> runAssignment headF "" (many green <|> many blue) (makeState []) + `shouldBe` + Right [] + + it "distributes through children rules" $ + fst <$> runAssignment headF "(red (blue))" (children (many green) <|> children (many blue)) (makeState [node Red 0 12 [node Blue 5 11 []]]) + `shouldBe` + Right [Out "(blue)"] + + it "matches rules to the left of pure" $ + fst <$> runAssignment headF "green" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Green 0 5 []]) + `shouldBe` + Right (Out "green") + + it "matches rules to the right of pure" $ + fst <$> runAssignment headF "blue" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Blue 0 4 []]) + `shouldBe` + Right (Out "blue") + + it "matches other nodes with pure" $ + fst <$> runAssignment headF "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Red 0 3 []]) + `shouldBe` + Right (Out "other") + + it "matches at end with pure" $ + fst <$> runAssignment headF "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState []) + `shouldBe` + Right (Out "other") + describe "symbol" $ do it "matches nodes with the same symbol" $ fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello")