github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-25 16:02:43 +03:00
Code Issues Projects Releases Wiki Activity

Define an eliminator for statements.

Browse Source
This commit is contained in:
Rob Rix 2019-07-23 11:18:21 -04:00
parent 16413e1e5b
commit 6050b9594d
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 4 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
semantic-core/src/Data/Core.hs
View File

@ -9,6 +9,7 @@ module Data.Core
, unseqs , unseqs
, (>>>=) , (>>>=)
, unbind , unbind
, unstatement
, do' , do'
, (:<-)(..) , (:<-)(..)
, lam , lam
@ -137,6 +138,9 @@ unbind :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -
unbind n (Term sig) | Just (Named u a :>>= b) <- prj sig = pure (Named u n :<- a, instantiate1 (pure n) b) unbind n (Term sig) | Just (Named u a :>>= b) <- prj sig = pure (Named u n :<- a, instantiate1 (pure n) b)
unbind _ _ = empty unbind _ _ = empty
unstatement :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Maybe (Named a) :<- Term sig a, Term sig a)
unstatement n t = first (first Just) <$> unbind n t <|> first (Nothing :<-) <$> unseq t
do' :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (Maybe (Named a) :<- m a) -> m a do' :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (Maybe (Named a) :<- m a) -> m a
do' bindings = fromMaybe unit (foldr bind Nothing bindings) do' bindings = fromMaybe unit (foldr bind Nothing bindings)
where bind (n :<- a) v = maybe (a >>>) ((>>>=) . (:<- a)) n <$> v <|> Just a where bind (n :<- a) v = maybe (a >>>) ((>>>=) . (:<- a)) n <$> v <|> Just a