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

Define branchNode.

Browse Source
This commit is contained in:
Rob Rix 2018-06-28 11:21:56 -04:00
parent 6af3f6c774
commit 4370de23fd
1 changed files with 10 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Assigning/Assignment/Deterministic.hs
View File

@ -11,8 +11,8 @@ import Prologue
class (Alternative f, Ord s, Show s) => Assigning s f | f -> s where class (Alternative f, Ord s, Show s) => Assigning s f | f -> s where
sym :: s -> f s sym :: s -> f s
leafNode :: s -> f Text leafNode :: s -> f Text
-- TODO: branchNode branchNode :: s -> f a -> f a
-- TODO: toTerm -- TODO: toTerm
combine :: Ord s => Bool -> Set s -> Set s -> Set s combine :: Ord s => Bool -> Set s -> Set s -> Set s
@ -86,5 +86,13 @@ instance (Ord s, Show s) => Assigning s (Assignment s) where
Left err -> Left (Error (astSpan s) [Left "valid utf-8"] (Just (Left (show err)))) Left err -> Left (Error (astSpan s) [Left "valid utf-8"] (Just (Left (show err))))
Right text -> Right (advanceState state, text)) Right text -> Right (advanceState state, text))
branchNode s a = Assignment Nothing (Set.singleton s) (\ src state _ -> case stateInput state of
[] -> Left (Error (stateSpan state) [Right s] Nothing)
s:_ -> case runAssignment a src state { stateInput = astChildren s } of
Left err -> Left err
Right (state', a') -> case stateInput state' of
[] -> Right (advanceState state, a')
s':_ -> Left (Error (stateSpan state') [] (Just (Right (astSymbol s')))))
runAssignment :: Assignment s a -> Source -> State s -> Either (Error (Either String s)) (State s, a) runAssignment :: Assignment s a -> Source -> State s -> Either (Error (Either String s)) (State s, a)
runAssignment (Assignment _ _ p) src inp = p src inp lowerBound runAssignment (Assignment _ _ p) src inp = p src inp lowerBound