mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Merge pull request #36 from github/if-any-monad-is-not-freer-then-I-too-am-bound
Copy Freer in to Assignment, 🔥 dependency on freer-cofreer
This commit is contained in:
commit
ac8bd4409c
3
.gitmodules
vendored
3
.gitmodules
vendored
@ -4,9 +4,6 @@
|
||||
[submodule "vendor/haskell-tree-sitter"]
|
||||
path = vendor/haskell-tree-sitter
|
||||
url = https://github.com/tree-sitter/haskell-tree-sitter.git
|
||||
[submodule "vendor/freer-cofreer"]
|
||||
path = vendor/freer-cofreer
|
||||
url = https://github.com/robrix/freer-cofreer.git
|
||||
[submodule "vendor/proto3-suite"]
|
||||
path = vendor/proto3-suite
|
||||
url = https://github.com/joshvera/proto3-suite.git
|
||||
|
@ -290,7 +290,6 @@ library
|
||||
, cryptohash ^>= 0.11.9
|
||||
, deepseq ^>= 1.4.4.0
|
||||
, directory-tree ^>= 0.12.1
|
||||
, freer-cofreer
|
||||
, generic-monoid ^>= 0.1.0.0
|
||||
, ghc-prim ^>= 0.5.3
|
||||
, gitrev ^>= 1.3.1
|
||||
|
@ -98,7 +98,6 @@ import Prologue
|
||||
import Prelude hiding (fail)
|
||||
import qualified Assigning.Assignment.Table as Table
|
||||
import Control.Monad.Except (MonadError (..))
|
||||
import Control.Monad.Free.Freer
|
||||
import Data.AST
|
||||
import Data.Error
|
||||
import Data.Range
|
||||
@ -200,7 +199,7 @@ choice :: (Enum grammar, Eq1 ast, Ix grammar, HasCallStack) => [Assignment ast g
|
||||
choice [] = empty
|
||||
choice alternatives
|
||||
| null choices = asum alternatives
|
||||
| otherwise = tracing (Choose (Table.fromListWith (<|>) choices) (wrap . tracing . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers)) `Then` pure
|
||||
| otherwise = tracing (Choose (Table.fromListWith (<|>) choices) ((`Then` id) . tracing . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers)) `Then` pure
|
||||
where (choices, atEnd, handlers) = foldMap toChoices alternatives
|
||||
toChoices :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> ([(grammar, Assignment ast grammar a)], [Assignment ast grammar a], [Error (Either String grammar) -> Assignment ast grammar a])
|
||||
toChoices rule = case rule of
|
||||
@ -356,7 +355,7 @@ instance MonadFail (Assignment ast grammar) where
|
||||
fail :: HasCallStack => String -> Assignment ast grammar a
|
||||
fail s = tracing (Fail s) `Then` pure
|
||||
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar, Show1 ast) => Parsing (Assignment ast grammar) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => Parsing (Assignment ast grammar) where
|
||||
try = id
|
||||
|
||||
(<?>) :: HasCallStack => Assignment ast grammar a -> String -> Assignment ast grammar a
|
||||
@ -369,7 +368,7 @@ instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar, Show1 ast) => Parsing
|
||||
eof = tracing End `Then` pure
|
||||
|
||||
notFollowedBy :: (HasCallStack, Show a) => Assignment ast grammar a -> Assignment ast grammar ()
|
||||
notFollowedBy a = a *> unexpected (show a) <|> pure ()
|
||||
notFollowedBy a = (a >>= unexpected . show) <|> pure ()
|
||||
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment ast grammar) where
|
||||
throwError :: HasCallStack => Error (Either String grammar) -> Assignment ast grammar a
|
||||
@ -381,22 +380,55 @@ instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error
|
||||
Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` pure
|
||||
_ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)
|
||||
|
||||
instance Show1 f => Show1 (Tracing f) where
|
||||
liftShowsPrec sp sl d = liftShowsPrec sp sl d . runTracing
|
||||
|
||||
instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where
|
||||
liftShowsPrec sp sl d a = case a of
|
||||
End -> showString "End" . showChar ' ' . sp d ()
|
||||
Location -> showString "Location" . sp d (L.Location (Range 0 0) (Span (Pos 1 1) (Pos 1 1)))
|
||||
CurrentNode -> showString "CurrentNode"
|
||||
Source -> showString "Source" . showChar ' ' . sp d ""
|
||||
Children a -> showsUnaryWith showChild "Children" d a
|
||||
Choose choices atEnd _ -> showsBinaryWith (liftShowsPrec showChild showChildren) (liftShowsPrec showChild showChildren) "Choose" d choices atEnd
|
||||
Many a -> showsUnaryWith (liftShowsPrec (\ d a -> sp d [a]) (sl . pure)) "Many" d a
|
||||
Alt as -> showsUnaryWith (const sl) "Alt" d (toList as)
|
||||
Label child string -> showsBinaryWith (liftShowsPrec sp sl) showsPrec "Label" d child string
|
||||
Fail s -> showsUnaryWith showsPrec "Fail" d s
|
||||
GetLocals -> showString "GetLocals"
|
||||
PutLocals locals -> showsUnaryWith showsPrec "PutLocals" d locals
|
||||
where showChild = liftShowsPrec sp sl
|
||||
showChildren = liftShowList sp sl
|
||||
-- Freer
|
||||
|
||||
data Freer f a where
|
||||
Return :: a -> Freer f a
|
||||
Then :: f x -> (x -> Freer f a) -> Freer f a
|
||||
|
||||
infixl 1 `Then`
|
||||
|
||||
instance Functor (Freer f) where
|
||||
fmap f = go
|
||||
where go (Return result) = Return (f result)
|
||||
go (Then step yield) = Then step (go . yield)
|
||||
{-# INLINE go #-}
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
instance Applicative (Freer f) where
|
||||
pure = Return
|
||||
{-# INLINE pure #-}
|
||||
|
||||
Return f <*> param = fmap f param
|
||||
Then action yield <*> param = Then action ((<*> param) . yield)
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
Return _ *> a = a
|
||||
Then r f *> a = Then r ((*> a) . f)
|
||||
{-# INLINE (*>) #-}
|
||||
|
||||
Return a <* b = b *> Return a
|
||||
Then r f <* a = Then r ((<* a) . f)
|
||||
{-# INLINE (<*) #-}
|
||||
|
||||
instance Monad (Freer f) where
|
||||
return = pure
|
||||
{-# INLINE return #-}
|
||||
|
||||
Return a >>= f = f a
|
||||
Then r f >>= g = Then r (g <=< f)
|
||||
{-# INLINE (>>=) #-}
|
||||
|
||||
(>>) = (*>)
|
||||
{-# INLINE (>>) #-}
|
||||
|
||||
-- | Tear down a 'Freer' 'Monad' using iteration with an explicit continuation.
|
||||
--
|
||||
-- This is analogous to 'iter' with a continuation for the interior values, and is therefore suitable for defining interpreters for GADTs/types lacking a 'Functor' instance.
|
||||
iterFreer :: (forall x. (x -> a) -> f x -> a) -> Freer f a -> a
|
||||
iterFreer algebra = go
|
||||
where go (Return result) = result
|
||||
go (Then action continue) = algebra (go . continue) action
|
||||
{-# INLINE go #-}
|
||||
{-# INLINE iterFreer #-}
|
||||
|
1
vendor/freer-cofreer
vendored
1
vendor/freer-cofreer
vendored
@ -1 +0,0 @@
|
||||
Subproject commit 6d94484a08f970877c4e34c9ecd9c219a7e476b5
|
Loading…
Reference in New Issue
Block a user