github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-20 21:31:48 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1257 from github/distribute-alternation-through-binds-and-overlapping-committed-choices

Browse Source 
Distribute alternation through binds and overlapping committed choices
This commit is contained in:
Rob Rix 2017-07-27 22:05:43 -04:00 committed by GitHub
commit 9ab8025ee7
2 changed files with 104 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
src/Data/Syntax/Assignment.hs
View File

@ -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

75
test/Data/Syntax/Assignment/Spec.hs
View File

@ -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")