github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 09:55:52 +03:00
Code Issues Projects Releases Wiki Activity

Disambiguate assignment results.

Browse Source
This commit is contained in:
Rob Rix 2017-08-04 09:11:22 -04:00
parent 7bd2d6b94b
commit 0a8411e534
3 changed files with 56 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -106,6 +106,7 @@ import qualified Data.IntMap.Lazy as IntMap
import Data.Ix (inRange)
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import Data.Maybe
import Data.Ord (comparing)
import Data.Record
import Data.Semigroup
import qualified Data.Source as Source (Source, fromBytes, slice, sourceBytes, sourceLines)
@ -246,17 +247,17 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (
-> Source.Source -- ^ The source for the parse tree.
-> Assignment ast grammar a -- ^ The 'Assignment to run.
-> ast -- ^ The root of the ast.
-> Amb (Error grammar) a -- ^ Either an 'Error' or a 'NonEmpty' list of assigned values.
-> Either (Error grammar) a -- ^ 'Either' an 'Error' or a 'NonEmpty' list of assigned values.
assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure
-- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively.
runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast))
=> (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
-> Source.Source -- ^ The source for the parse tree.
-> Assignment ast grammar a -- ^ The 'Assignment' to run.
-> State ast grammar -- ^ The current state.
-> Amb (Error grammar) (a, State ast grammar) -- ^ Either an 'Error' or a 'NonEmpty' list of assigned values & updated states.
runAssignment toNode source = (\ assignment state -> go assignment state >>= requireExhaustive)
=> (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
-> Source.Source -- ^ The source for the parse tree.
-> Assignment ast grammar a -- ^ The 'Assignment' to run.
-> State ast grammar -- ^ The current state.
-> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or a 'NonEmpty' list of assigned values & updated states.
runAssignment toNode source = (\ assignment state -> disamb Left (Right . minimumBy (comparing (stateErrorCounter . snd))) (go assignment state >>= requireExhaustive))
-- Note: We explicitly bind toNode & source above in order to ensure that the where clause can close over them; they don’t change through the course of the run, so holding one reference is sufficient. On the other hand, we don’t want to accidentally capture the assignment and state in the where clause, since they change at every step—and capturing when you meant to shadow is an easy mistake to make, & results in hard-to-debug errors. Binding them in a lambda avoids that problem while also being easier to follow than a pointfree definition.
where go :: Assignment ast grammar result -> State ast grammar -> Amb (Error grammar) (result, State ast grammar)
go assignment = iterFreer run ((pure .) . (,) <$> assignment)

13
src/Semantic/Task.hs
View File

@ -32,15 +32,11 @@ import Control.Monad.IO.Class
import Control.Parallel.Strategies
import qualified Control.Concurrent.Async as Async
import Control.Monad.Free.Freer
import Data.Amb
import Data.Blob
import qualified Data.ByteString as B
import Data.Foldable (find, fold, for_)
import Data.Foldable (fold, for_)
import Data.Functor.Both as Both hiding (snd)
import Data.Functor.Foldable (cata)
import Data.List (minimumBy)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Record
import Data.Semigroup ((<>))
import Data.Source (totalRange, totalSpan)
@ -200,12 +196,11 @@ runParser Options{..} blob@Blob{..} = go
res <- go parser
case res of
Left err -> writeLog Error "failed parsing" blobFields >> pure (Left err)
Right ast -> logTiming "assign" $ case Assignment.runAssignment by blobSource assignment (Assignment.makeState [ast]) of
None err -> do
Right ast -> logTiming "assign" $ case Assignment.assignBy by blobSource assignment ast of
Left err -> do
writeLog Error (Assignment.formatErrorWithOptions optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) blobFields
pure $ Right (Syntax.makeTerm (totalRange blobSource :. totalSpan blobSource :. Nil) (Syntax.Error (fmap show err) []))
Some terms -> do
let (term, _) = fromMaybe (minimumBy (comparing (Assignment.stateErrorCounter . snd)) terms) (find ((== 0) . Assignment.stateErrorCounter . snd) terms)
Right term -> do
for_ (errors term) $ \ err ->
writeLog Warning (Assignment.formatErrorWithOptions optionsPrintSource optionsEnableColour blob err) blobFields
pure $ Right term

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

@ -3,10 +3,8 @@ module Data.Syntax.Assignment.Spec where
import Control.Comonad.Cofree (Cofree(..))
import Control.Comonad.Trans.Cofree (headF)
import Data.Amb
import Data.Bifunctor (first)
import Data.ByteString.Char8 as B (ByteString, length, words)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup ((<>))
import Data.Source
import Data.Syntax.Assignment
@ -22,13 +20,13 @@ spec = do
it "matches in sequence" $
fst <$> runAssignment headF "helloworld" ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []])
`shouldBe`
Some ((Out "hello", Out "world") :| [])
Right (Out "hello", Out "world")
describe "Alternative" $ do
it "attempts multiple alternatives" $
fst <$> runAssignment headF "hello" (green <|> red) (makeState [node Red 0 5 []])
`shouldBe`
Some ((Out "hello") :| [])
Right (Out "hello")
it "matches repetitions" $
let s = "colourless green ideas sleep furiously"
@ -36,94 +34,94 @@ spec = do
(_, nodes) = foldl (\ (i, prev) word -> (i + B.length word + 1, prev <> [node Red i (i + B.length word) []])) (0, []) w in
fst <$> runAssignment headF (fromBytes s) (many red) (makeState nodes)
`shouldBe`
Some ((Out <$> w) :| [])
Right (Out <$> w)
it "matches one-or-more repetitions against one or more input nodes" $
fst <$> runAssignment headF "hello" (some red) (makeState [node Red 0 5 []])
`shouldBe`
Some ([Out "hello"] :| [])
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`
Some (Out "(green)" :| [])
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`
Some (Out "(blue)" :| [])
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`
Some ([Out "green", Out "green"] :| [])
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`
Some ([Out "blue", Out "blue"] :| [])
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`
Some (Left [] :| [])
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`
Some (Out "green" :| [])
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`
Some (Out "blue" :| [])
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`
Some ([Out "green", Out "green"] :| [])
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`
Some ([Out "blue", Out "blue"] :| [])
Right [Out "blue", Out "blue"]
it "alternates repetitions, matching at the end of input" $
fst <$> runAssignment headF "" (many green <|> many blue) (makeState [])
`shouldBe`
Some ([] :| [])
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`
Some ([Out "(blue)"] :| [])
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`
Some (Out "green" :| [])
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`
Some (Out "blue" :| [])
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`
Some (Out "other" :| [])
Right (Out "other")
it "matches at end with pure" $
fst <$> runAssignment headF "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [])
`shouldBe`
Some (Out "other" :| [])
Right (Out "other")
describe "symbol" $ do
it "matches nodes with the same symbol" $
fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Some (Out "hello" :| [])
fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello")
it "does not advance past the current node" $
runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` None (Error (Info.Pos 1 1) [] (Just Red))
runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) [] (Just Red))
describe "without catchError" $ do
it "assignment returns unexpected symbol error" $
@ -131,14 +129,14 @@ spec = do
red
(makeState [node Green 0 1 []])
`shouldBe`
None (Error (Info.Pos 1 1) [Red] (Just Green))
Left (Error (Info.Pos 1 1) [Red] (Just Green))
it "assignment returns unexpected end of input" $
runAssignment headF "A"
(symbol Green *> children (some red))
(makeState [node Green 0 1 []])
`shouldBe`
None (Error (Info.Pos 1 1) [Red] Nothing)
Left (Error (Info.Pos 1 1) [Red] Nothing)
describe "catchError" $ do
it "handler that always matches" $
@ -146,21 +144,21 @@ spec = do
(red `catchError` (\ _ -> OutError <$ location <*> source))
(makeState [node Green 0 1 []])
`shouldBe`
Some (OutError "A" :| [])
Right (OutError "A")
it "handler that matches" $
fst <$> runAssignment headF "A"
(red `catchError` const green)
(makeState [node Green 0 1 []])
`shouldBe`
Some (Out "A" :| [])
Right (Out "A")
it "handler that doesn't match produces error" $
runAssignment headF "A"
(red `catchError` const blue)
(makeState [node Green 0 1 []])
`shouldBe`
None (Error (Info.Pos 1 1) [Red] (Just Green))
Left (Error (Info.Pos 1 1) [Red] (Just Green))
describe "in many" $ do
it "handler that always matches" $
@ -170,21 +168,21 @@ spec = do
))
(makeState [node Palette 0 1 [node Green 1 2 []]])
`shouldBe`
Some ([OutError "G"] :| [])
Right [OutError "G"]
it "handler that matches" $
fst <$> runAssignment headF "PG"
(symbol Palette *> children ( many (red `catchError` const green) ))
(makeState [node Palette 0 1 [node Green 1 2 []]])
`shouldBe`
Some ([Out "G"] :| [])
Right [Out "G"]
it "handler that doesn't match produces error" $
runAssignment headF "PG"
(symbol Palette *> children ( many (red `catchError` const blue) ))
(makeState [node Palette 0 1 [node Green 1 2 []]])
`shouldBe`
None (Error (Info.Pos 1 2) [] (Just Green))
Left (Error (Info.Pos 1 2) [] (Just Green))
it "handlers defer to later rules" $
fst <$> runAssignment headF "PG"
@ -193,7 +191,7 @@ spec = do
))
(makeState [node Palette 0 1 [node Green 1 2 []]])
`shouldBe`
Some (([], Out "G") :| [])
Right ([], Out "G")
it "handler that doesn't match with apply" $
fst <$> runAssignment headF "PG"
@ -202,7 +200,7 @@ spec = do
))
(makeState [node Palette 0 1 [node Green 1 2 []]])
`shouldBe`
Some (([], Out "G") :| [])
Right ([], Out "G")
describe "many" $ do
it "takes ones and only one zero width repetition" $
@ -210,39 +208,39 @@ spec = do
(symbol Palette *> children ( many (green <|> pure (Out "always")) ))
(makeState [node Palette 0 1 [node Green 1 2 [], node Green 2 3 []]])
`shouldBe`
Some ([Out "G", Out "G", Out "always"] :| [[Out "G", Out "G"]])
Right [Out "G", Out "G", Out "always"]
describe "source" $ do
it "produces the node’s source" $
assignBy headF "hi" source (node Red 0 2 []) `shouldBe` Some ("hi" :| [])
assignBy headF "hi" source (node Red 0 2 []) `shouldBe` Right ("hi")
it "advances past the current node" $
snd <$> runAssignment headF "hi" source (makeState [ node Red 0 2 [] ])
`shouldBe`
Some ((State 2 (Info.Pos 1 3) 0 []) :| [])
Right (State 2 (Info.Pos 1 3) 0 [])
describe "children" $ do
it "advances past the current node" $
snd <$> runAssignment headF "a" (children (pure (Out ""))) (makeState [node Red 0 1 []])
`shouldBe`
Some (State 1 (Info.Pos 1 2) 0 [] :| [])
Right (State 1 (Info.Pos 1 2) 0 [])
it "matches if its subrule matches" $
() <$ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]])
`shouldBe`
Some (() :| [])
Right ()
it "does not match if its subrule does not match" $
runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]])
`shouldBe`
None (Error (Info.Pos 1 1) [Red] (Just Green))
Left (Error (Info.Pos 1 1) [Red] (Just Green))
it "matches nested children" $
fst <$> runAssignment headF "1"
(symbol Red *> children (symbol Green *> children (symbol Blue *> source)))
(makeState [ node Red 0 1 [ node Green 0 1 [ node Blue 0 1 [] ] ] ])
`shouldBe`
Some ("1" :| [])
Right "1"
it "continues after children" $
fst <$> runAssignment headF "BC"
@ -251,7 +249,7 @@ spec = do
(makeState [ node Red 0 1 [ node Green 0 1 [] ]
, node Blue 1 2 [] ])
`shouldBe`
Some (["B", "C"] :| [])
Right ["B", "C"]
it "matches multiple nested children" $
fst <$> runAssignment headF "12"
@ -259,28 +257,28 @@ spec = do
(makeState [ node Red 0 2 [ node Green 0 1 [ node Blue 0 1 [] ]
, node Green 1 2 [ node Blue 1 2 [] ] ] ])
`shouldBe`
Some (["1", "2"] :| [])
Right ["1", "2"]
describe "runAssignment" $ do
it "drops anonymous nodes before matching symbols" $
fst <$> runAssignment headF "magenta red" red (makeState [node Magenta 0 7 [], node Red 8 11 []])
`shouldBe`
Some (Out "red" :| [])
Right (Out "red")
it "does not drop anonymous nodes after matching" $
stateNodes . snd <$> runAssignment headF "red magenta" red (makeState [node Red 0 3 [], node Magenta 4 11 []])
`shouldBe`
Some ([node Magenta 4 11 []] :| [])
Right [node Magenta 4 11 []]
it "does not drop anonymous nodes when requested" $
fst <$> runAssignment headF "magenta red" ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []])
`shouldBe`
Some ((Out "magenta", Out "red") :| [])
Right (Out "magenta", Out "red")
it "produces errors with callstacks pointing at the failing assignment" $
first (fmap fst . getCallStack . errorCallStack) (runAssignment headF "blue" red (makeState [node Blue 0 4 []]))
`shouldBe`
None [ "symbol", "red" ]
Left [ "symbol", "red" ]
node :: symbol -> Int -> Int -> [AST symbol] -> AST symbol
node symbol start end children = Node symbol (Range start end) (Info.Span (Info.Pos 1 (succ start)) (Info.Pos 1 (succ end))) :< children