github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 00:42:33 +03:00
Code Issues Projects Releases Wiki Activity

Derive HFoldable instances for syntax types.

Browse Source
This commit is contained in:
Patrick Thomson 2019-12-06 14:49:57 -05:00
parent cb0e0eae0c
commit dd5cf213d6
2 changed files with 13 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
semantic-core/src/Core/Core.hs
View File

@ -48,6 +48,7 @@ import Data.Text (Text)
import GHC.Generics (Generic1)
import GHC.Stack
import Source.Span
import Syntax.Foldable
import Syntax.Module
import Syntax.Scope
import Syntax.Stack
@ -91,6 +92,7 @@ infixl 9 :.
infix 3 :=
instance HFunctor Core
instance HFoldable Core
instance HTraversable Core
deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Core f a)
@ -232,9 +234,8 @@ data Ann ann f a
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance HFunctor (Ann ann)
instance HTraversable (Ann ann) where
htraverse f (Ann a x) = Ann a <$> f x
instance HFoldable (Ann ann)
instance HTraversable (Ann ann)
instance RightModule (Ann ann) where
Ann l b >>=* f = Ann l (b >>= f)

18
semantic-python/src/Language/Python/Failure.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, ExistentialQuantification, FlexibleContexts,
KindSignatures, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, StandaloneDeriving,
TypeOperators #-}
{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, ExistentialQuantification,
FlexibleContexts, KindSignatures, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes,
StandaloneDeriving, TypeOperators #-}
module Language.Python.Failure
( Failure (..)
@ -15,6 +15,8 @@ import Control.Effect.Carrier
import Control.Monad.Fail
import Data.Coerce
import Data.Kind
import GHC.Generics (Generic1)
import Syntax.Foldable
import Syntax.Module
import Syntax.Term
import Syntax.Traversable
@ -32,16 +34,14 @@ deriving instance Functor (Failure f)
deriving instance Foldable (Failure f)
deriving instance Traversable (Failure f)
instance HFunctor Failure where hmap _ = coerce
instance HTraversable Failure where
htraverse _ = \case
Unimplemented x -> pure (Unimplemented x)
InvariantViolated y -> pure (InvariantViolated y)
instance HFunctor Failure
instance HFoldable Failure
instance HTraversable Failure
instance RightModule Failure where
a >>=* _ = coerce a
unimplemented :: (Show ast, Member Failure sig, Carrier sig m) => ast -> m a
unimplemented = send . Unimplemented . show