Disambiguate assignment results.

src/Data/Syntax/Assignment.hs

@@ -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,7 +247,7 @@ 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.
@@ -255,8 +256,8 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar
               -> 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.
+              -> Either (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)
+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)

src/Semantic/Task.hs

@@ -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
+              Right ast -> logTiming "assign" $ case Assignment.assignBy by blobSource assignment ast of
-                None err -> do
+                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
+                Right term -> do
-                  let (term, _) = fromMaybe (minimumBy (comparing (Assignment.stateErrorCounter . snd)) terms) (find ((== 0) . Assignment.stateErrorCounter . snd) terms)
                   for_ (errors term) $ \ err ->
                     writeLog Warning (Assignment.formatErrorWithOptions optionsPrintSource optionsEnableColour blob err) blobFields
                   pure $ Right term

test/Data/Syntax/Assignment/Spec.hs

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