Merge pull request #1089 from github/committed-choice

Committed choice

src/Data/Syntax/Assignment.hs

@@ -1,13 +1,9 @@
-{-# LANGUAGE DataKinds, GADTs, TypeFamilies #-}
+{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeFamilies #-}
 module Data.Syntax.Assignment
 ( Assignment
-, get
-, state
 , Location
 , location
 , symbol
-, range
-, sourceSpan
 , source
 , children
 , Rose(..)
@@ -21,8 +17,11 @@ module Data.Syntax.Assignment
 ) where
 
 import Control.Monad.Free.Freer
+import qualified Data.ByteString.Char8 as B
 import Data.Functor.Classes
 import Data.Functor.Foldable hiding (Nil)
+import qualified Data.IntMap.Lazy as IntMap
+import Data.List ((!!))
 import Data.Record
 import Data.Text (unpack)
 import qualified Info
@@ -38,48 +37,24 @@ import Text.Show hiding (show)
 type Assignment node = Freer (AssignmentF node)
 
 data AssignmentF node a where
-  Get :: AssignmentF node node
+  Location :: AssignmentF node Location
-  State :: AssignmentF (Node grammar) (AssignmentState grammar)
   Source :: AssignmentF symbol ByteString
   Children :: Assignment symbol a -> AssignmentF symbol a
+  Choose :: IntMap.IntMap a -> AssignmentF node a
   Alt :: a -> a -> AssignmentF symbol a
   Empty :: AssignmentF symbol a
 
--- | Zero-width production of the current node.
---
---   Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (get *> b)' is fine, but 'many get' is not.
-get :: Assignment (Record fields) (Record fields)
-get = Get `Then` return
-
--- | Zero-width production of the current state.
---
---   Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (state *> b)' is fine, but 'many state' is not.
-state :: Assignment (Node grammar) (AssignmentState grammar)
-state = State `Then` return
-
 -- | Zero-width production of the current location.
 --
 --   If assigning at the end of input or at the end of a list of children, the loccation will be returned as an empty Range and SourceSpan at the current offset. Otherwise, it will be the Range and SourceSpan of the current node.
 location :: Assignment (Node grammar) Location
-location = rtail <$> get <|> (\ (AssignmentState o p _ _) -> Info.Range o o :. Info.SourceSpan p p :. Nil) <$> state
+location = Location `Then` return
 
 -- | Zero-width match of a node with the given symbol.
 --
 --   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 :: (HasField fields symbol, Eq symbol) => symbol -> Assignment (Record fields) ()
+symbol :: (Enum symbol, Eq symbol) => symbol -> Assignment (Node symbol) ()
-symbol s = Get `Then` guard . (s ==) . getField
+symbol s = Choose (IntMap.singleton (fromEnum s) ()) `Then` return
-
--- | Zero-width production of the current node’s range.
---
---   Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (range *> b)' is fine, but 'many range' is not.
-range :: HasField fields Info.Range => Assignment (Record fields) Info.Range
-range = Get `Then` return . getField
-
--- | Zero-width production of the current node’s sourceSpan.
---
---   Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (sourceSpan *> b)' is fine, but 'many sourceSpan' is not.
-sourceSpan :: HasField fields Info.SourceSpan => Assignment (Record fields) Info.SourceSpan
-sourceSpan = Get `Then` return . getField
 
 -- | A rule to produce a node’s source as a ByteString.
 source :: Assignment symbol ByteString
@@ -110,10 +85,10 @@ data Result a = Result a | Error [Text]
 
 
 -- | Run an assignment of nodes in a grammar onto terms in a syntax, discarding any unparsed nodes.
-assignAll :: (Symbol grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> Source.Source -> [AST grammar] -> Result a
+assignAll :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> Source.Source -> [AST grammar] -> Result a
 assignAll assignment = (assignAllFrom assignment .) . AssignmentState 0 (Info.SourcePos 1 1)
 
-assignAllFrom :: (Symbol grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result a
+assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result a
 assignAllFrom assignment state = case runAssignment assignment state of
   Result (state, a) -> case stateNodes (dropAnonymous state) of
     [] -> Result a
@@ -121,23 +96,27 @@ assignAllFrom assignment state = case runAssignment assignment state of
   Error e -> Error e
 
 -- | Run an assignment of nodes in a grammar onto terms in a syntax.
-runAssignment :: (Symbol grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result (AssignmentState grammar, a)
+runAssignment :: forall grammar a. (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result (AssignmentState grammar, a)
-runAssignment = iterFreer (\ assignment yield state -> case (assignment, dropAnonymous state) of
+runAssignment = iterFreer run . fmap (\ a state -> Result (state, a))
-  -- Nullability: some rules, e.g. 'pure a' and 'many a', should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input.
+  where run :: AssignmentF (Node grammar) x -> (x -> AssignmentState grammar -> Result (AssignmentState grammar, a)) -> AssignmentState grammar -> Result (AssignmentState grammar, a)
-  (Alt a b, state) -> yield a state <|> yield b state -- FIXME: Symbol `Alt` Symbol `Alt` Symbol is inefficient, should build and match against an IntMap instead.
+        run assignment yield initialState = case (assignment, stateNodes) of
-  (State, state) -> yield state state
+          (Location, Rose (_ :. location) _ : _) -> yield location state
-  (assignment, AssignmentState offset _ source (subtree@(Rose node@(_ :. range :. _) children) : _)) -> case assignment of
+          (Location, []) -> yield (Info.Range stateOffset stateOffset :. Info.SourceSpan statePos statePos :. Nil) state
-    Get -> yield node state
+          (Source, Rose (_ :. range :. _) _ : _) -> yield (Source.sourceText (Source.slice (offsetRange range (negate stateOffset)) stateSource)) (advanceState state)
-    Source -> yield (Source.sourceText (Source.slice (offsetRange range (negate offset)) source)) (advanceState state)
+          (Children childAssignment, Rose _ children : _) -> case assignAllFrom childAssignment state { stateNodes = children } of
-    Children childAssignment -> do
+            Result c -> yield c (advanceState state)
-      c <- assignAllFrom childAssignment state { stateNodes = children }
+            Error e -> Error e
-      yield c (advanceState state)
+          (Choose choices, Rose (symbol :. _) _ : _) | Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state
-    _ -> Error ["No rule to match " <> show subtree]
+          -- Nullability: some rules, e.g. 'pure a' and 'many a', should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input.
-  (Get, AssignmentState{}) -> Error [ "Expected node but got end of input." ]
+          (Alt a b, _) -> yield a state <|> yield b state
-  (Source, AssignmentState{}) -> Error [ "Expected leaf node but got end of input." ]
+          _ -> Error [expectation <> maybe "end of input" (show . rhead . roseValue) (listToMaybe stateNodes) <> ":\n" <> toS (B.lines (Source.sourceText stateSource) !! pred (Info.line statePos)) <> "\n" <> toS (replicate (pred (Info.column statePos)) ' ') <> "^"]
-  (Children _, AssignmentState{}) -> Error [ "Expected branch node but got end of input." ]
+          where state@AssignmentState{..} = dropAnonymous initialState
-  _ -> Error ["No rule to match at end of input."])
+                expectation = case assignment of
-  . fmap (\ a state -> Result (state, a))
+                  Source -> "Expected a leaf node but got "
+                  Children _ -> "Expected a branch node but got "
+                  Choose choices | [(i, _)] <- IntMap.toList choices -> "Expected " <> show ((toEnum :: Int -> grammar) i) <> " but got "
+                                 | otherwise -> "Expected one of " <> show ((toEnum :: Int -> grammar) <$> IntMap.keys choices) <> " but got "
+                  _ -> "No rule to match at "
 
 dropAnonymous :: Symbol grammar => AssignmentState grammar -> AssignmentState grammar
 dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . rhead . roseValue) (stateNodes state) }
@@ -157,16 +136,20 @@ data AssignmentState grammar = AssignmentState
   }
   deriving (Eq, Show)
 
-instance Alternative (Assignment symbol) where
+instance Enum symbol => Alternative (Assignment (Node symbol)) where
   empty = Empty `Then` return
-  (<|>) = (wrap .) . Alt
+  a <|> b = case (a, b) of
+    (_, Empty `Then` _) -> a
+    (Empty `Then` _, _) -> b
+    (Choose choices1 `Then` continue1, Choose choices2 `Then` continue2) -> Choose (IntMap.union (fmap continue1 choices1) (fmap continue2 choices2)) `Then` identity
+    _ -> wrap $ Alt a b
 
-instance Show symbol => Show1 (AssignmentF symbol) where
+instance Show symbol => Show1 (AssignmentF (Node symbol)) where
   liftShowsPrec sp sl d a = case a of
-    Get -> showString "Get"
+    Location -> showString "Location" . sp d (Info.Range 0 0 :. Info.SourceSpan (Info.SourcePos 0 0) (Info.SourcePos 0 0) :. Nil)
-    State -> showString "State" . sp d (AssignmentState 0 (Info.SourcePos 0 0) (Source.Source "") [])
     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)
     Alt a b -> showsBinaryWith sp sp "Alt" d a b
     Empty -> showString "Empty"
 
@@ -197,8 +180,3 @@ instance Alternative Result where
   Result a <|> _ = Result a
   _ <|> Result b = Result b
   Error a <|> Error b = Error (a <> b)
-
-instance Monad Result where
-  return = pure
-  Error a >>= _ = Error a
-  Result a >>= f = f a

src/Language/Ruby/Syntax.hs

@@ -53,20 +53,18 @@ declaration :: Assignment (Node Grammar) (Term Syntax Location)
 declaration = comment <|> class' <|> method
 
 class' :: Assignment (Node Grammar) (Term Syntax Location)
-class' = term <*  symbol Class
+class' = symbol Class *> term <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration)
-              <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration)
   where superclass = pure <$ symbol Superclass <*> children constant
         scopeResolution = symbol ScopeResolution *> children (constant <|> identifier)
 
 constant :: Assignment (Node Grammar) (Term Syntax Location)
-constant = term <*> (Syntax.Identifier <$ symbol Constant <*> source)
+constant = leaf Constant Syntax.Identifier
 
 identifier :: Assignment (Node Grammar) (Term Syntax Location)
-identifier = term <*> (Syntax.Identifier <$ symbol Identifier <*> source)
+identifier = leaf Identifier Syntax.Identifier
 
 method :: Assignment (Node Grammar) (Term Syntax Location)
-method = term <*  symbol Method
+method = symbol Method *> term <*> children (Declaration.Method <$> identifier <*> pure [] <*> (term <*> many statement))
-              <*> children (Declaration.Method <$> identifier <*> pure [] <*> (term <*> many statement))
 
 statement :: Assignment (Node Grammar) (Term Syntax Location)
 statement  =  exit Statement.Return Return
@@ -78,32 +76,35 @@ statement  =  exit Statement.Return Return
           <|> unless
           <|> unlessModifier
           <|> literal
-  where exit construct sym = term <*> (construct <$ symbol sym <*> children (optional (symbol ArgumentList *> children statement)))
+  where exit construct sym = symbol sym *> term <*> (children (construct <$> optional (symbol ArgumentList *> children statement)))
 
 comment :: Assignment (Node Grammar) (Term Syntax Location)
-comment = term <*> (Comment.Comment <$ symbol Comment <*> source)
+comment = leaf Comment Comment.Comment
 
 if' :: Assignment (Node Grammar) (Term Syntax Location)
 if' = go If
-  where go s = term <* symbol s <*> children (Statement.If <$> statement <*> (term <*> many statement) <*> optional (go Elsif <|> term <* symbol Else <*> children (many statement)))
+  where go s = symbol s *> term <*> children (Statement.If <$> statement <*> (term <*> many statement) <*> optional (go Elsif <|> symbol Else *> term <*> children (many statement)))
 
 ifModifier :: Assignment (Node Grammar) (Term Syntax Location)
-ifModifier = term <* symbol IfModifier <*> children (flip Statement.If <$> statement <*> statement <*> (term <*> pure Syntax.Empty))
+ifModifier = symbol IfModifier *> term <*> children (flip Statement.If <$> statement <*> statement <*> (term <*> pure Syntax.Empty))
 
 unless :: Assignment (Node Grammar) (Term Syntax Location)
-unless = term <* symbol Unless <*> children (Statement.If <$> (term <*> (Expression.Not <$> statement)) <*> (term <*> many statement) <*> optional (term <* symbol Else <*> children (many statement)))
+unless = symbol Unless *> term <*> children (Statement.If <$> (term <*> (Expression.Not <$> statement)) <*> (term <*> many statement) <*> optional (symbol Else *> term <*> children (many statement)))
 
 unlessModifier :: Assignment (Node Grammar) (Term Syntax Location)
-unlessModifier = term <* symbol UnlessModifier <*> children (flip Statement.If <$> statement <*> (term <*> (Expression.Not <$> statement)) <*> (term <*> pure Syntax.Empty))
+unlessModifier = symbol UnlessModifier *> term <*> children (flip Statement.If <$> statement <*> (term <*> (Expression.Not <$> statement)) <*> (term <*> pure Syntax.Empty))
 
 literal :: Assignment (Node Grammar) (Term Syntax Location)
-literal  =  term <*> (Literal.true <$ symbol Language.Ruby.Syntax.True <* source)
+literal  =  leaf Language.Ruby.Syntax.True (const Literal.true)
-        <|> term <*> (Literal.false <$ symbol Language.Ruby.Syntax.False <* source)
+        <|> leaf Language.Ruby.Syntax.False (const Literal.false)
-        <|> term <*> (Literal.Integer <$ symbol Language.Ruby.Syntax.Integer <*> source)
+        <|> leaf Language.Ruby.Syntax.Integer Literal.Integer
 
 -- | Assignment of the current node’s annotation.
 term :: InUnion Syntax' f => Assignment (Node grammar) (f (Term Syntax Location) -> Term Syntax Location)
-term =  (\ a f -> cofree $ a :< inj f) <$> location
+term = (\ a f -> cofree $ a :< inj f) <$> location
+
+leaf :: (Enum symbol, Eq symbol, InUnion Syntax' f) => symbol -> (ByteString -> f (Term Syntax Location)) -> Assignment (Node symbol) (Term Syntax Location)
+leaf s f = (\ a -> cofree . (a :<) . inj . f) <$ symbol s <*> location <*> source
 
 optional :: Assignment (Node Grammar) (Term Syntax Location) -> Assignment (Node Grammar) (Term Syntax Location)
 optional a = a <|> term <*> pure Syntax.Empty

test/Data/Syntax/Assignment/Spec.hs

@@ -51,8 +51,7 @@ spec = do
       () <$ runAssignment (children red) (startingState "a" [Rose (rec Blue 0 1) [Rose (rec Red 0 1) []]]) `shouldBe` Result ()
 
     it "does not match if its subrule does not match" $
-      let errors r = case r of { Result _ -> [] ; Error e -> e } in
+      (runAssignment (children red) (startingState "a" [Rose (rec Blue 0 1) [Rose (rec Green 0 1) []]])) `shouldBe` Error [ "Expected Red but got Green:\na\n^" ]
-      Prologue.length (errors (runAssignment (children red) (startingState "a" [Rose (rec Blue 0 1) [Rose (rec Green 0 1) []]]))) `shouldBe` 1
 
     it "matches nested children" $ do
       runAssignment
@@ -85,7 +84,7 @@ startingState :: ByteString -> [AST grammar] -> AssignmentState grammar
 startingState = AssignmentState 0 (Info.SourcePos 1 1) . Source
 
 data Grammar = Red | Green | Blue
-  deriving (Eq, Show)
+  deriving (Enum, Eq, Show)
 
 instance Symbol Grammar where
   symbolType _ = Regular