mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Merge pull request #1338 from github/unrolled-union-instances
Unrolled Union instances
This commit is contained in:
Josh Vera
GitHub
commit
99603c2a47
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
module Algorithm where
|
||||
|
||||
import Control.Applicative (liftA2)
|
||||
@ -106,8 +106,8 @@ genericAlgorithmFor a b = fmap to1 <$> algorithmFor' (from1 a) (from1 b)
|
||||
-- Right is the "head" of the Union. 'weaken' relaxes the Union to allow the possible
|
||||
-- diff terms from the "rest" of the Union, and 'inj' adds the diff terms into the Union.
|
||||
-- NB: If Left or Right Syntax terms in our Union don't match, we fail fast by returning Nothing.
|
||||
instance Apply1 Diffable fs => Diffable (Union fs) where
|
||||
algorithmFor u1 u2 = join (apply1_2' (Proxy :: Proxy Diffable) (\ reinj f1 f2 -> fmap reinj <$> algorithmFor f1 f2) u1 u2)
|
||||
instance Apply Diffable fs => Diffable (Union fs) where
|
||||
algorithmFor u1 u2 = join (apply2' (Proxy :: Proxy Diffable) (\ inj f1 f2 -> fmap inj <$> algorithmFor f1 f2) u1 u2)
|
||||
|
||||
-- | Diff two list parameters using RWS.
|
||||
instance Diffable [] where
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DataKinds, DefaultSignatures, TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds, DefaultSignatures, TypeOperators, UndecidableInstances #-}
|
||||
module Data.Align.Generic where
|
||||
|
||||
import Control.Monad
|
||||
@ -29,8 +29,8 @@ instance GAlign Maybe where
|
||||
instance GAlign Identity where
|
||||
galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b)))
|
||||
|
||||
instance (Apply1 GAlign fs) => GAlign (Union fs) where
|
||||
galignWith f = (join .) . apply1_2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
|
||||
instance Apply GAlign fs => GAlign (Union fs) where
|
||||
galignWith f = (join .) . apply2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
|
||||
|
||||
instance GAlign (Union '[]) where
|
||||
galignWith _ _ _ = Nothing
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses, TypeOperators #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
|
||||
module Data.JSON.Fields where
|
||||
|
||||
import Data.Aeson
|
||||
@ -26,8 +26,8 @@ instance ToJSON a => ToJSONFields [a] where
|
||||
instance ToJSONFields1 [] where
|
||||
toJSONFields1 list = [ "children" .= list ]
|
||||
|
||||
instance (Apply1 Foldable fs) => ToJSONFields1 (Union fs) where
|
||||
toJSONFields1 = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
|
||||
instance Apply Foldable fs => ToJSONFields1 (Union fs) where
|
||||
toJSONFields1 = apply (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
|
||||
|
||||
instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (a, b) where
|
||||
toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]
|
||||
|
||||
@ -26,7 +26,7 @@ import Term
|
||||
-- Combinators
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
||||
makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
|
||||
makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
|
||||
makeTerm a = makeTerm' a . inj
|
||||
|
||||
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
|
||||
@ -34,7 +34,7 @@ makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Ter
|
||||
makeTerm' a f = termIn (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f
|
||||
|
||||
-- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
|
||||
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
|
||||
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
|
||||
makeTerm1 = makeTerm1' . inj
|
||||
|
||||
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
|
||||
@ -44,20 +44,20 @@ makeTerm1' f = case toList f of
|
||||
_ -> error "makeTerm1': empty structure"
|
||||
|
||||
-- | Construct an empty term at the current position.
|
||||
emptyTerm :: (HasCallStack, Empty :< fs, Apply1 Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
emptyTerm = makeTerm <$> Assignment.location <*> pure Empty
|
||||
|
||||
-- | Catch assignment errors into an error term.
|
||||
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply1 Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
|
||||
-- | Catch parse errors into an error term.
|
||||
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply1 Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (getCallStack (freezeCallStack callStack)) [] (Just "ParseError") [])
|
||||
|
||||
|
||||
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply1 Foldable fs)
|
||||
contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
@ -67,7 +67,7 @@ contextualize context rule = make <$> Assignment.manyThrough context rule
|
||||
_ -> node
|
||||
|
||||
-- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
|
||||
postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply1 Foldable fs)
|
||||
postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
-> m b
|
||||
@ -78,7 +78,7 @@ postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThr
|
||||
_ -> (node, end)
|
||||
|
||||
-- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply1 Foldable fs)
|
||||
postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
@ -88,7 +88,7 @@ postContextualize context rule = make <$> rule <*> many context
|
||||
_ -> node
|
||||
|
||||
-- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
|
||||
infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply1 Foldable fs)
|
||||
infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
|
||||
=> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
-> m (Term (Union fs) a)
|
||||
@ -158,19 +158,19 @@ data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
|
||||
instance Eq1 Context where liftEq = genericLiftEq
|
||||
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
algorithmDeletingContext :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
algorithmDeletingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
|
||||
=> TermF Context a (Term (Union fs) a)
|
||||
-> Term (Union fs) a
|
||||
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a)))
|
||||
algorithmDeletingContext (In a1 (Context n1 s1)) s2 = fmap (In a1 . Context (deleting <$> n1)) <$> algorithmForComparableTerms s1 s2
|
||||
|
||||
algorithmInsertingContext :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
algorithmInsertingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
|
||||
=> Term (Union fs) a
|
||||
-> TermF Context a (Term (Union fs) a)
|
||||
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a)))
|
||||
algorithmInsertingContext s1 (In a2 (Context n2 s2)) = fmap (In a2 . Context (inserting <$> n2)) <$> algorithmForComparableTerms s1 s2
|
||||
|
||||
algorithmForContextUnions :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
algorithmForContextUnions :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
|
||||
=> Term (Union fs) a
|
||||
-> Term (Union fs) a
|
||||
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (Diff (Union fs) a))
|
||||
|
||||
@ -42,7 +42,7 @@ newtype Identifier = Identifier ByteString
|
||||
-- | Produce the identifier for a given term, if any.
|
||||
--
|
||||
-- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not.
|
||||
identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier)
|
||||
identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply Foldable fs, Apply Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier)
|
||||
identifierAlgebra (In _ union) = case union of
|
||||
_ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s)
|
||||
_ | Just Declaration.Class{..} <- prj union -> classIdentifier
|
||||
@ -58,7 +58,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int
|
||||
-- TODO: Explicit returns at the end of methods should only count once.
|
||||
-- TODO: Anonymous functions should not increase parent scope’s complexity.
|
||||
-- TODO: Inner functions should not increase parent scope’s complexity.
|
||||
cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity
|
||||
cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply Foldable fs, Apply Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity
|
||||
cyclomaticComplexityAlgebra (In _ union) = case union of
|
||||
_ | Just Declaration.Method{} <- prj union -> succ (sum union)
|
||||
_ | Just Statement.Return{} <- prj union -> succ (sum union)
|
||||
|
||||
@ -23,8 +23,8 @@ constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
|
||||
constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")
|
||||
|
||||
-- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's.
|
||||
constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
|
||||
constructorLabel (In _ u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u)
|
||||
constructorLabel :: Apply ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
|
||||
constructorLabel (In _ u) = ConstructorLabel $ pack (apply (Proxy :: Proxy ConstructorName) constructorName u)
|
||||
|
||||
|
||||
newtype ConstructorLabel = ConstructorLabel ByteString
|
||||
|
||||
@ -40,7 +40,7 @@ data Parser term where
|
||||
-- | A parser producing 'AST' using a 'TS.Language'.
|
||||
ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST [] grammar)
|
||||
-- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type.
|
||||
AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast)
|
||||
AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast)
|
||||
=> Parser (Term ast (Node grammar)) -- ^ A parser producing AST.
|
||||
-> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.
|
||||
-> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's.
|
||||
|
||||
@ -112,7 +112,7 @@ syntaxDeclarationAlgebra Blob{..} (In a r) = case r of
|
||||
where getSource = toText . flip Source.slice blobSource . byteRange . extract
|
||||
|
||||
-- | Compute 'Declaration's for methods and functions.
|
||||
declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span)
|
||||
declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply Functor fs, HasField fields Range, HasField fields Span)
|
||||
=> Blob
|
||||
-> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
|
||||
declarationAlgebra blob@Blob{..} (In a r)
|
||||
@ -123,7 +123,7 @@ declarationAlgebra blob@Blob{..} (In a r)
|
||||
where getSource = toText . flip Source.slice blobSource . byteRange
|
||||
|
||||
-- | Compute 'Declaration's with the headings of 'Markup.Section's.
|
||||
markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs)
|
||||
markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply Functor fs, Apply Foldable fs)
|
||||
=> Blob
|
||||
-> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
|
||||
markupSectionAlgebra blob@Blob{..} (In a r)
|
||||
|
||||
@ -219,7 +219,7 @@ runParser Options{..} blob@Blob{..} = go
|
||||
MarkdownParser -> logTiming "cmark parse" $ pure (cmarkParser blobSource)
|
||||
LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource)
|
||||
blobFields = ("path", blobPath) : maybe [] (pure . (,) "language" . show) blobLanguage
|
||||
errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
|
||||
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
|
||||
errors = cata $ \ (In a syntax) -> case syntax of
|
||||
_ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err]
|
||||
_ -> fold syntax
|
||||
|
||||
2
vendor/effects
vendored
2
vendor/effects
vendored
@ -1 +1 @@
|
||||
Subproject commit 3e4e0d422adb9fe8aff95c206e4ddd91c349f162
|
||||
Subproject commit bd6bd91c0df4f51b51a536b278ff9ae009354327
|
||||
Loading…
Reference in New Issue
Block a user