mirror of
https://github.com/github/semantic.git
synced 2024-12-11 20:44:37 +03:00
Merge pull request #578 from github/no-uncertain-terms
Remove Data.Term and Data.AST.
This commit is contained in:
Patrick Thomson
GitHub
commit
cf6373be1e
@ -54,13 +54,11 @@ common dependencies
|
||||
, bytestring ^>= 0.10.8.2
|
||||
, containers ^>= 0.6.0.1
|
||||
, directory ^>= 1.3.3.0
|
||||
, fastsum ^>= 0.1.1.1
|
||||
, fused-effects ^>= 1
|
||||
, fused-effects-exceptions ^>= 1
|
||||
, fused-effects-resumable ^>= 0.1
|
||||
, hashable >= 1.2.7 && < 1.4
|
||||
, tree-sitter ^>= 0.9.0.1
|
||||
, mtl ^>= 2.2.2
|
||||
, network ^>= 2.8.0.0
|
||||
, pathtype ^>= 0.8.1
|
||||
, process ^>= 1.6.3.0
|
||||
@ -91,7 +89,6 @@ library
|
||||
, Control.Effect.Sum.Project
|
||||
, Control.Effect.Timeout
|
||||
-- General datatype definitions & generic algorithms
|
||||
, Data.AST
|
||||
, Data.Blob
|
||||
, Data.Blob.IO
|
||||
, Data.Duration
|
||||
@ -107,7 +104,6 @@ library
|
||||
, Data.Maybe.Exts
|
||||
, Data.Semigroup.App
|
||||
, Data.Scientific.Exts
|
||||
, Data.Term
|
||||
, Numeric.Exts
|
||||
-- Parser glue
|
||||
, Parsing.Parser
|
||||
@ -209,7 +205,6 @@ test-suite test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
ghc-options: -Werror
|
||||
other-modules: Data.Functor.Classes.Generic.Spec
|
||||
, Data.Functor.Listable
|
||||
, Data.Graph.Spec
|
||||
@ -218,7 +213,6 @@ test-suite test
|
||||
, Data.Semigroup.App.Spec
|
||||
, Integration.Spec
|
||||
, Numeric.Spec
|
||||
, Parsing.Spec
|
||||
, Semantic.Spec
|
||||
, Semantic.CLI.Spec
|
||||
, Semantic.IO.Spec
|
||||
|
||||
@ -1,124 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Analysis.CyclomaticComplexity
|
||||
( CyclomaticComplexity(..)
|
||||
, HasCyclomaticComplexity
|
||||
, cyclomaticComplexityAlgebra
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.Sum
|
||||
import qualified Data.Syntax.Declaration as Declaration
|
||||
import qualified Data.Syntax.Statement as Statement
|
||||
import Data.Term
|
||||
|
||||
-- | The cyclomatic complexity of a (sub)term.
|
||||
newtype CyclomaticComplexity = CyclomaticComplexity Int
|
||||
deriving (Enum, Eq, Num, Ord, Show, ToJSON)
|
||||
|
||||
-- | Compute the cyclomatic complexity of a (sub)term, measured as the number places where control exits scope, e.g. returns and yields.
|
||||
--
|
||||
-- TODO: Explicit returns at the end of methods or functions should only count once.
|
||||
-- TODO: Anonymous functions should not increase parent scope’s complexity.
|
||||
-- TODO: Inner functions should not increase parent scope’s complexity.
|
||||
|
||||
-- | An f-algebra producing a 'CyclomaticComplexity' for syntax nodes corresponding to their summary cyclomatic complexity, defaulting to the sum of their contents’ cyclomatic complexities.
|
||||
--
|
||||
-- Customizing this for a given syntax type involves two steps:
|
||||
--
|
||||
-- 1. Defining a 'CustomHasCyclomaticComplexity' instance for the type.
|
||||
-- 2. Adding the type to the 'CyclomaticComplexityStrategy' type family.
|
||||
--
|
||||
-- If you’re getting errors about missing a 'CustomHasCyclomaticComplexity' instance for your syntax type, you probably forgot step 1.
|
||||
--
|
||||
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
|
||||
cyclomaticComplexityAlgebra :: HasCyclomaticComplexity syntax => TermF syntax ann CyclomaticComplexity -> CyclomaticComplexity
|
||||
cyclomaticComplexityAlgebra (In _ syntax) = toCyclomaticComplexity syntax
|
||||
|
||||
|
||||
-- | Types for which we can produce a 'CyclomaticComplexity'. There is exactly one instance of this typeclass; adding customized 'CyclomaticComplexity's for a new type is done by defining an instance of 'CustomHasCyclomaticComplexity' instead.
|
||||
--
|
||||
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
|
||||
class HasCyclomaticComplexity syntax where
|
||||
-- | Compute a 'CyclomaticComplexity' for a syntax type using its 'CustomHasCyclomaticComplexity' instance, if any, or else falling back to the default definition (which simply returns the sum of any contained cyclomatic complexities).
|
||||
toCyclomaticComplexity :: syntax CyclomaticComplexity -> CyclomaticComplexity
|
||||
|
||||
-- | Define 'toCyclomaticComplexity' using the 'CustomHasCyclomaticComplexity' instance for a type if there is one or else use the default definition.
|
||||
--
|
||||
-- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'CyclomaticComplexityStrategy' type family. Thus producing a 'CyclomaticComplexity' for a node requires both defining a 'CustomHasCyclomaticComplexity' instance _and_ adding a definition for the type to the 'CyclomaticComplexityStrategy' type family to return 'Custom'.
|
||||
--
|
||||
-- Note that since 'CyclomaticComplexityStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasCyclomaticComplexity', as any other instance would be indistinguishable.
|
||||
instance (CyclomaticComplexityStrategy syntax ~ strategy, HasCyclomaticComplexityWithStrategy strategy syntax) => HasCyclomaticComplexity syntax where
|
||||
toCyclomaticComplexity = toCyclomaticComplexityWithStrategy (Proxy :: Proxy strategy)
|
||||
|
||||
|
||||
-- | Types for which we can produce a customized 'CyclomaticComplexity'.
|
||||
class CustomHasCyclomaticComplexity syntax where
|
||||
-- | Produce a customized 'CyclomaticComplexity' for a given syntax node.
|
||||
customToCyclomaticComplexity :: syntax CyclomaticComplexity -> CyclomaticComplexity
|
||||
|
||||
-- | Because we perform the same operation wherever we use the custom strategy, we can define the default method for all instances.
|
||||
default customToCyclomaticComplexity :: Foldable syntax => syntax CyclomaticComplexity -> CyclomaticComplexity
|
||||
customToCyclomaticComplexity = succ . sum
|
||||
|
||||
instance CustomHasCyclomaticComplexity Declaration.Function
|
||||
instance CustomHasCyclomaticComplexity Declaration.Method
|
||||
instance CustomHasCyclomaticComplexity Statement.Catch
|
||||
instance CustomHasCyclomaticComplexity Statement.DoWhile
|
||||
instance CustomHasCyclomaticComplexity Statement.Else
|
||||
instance CustomHasCyclomaticComplexity Statement.For
|
||||
instance CustomHasCyclomaticComplexity Statement.ForEach
|
||||
instance CustomHasCyclomaticComplexity Statement.If
|
||||
instance CustomHasCyclomaticComplexity Statement.Pattern
|
||||
instance CustomHasCyclomaticComplexity Statement.While
|
||||
|
||||
-- | Produce a 'CyclomaticComplexity' for 'Sum's using the 'HasCyclomaticComplexity' instance & therefore using a 'CustomHasCyclomaticComplexity' instance when one exists & the type is listed in 'CyclomaticComplexityStrategy'.
|
||||
instance Apply HasCyclomaticComplexity fs => CustomHasCyclomaticComplexity (Sum fs) where
|
||||
customToCyclomaticComplexity = apply @HasCyclomaticComplexity toCyclomaticComplexity
|
||||
|
||||
|
||||
-- | A strategy for defining a 'HasCyclomaticComplexity' instance. Intended to be promoted to the kind level using @-XDataKinds@.
|
||||
data Strategy = Default | Custom
|
||||
|
||||
-- | Produce a 'CyclomaticComplexity' for a syntax node using either the 'Default' or 'Custom' strategy.
|
||||
--
|
||||
-- You should probably be using 'CustomHasCyclomaticComplexity' instead of this class; and you should not define new instances of this class.
|
||||
class HasCyclomaticComplexityWithStrategy (strategy :: Strategy) syntax where
|
||||
toCyclomaticComplexityWithStrategy :: proxy strategy -> syntax CyclomaticComplexity -> CyclomaticComplexity
|
||||
|
||||
|
||||
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
|
||||
--
|
||||
-- Only entries for which we want to use the 'Custom' strategy should be listed, with the exception of the final entry which maps all other types onto the 'Default' strategy.
|
||||
--
|
||||
-- If you’re seeing errors about missing a 'CustomHasCyclomaticComplexity' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasCyclomaticComplexity' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasCyclomaticComplexity' method is never being called, you may have forgotten to list the type in here.
|
||||
type family CyclomaticComplexityStrategy syntax where
|
||||
CyclomaticComplexityStrategy Declaration.Function = 'Custom
|
||||
CyclomaticComplexityStrategy Declaration.Method = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.Catch = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.DoWhile = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.Else = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.For = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.ForEach = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.If = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.Pattern = 'Custom
|
||||
CyclomaticComplexityStrategy Statement.While = 'Custom
|
||||
CyclomaticComplexityStrategy (Sum _) = 'Custom
|
||||
CyclomaticComplexityStrategy _ = 'Default
|
||||
|
||||
|
||||
-- | The 'Default' strategy takes the sum without incrementing.
|
||||
instance Foldable syntax => HasCyclomaticComplexityWithStrategy 'Default syntax where
|
||||
toCyclomaticComplexityWithStrategy _ = sum
|
||||
|
||||
-- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasCyclomaticComplexity' instance for the type.
|
||||
instance CustomHasCyclomaticComplexity syntax => HasCyclomaticComplexityWithStrategy 'Custom syntax where
|
||||
toCyclomaticComplexityWithStrategy _ = customToCyclomaticComplexity
|
||||
@ -59,10 +59,6 @@ runParser ::
|
||||
-> Parser term
|
||||
-> m term
|
||||
runParser blob@Blob{..} parser = case parser of
|
||||
ASTParser language ->
|
||||
time "parse.tree_sitter_ast_parse" languageTag $ do
|
||||
config <- asks config
|
||||
executeParserAction (parseToAST (configTreeSitterParseTimeout config) language blob)
|
||||
|
||||
UnmarshalParser language -> do
|
||||
(time "parse.tree_sitter_precise_ast_parse" languageTag $ do
|
||||
|
||||
@ -50,10 +50,6 @@ runParser
|
||||
-> Parser term
|
||||
-> m term
|
||||
runParser timeout blob@Blob{..} parser = case parser of
|
||||
ASTParser language ->
|
||||
parseToAST timeout language blob
|
||||
>>= either (throwError . SomeException) pure
|
||||
|
||||
UnmarshalParser language ->
|
||||
parseToPreciseAST timeout timeout language blob
|
||||
>>= either (throwError . SomeException) pure
|
||||
|
||||
@ -1,25 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
|
||||
module Data.AST
|
||||
( Node (..)
|
||||
, nodeSpan
|
||||
, nodeByteRange
|
||||
, AST
|
||||
) where
|
||||
|
||||
import Data.Term
|
||||
import Source.Loc as Loc
|
||||
|
||||
-- | An AST node labelled with symbols and source location.
|
||||
type AST grammar = Term [] (Node grammar)
|
||||
|
||||
data Node grammar = Node
|
||||
{ nodeSymbol :: !grammar
|
||||
, nodeLocation :: {-# UNPACK #-} !Loc
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
nodeSpan :: Node grammar -> Span
|
||||
nodeSpan = Loc.span . nodeLocation
|
||||
|
||||
nodeByteRange :: Node grammar -> Range
|
||||
nodeByteRange = byteRange . nodeLocation
|
||||
174
src/Data/Term.hs
174
src/Data/Term.hs
@ -1,174 +0,0 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Data.Term
|
||||
( Term(..)
|
||||
, TermF(..)
|
||||
, termSize
|
||||
, hoistTerm
|
||||
, hoistTermF
|
||||
, Annotated (..)
|
||||
-- * Abstract term interfaces
|
||||
, IsTerm(..)
|
||||
, termAnnotation
|
||||
, termOut
|
||||
, projectTerm
|
||||
, termIn
|
||||
, injectTerm
|
||||
) where
|
||||
|
||||
-- TODO remove this??
|
||||
|
||||
import Control.Lens.Lens
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Foldable
|
||||
import Data.Sum
|
||||
import qualified Data.Sum as Sum
|
||||
import GHC.Generics (Generic1)
|
||||
import Source.Span
|
||||
import Text.Show
|
||||
|
||||
-- | A Term with an abstract syntax tree and an annotation.
|
||||
newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
|
||||
|
||||
data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur }
|
||||
deriving (Eq, Ord, Foldable, Functor, Show, Traversable, Generic1)
|
||||
|
||||
annotationLens :: Lens' (TermF syntax ann recur) ann
|
||||
annotationLens = lens termFAnnotation (\t a -> t { termFAnnotation = a })
|
||||
{-# INLINE annotationLens #-}
|
||||
|
||||
instance HasSpan ann => HasSpan (TermF syntax ann recur) where
|
||||
span_ = annotationLens.span_
|
||||
{-# INLINE span_ #-}
|
||||
|
||||
instance HasSpan ann => HasSpan (Term syntax ann) where
|
||||
span_ = inner.span_ where inner = lens unTerm (\t i -> t { unTerm = i })
|
||||
{-# INLINE span_ #-}
|
||||
|
||||
-- | A convenience typeclass to get the annotation out of a 'Term' or 'TermF'.
|
||||
-- Useful in term-rewriting algebras.
|
||||
class Annotated t ann | t -> ann where
|
||||
annotation :: t -> ann
|
||||
|
||||
instance Annotated (TermF syntax ann recur) ann where
|
||||
annotation = termFAnnotation
|
||||
|
||||
instance Annotated (Term syntax ann) ann where
|
||||
annotation = termAnnotation
|
||||
|
||||
|
||||
-- | Return the node count of a term.
|
||||
termSize :: (Foldable f, Functor f) => Term f annotation -> Int
|
||||
termSize = cata size where
|
||||
size (In _ syntax) = 1 + sum syntax
|
||||
|
||||
|
||||
hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a
|
||||
hoistTerm f = go where go (Term r) = Term (hoistTermF f (fmap go r))
|
||||
|
||||
hoistTermF :: (forall a. f a -> g a) -> TermF f a b -> TermF g a b
|
||||
hoistTermF f = go where go (In a r) = In a (f r)
|
||||
|
||||
|
||||
type instance Base (Term f a) = TermF f a
|
||||
|
||||
instance Functor f => Recursive (Term f a) where project = unTerm
|
||||
instance Functor f => Corecursive (Term f a) where embed = Term
|
||||
|
||||
instance Functor f => Functor (Term f) where
|
||||
fmap f = go where go = Term . bimap f go . unTerm
|
||||
|
||||
instance Foldable f => Foldable (Term f) where
|
||||
foldMap f = go where go = bifoldMap f go . unTerm
|
||||
|
||||
instance Traversable f => Traversable (Term f) where
|
||||
traverse f = go where go = fmap Term . bitraverse f go . unTerm
|
||||
|
||||
instance Eq1 f => Eq1 (Term f) where
|
||||
liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unTerm t1) (unTerm t2)
|
||||
|
||||
instance (Eq1 f, Eq a) => Eq (Term f a) where
|
||||
(==) = eq1
|
||||
|
||||
instance Show1 f => Show1 (Term f) where
|
||||
liftShowsPrec spA _ = go where go d (Term (In a f)) = showsBinaryWith spA (liftShowsPrec go (showListWith (go 0))) "Term" d a f
|
||||
|
||||
instance (Show1 f, Show a) => Show (Term f a) where
|
||||
showsPrec = showsPrec1
|
||||
|
||||
instance Ord1 f => Ord1 (Term f) where
|
||||
liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2)
|
||||
|
||||
instance (Ord1 f, Ord a) => Ord (Term f a) where
|
||||
compare = compare1
|
||||
|
||||
|
||||
instance Functor f => Bifunctor (TermF f) where
|
||||
bimap f g (In a r) = In (f a) (fmap g r)
|
||||
|
||||
instance Foldable f => Bifoldable (TermF f) where
|
||||
bifoldMap f g (In a r) = f a `mappend` foldMap g r
|
||||
|
||||
instance Traversable f => Bitraversable (TermF f) where
|
||||
bitraverse f g (In a r) = In <$> f a <*> traverse g r
|
||||
|
||||
|
||||
instance Eq1 f => Eq2 (TermF f) where
|
||||
liftEq2 eqA eqB (In a1 f1) (In a2 f2) = eqA a1 a2 && liftEq eqB f1 f2
|
||||
|
||||
|
||||
instance (Eq1 f, Eq a) => Eq1 (TermF f a) where
|
||||
liftEq = liftEq2 (==)
|
||||
|
||||
instance Show1 f => Show2 (TermF f) where
|
||||
liftShowsPrec2 spA _ spB slB d (In a f) = showsBinaryWith spA (liftShowsPrec spB slB) "In" d a f
|
||||
|
||||
instance (Show1 f, Show a) => Show1 (TermF f a) where
|
||||
liftShowsPrec = liftShowsPrec2 showsPrec showList
|
||||
|
||||
instance Ord1 f => Ord2 (TermF f) where
|
||||
liftCompare2 compA compB (In a1 f1) (In a2 f2) = compA a1 a2 <> liftCompare compB f1 f2
|
||||
|
||||
instance (Ord1 f, Ord a) => Ord1 (TermF f a) where
|
||||
liftCompare = liftCompare2 compare
|
||||
|
||||
class IsTerm term where
|
||||
type Syntax term :: * -> *
|
||||
|
||||
toTermF :: term ann -> TermF (Syntax term) ann (term ann)
|
||||
fromTermF :: TermF (Syntax term) ann (term ann) -> term ann
|
||||
|
||||
|
||||
termAnnotation :: IsTerm term => term ann -> ann
|
||||
termAnnotation = termFAnnotation . toTermF
|
||||
|
||||
termOut :: IsTerm term => term ann -> Syntax term (term ann)
|
||||
termOut = termFOut . toTermF
|
||||
|
||||
projectTerm :: (f :< syntax, Sum syntax ~ Syntax term, IsTerm term) => term ann -> Maybe (f (term ann))
|
||||
projectTerm = Sum.project . termOut
|
||||
|
||||
|
||||
-- | Build a term from its annotation and syntax.
|
||||
termIn :: IsTerm term => ann -> Syntax term (term ann) -> term ann
|
||||
termIn = fmap fromTermF . In
|
||||
|
||||
injectTerm :: (f :< syntax, Sum syntax ~ Syntax term, IsTerm term) => ann -> f (term ann) -> term ann
|
||||
injectTerm a = termIn a . Sum.inject
|
||||
|
||||
|
||||
instance IsTerm (Term syntax) where
|
||||
type Syntax (Term syntax) = syntax
|
||||
|
||||
toTermF = unTerm
|
||||
fromTermF = Term
|
||||
@ -29,7 +29,6 @@ module Parsing.Parser
|
||||
) where
|
||||
|
||||
import AST.Unmarshal
|
||||
import Data.AST
|
||||
import Data.Language
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
@ -49,8 +48,6 @@ import qualified TreeSitter.Language as TS (Language)
|
||||
|
||||
-- | A parser from 'Source' onto some term type.
|
||||
data Parser term where
|
||||
-- | A parser producing 'AST' using a 'TS.Language'.
|
||||
ASTParser :: (Bounded grammar, Enum grammar, Show grammar) => Ptr TS.Language -> Parser (AST grammar)
|
||||
-- | A parser 'Unmarshal'ing to a precise AST type using a 'TS.Language'.
|
||||
UnmarshalParser :: Unmarshal t => Ptr TS.Language -> Parser (t Loc)
|
||||
|
||||
|
||||
@ -9,26 +9,20 @@
|
||||
module Parsing.TreeSitter
|
||||
( TSParseException (..)
|
||||
, Duration(..)
|
||||
, parseToAST
|
||||
, parseToPreciseAST
|
||||
) where
|
||||
|
||||
import Control.Carrier.Reader
|
||||
import Control.Exception as Exc
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Functor.Foldable
|
||||
import Foreign
|
||||
import GHC.Generics
|
||||
|
||||
import Data.AST (AST, Node (Node))
|
||||
import Data.Blob
|
||||
import Data.Duration
|
||||
import Data.Maybe.Exts
|
||||
import Data.Term
|
||||
import Source.Loc
|
||||
import qualified Source.Source as Source
|
||||
import Source.Span
|
||||
import qualified System.Timeout as System
|
||||
|
||||
import qualified TreeSitter.Cursor as TS
|
||||
@ -45,18 +39,6 @@ data TSParseException
|
||||
| UnmarshalFailure String
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
-- | Parse a 'Blob' with the given 'TS.Language' and return its AST.
|
||||
-- Returns 'Nothing' if the operation timed out.
|
||||
parseToAST :: ( Bounded grammar
|
||||
, Enum grammar
|
||||
, MonadIO m
|
||||
)
|
||||
=> Duration
|
||||
-> Ptr TS.Language
|
||||
-> Blob
|
||||
-> m (Either TSParseException (AST grammar))
|
||||
parseToAST parseTimeout language blob = runParse parseTimeout language blob (anaM toAST <=< peek)
|
||||
|
||||
parseToPreciseAST
|
||||
:: ( MonadIO m
|
||||
, TS.Unmarshal t
|
||||
@ -102,22 +84,3 @@ runParse parseTimeout language Blob{..} action =
|
||||
TS.withRootNode treePtr action
|
||||
else
|
||||
Exc.throw IncompatibleVersions
|
||||
|
||||
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST grammar) TS.Node)
|
||||
toAST node@TS.Node{..} = do
|
||||
let count = fromIntegral nodeChildCount
|
||||
children <- allocaArray count $ \ childNodesPtr -> do
|
||||
_ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` childNodesPtr)
|
||||
peekArray count childNodesPtr
|
||||
pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Loc (nodeRange node) (nodeSpan node))) children
|
||||
|
||||
anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t
|
||||
anaM g = a where a = pure . embed <=< traverse a <=< g
|
||||
|
||||
|
||||
nodeRange :: TS.Node -> Range
|
||||
nodeRange node = Range (fromIntegral (TS.nodeStartByte node)) (fromIntegral (TS.nodeEndByte node))
|
||||
|
||||
nodeSpan :: TS.Node -> Span
|
||||
nodeSpan node = TS.nodeStartPoint node `seq` TS.nodeEndPoint node `seq` Span (pointPos (TS.nodeStartPoint node)) (pointPos (TS.nodeEndPoint node))
|
||||
where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
|
||||
|
||||
@ -1,200 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Semantic.Analysis
|
||||
( evaluate
|
||||
, runDomainEffects
|
||||
, evalTerm
|
||||
) where
|
||||
|
||||
|
||||
import Control.Abstract as Abstract
|
||||
import Control.Algebra
|
||||
import Control.Carrier.Error.Either
|
||||
import Control.Carrier.Reader
|
||||
import Control.Effect.Interpose
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.Functor.Foldable
|
||||
import Data.Language (Language)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Source.Span
|
||||
|
||||
type ModuleC address value m
|
||||
= ErrorC (LoopControl value)
|
||||
( ErrorC (Return value)
|
||||
( ReaderC (CurrentScope address)
|
||||
( ReaderC (CurrentFrame address)
|
||||
( DerefC address value
|
||||
( AllocatorC address
|
||||
( ReaderC ModuleInfo
|
||||
m))))))
|
||||
|
||||
type DomainC term address value m
|
||||
= FunctionC term address value
|
||||
( WhileC value
|
||||
( BooleanC value
|
||||
( StringC value
|
||||
( NumericC value
|
||||
( BitwiseC value
|
||||
( ObjectC address value
|
||||
( ArrayC value
|
||||
( HashC value
|
||||
( UnitC value
|
||||
( InterposeC (Resumable (BaseError (UnspecializedError address value)))
|
||||
m))))))))))
|
||||
|
||||
-- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
|
||||
evaluate :: ( Algebra outerSig outer
|
||||
, derefSig ~ (Deref value :+: allocatorSig)
|
||||
, derefC ~ DerefC address value allocatorC
|
||||
, Algebra derefSig derefC
|
||||
, allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
|
||||
, allocatorC ~ AllocatorC address (ReaderC ModuleInfo outer)
|
||||
, Algebra allocatorSig allocatorC
|
||||
, Effect outerSig
|
||||
, Has Fresh outerSig outer
|
||||
, Has (Reader (ModuleTable (Module (ModuleResult address value)))) outerSig outer
|
||||
, Has (State (Heap address address value)) outerSig outer
|
||||
, Has (State (ScopeGraph address)) outerSig outer
|
||||
, Ord address
|
||||
)
|
||||
=> proxy (lang :: Language)
|
||||
-> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value)
|
||||
-> [Module term]
|
||||
-> Evaluator term address value outer (ModuleTable (Module (ModuleResult address value)))
|
||||
evaluate lang runModule modules = do
|
||||
let prelude = Module moduleInfoFromCallStack (Left lang)
|
||||
((preludeScopeAddress, preludeFrameAddress), _) <- evalModule Nothing Nothing prelude
|
||||
foldr (run preludeScopeAddress preludeFrameAddress . fmap Right) ask modules
|
||||
where run preludeScopeAddress preludeFrameAddress m rest = do
|
||||
evaluated <- evalModule (Just preludeScopeAddress) (Just preludeFrameAddress) m
|
||||
local (ModuleTable.insert (modulePath (moduleInfo m)) (evaluated <$ m)) rest
|
||||
|
||||
-- Run the allocator and Reader ModuleInfo effects (Some allocator instances depend on Reader ModuleInfo)
|
||||
-- after setting up the scope and frame for a module.
|
||||
evalModule parentScope parentFrame m = raiseHandler (runReader (moduleInfo m)) . runAllocator $ do
|
||||
let (scopeEdges, frameLinks) = case (parentScope, parentFrame) of
|
||||
(Just parentScope, Just parentFrame) -> (Map.singleton Lexical [ parentScope ], Map.singleton Lexical (Map.singleton parentScope parentFrame))
|
||||
_ -> mempty
|
||||
scopeAddress <- if Data.Foldable.null scopeEdges then newPreludeScope scopeEdges else newScope scopeEdges
|
||||
frameAddress <- newFrame scopeAddress frameLinks
|
||||
val <- runInModule scopeAddress frameAddress m
|
||||
pure ((scopeAddress, frameAddress), val)
|
||||
where runInModule scopeAddress frameAddress
|
||||
= runDeref
|
||||
. raiseHandler (runReader (CurrentFrame frameAddress))
|
||||
. raiseHandler (runReader (CurrentScope scopeAddress))
|
||||
. runReturn
|
||||
. runLoopControl
|
||||
. runModule
|
||||
|
||||
runDomainEffects :: ( AbstractValue term address value (DomainC term address value m)
|
||||
, unitC ~ UnitC value (InterposeC (Resumable (BaseError (UnspecializedError address value))) m)
|
||||
, unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig)
|
||||
, hashC ~ HashC value unitC
|
||||
, hashSig ~ (Abstract.Hash value :+: unitSig)
|
||||
, arrayC ~ ArrayC value hashC
|
||||
, arraySig ~ (Abstract.Array value :+: hashSig)
|
||||
, objectC ~ ObjectC address value arrayC
|
||||
, objectSig ~ (Abstract.Object address value :+: arraySig)
|
||||
, bitwiseC ~ BitwiseC value objectC
|
||||
, bitwiseSig ~ (Abstract.Bitwise value :+: objectSig)
|
||||
, numericC ~ NumericC value bitwiseC
|
||||
, numericSig ~ (Abstract.Numeric value :+: bitwiseSig)
|
||||
, stringC ~ StringC value numericC
|
||||
, stringSig ~ (Abstract.String value :+: numericSig)
|
||||
, booleanC ~ BooleanC value stringC
|
||||
, booleanSig ~ (Boolean value :+: stringSig)
|
||||
, whileC ~ WhileC value booleanC
|
||||
, whileSig ~ (While value :+: booleanSig)
|
||||
, functionC ~ FunctionC term address value whileC
|
||||
, functionSig ~ (Function term address value :+: whileSig)
|
||||
, Algebra functionSig functionC
|
||||
, HasPrelude lang
|
||||
, Has (Allocator address) sig m
|
||||
, Has (Deref value) sig m
|
||||
, Has Fresh sig m
|
||||
, Has (Reader (CurrentFrame address)) sig m
|
||||
, Has (Reader (CurrentScope address)) sig m
|
||||
, Has (Reader ModuleInfo) sig m
|
||||
, Has (Reader Span) sig m
|
||||
, Has (Resumable (BaseError (AddressError address value))) sig m
|
||||
, Has (Resumable (BaseError (HeapError address))) sig m
|
||||
, Has (Resumable (BaseError (ScopeError address))) sig m
|
||||
, Has (State (Heap address address value)) sig m
|
||||
, Has (State (ScopeGraph address)) sig m
|
||||
, Has Trace sig m
|
||||
, Ord address
|
||||
, Show address
|
||||
)
|
||||
=> (term -> Evaluator term address value (DomainC term address value m) value)
|
||||
-> Module (Either (proxy lang) term)
|
||||
-> Evaluator term address value m value
|
||||
runDomainEffects runTerm
|
||||
= raiseHandler runInterpose
|
||||
. runUnit
|
||||
. runHash
|
||||
. runArray
|
||||
. runObject
|
||||
. runBitwise
|
||||
. runNumeric
|
||||
. runString
|
||||
. runBoolean
|
||||
. runWhile
|
||||
. runFunction runTerm
|
||||
. either ((unit <*) . definePrelude) runTerm
|
||||
. moduleBody
|
||||
|
||||
-- | Evaluate a term recursively, applying the passed function at every recursive position.
|
||||
--
|
||||
-- This calls out to the 'Evaluatable' instances, and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term.
|
||||
evalTerm :: ( AbstractValue term address value m
|
||||
, AccessControls term
|
||||
, Declarations term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, HasSpan term
|
||||
, Has (Allocator address) sig m
|
||||
, Has (Bitwise value) sig m
|
||||
, Has (Boolean value) sig m
|
||||
, Has (Deref value) sig m
|
||||
, Has (Error (LoopControl value)) sig m
|
||||
, Has (Error (Return value)) sig m
|
||||
, Has (Function term address value) sig m
|
||||
, Has (Modules address value) sig m
|
||||
, Has (Numeric value) sig m
|
||||
, Has (Object address value) sig m
|
||||
, Has (Array value) sig m
|
||||
, Has (Hash value) sig m
|
||||
, Has (Reader ModuleInfo) sig m
|
||||
, Has (Reader PackageInfo) sig m
|
||||
, Has (Reader Span) sig m
|
||||
, Has (Resumable (BaseError (AddressError address value))) sig m
|
||||
, Has (Resumable (BaseError (HeapError address))) sig m
|
||||
, Has (Resumable (BaseError (ScopeError address))) sig m
|
||||
, Has (Resumable (BaseError (UnspecializedError address value))) sig m
|
||||
, Has (Resumable (BaseError (EvalError term address value))) sig m
|
||||
, Has (Resumable (BaseError ResolutionError)) sig m
|
||||
, Has (State (Heap address address value)) sig m
|
||||
, Has (State (ScopeGraph address)) sig m
|
||||
, Has (Abstract.String value) sig m
|
||||
, Has (Reader (CurrentFrame address)) sig m
|
||||
, Has (Reader (CurrentScope address)) sig m
|
||||
, Has (State Span) sig m
|
||||
, Has (Unit value) sig m
|
||||
, Has (While value) sig m
|
||||
, Has Fresh sig m
|
||||
, Has Trace sig m
|
||||
, Ord address
|
||||
, Recursive term
|
||||
, Show address
|
||||
)
|
||||
=> Open (term -> Evaluator term address value m value)
|
||||
-> term -> Evaluator term address value m value
|
||||
-- NB: We use a lazy pattern match for the lambda’s argument to postpone evaluating the pair until eval/ref is called.
|
||||
evalTerm perTerm = fst (fix (\ ~(ev, re) -> (perTerm (eval ev re . project), ref ev re . project)))
|
||||
@ -7,9 +7,7 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-}
|
||||
module Semantic.Util
|
||||
( mergeErrors
|
||||
, reassociate
|
||||
, parseFile
|
||||
( parseFile
|
||||
, parseFileQuiet
|
||||
) where
|
||||
|
||||
@ -17,12 +15,10 @@ import Prelude hiding (readFile)
|
||||
|
||||
import Analysis.File
|
||||
import Control.Carrier.Parse.Simple
|
||||
import Control.Carrier.Resumable.Either (SomeError (..))
|
||||
import Control.Effect.Reader
|
||||
import Control.Exception hiding (evaluate)
|
||||
import Control.Monad
|
||||
import qualified Data.Language as Language
|
||||
import Data.Sum
|
||||
import Parsing.Parser
|
||||
import Semantic.Config
|
||||
import Semantic.Task
|
||||
@ -40,9 +36,3 @@ fileForPath (Path.absRel -> p) = File p (point (Pos 1 1)) (Language.forPath p)
|
||||
runTask', runTaskQuiet :: ParseC TaskC a -> IO a
|
||||
runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
|
||||
runTaskQuiet task = runTaskWithOptions defaultOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
|
||||
|
||||
mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
|
||||
mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)
|
||||
|
||||
reassociate :: Either (SomeError err1) (Either (SomeError err2) (Either (SomeError err3) (Either (SomeError err4) (Either (SomeError err5) (Either (SomeError err6) (Either (SomeError err7) (Either (SomeError err8) result))))))) -> Either (SomeError (Sum '[err8, err7, err6, err5, err4, err3, err2, err1])) result
|
||||
reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right
|
||||
|
||||
@ -20,9 +20,7 @@ import Data.Bifunctor.Join
|
||||
import Data.Edit
|
||||
import qualified Data.Language as Language
|
||||
import Data.List.NonEmpty
|
||||
import Data.Term
|
||||
import Data.Text as T (Text, pack)
|
||||
import Data.Sum
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
import Test.LeanCheck
|
||||
@ -34,11 +32,6 @@ class Listable1 l where
|
||||
-- | The tiers for @l :: * -> *@, parameterized by the tiers for @a :: *@.
|
||||
liftTiers :: [Tier a] -> [Tier (l a)]
|
||||
|
||||
-- | A suitable definition of 'tiers' for 'Listable1' type constructors parameterized by 'Listable' types.
|
||||
tiers1 :: (Listable a, Listable1 l) => [Tier (l a)]
|
||||
tiers1 = liftTiers tiers
|
||||
|
||||
|
||||
-- | Lifting of 'Listable' to @* -> * -> *@.
|
||||
class Listable2 l where
|
||||
-- | The tiers for @l :: * -> * -> *@, parameterized by the tiers for @a :: *@ & @b :: *@.
|
||||
@ -85,22 +78,6 @@ instance Listable1 NonEmpty where
|
||||
instance Listable2 p => Listable1 (Join p) where
|
||||
liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join
|
||||
|
||||
instance Listable1 f => Listable2 (TermF f) where
|
||||
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In
|
||||
|
||||
instance (Listable1 f, Listable a) => Listable1 (TermF f a) where
|
||||
liftTiers = liftTiers2 tiers
|
||||
|
||||
instance (Listable1 f, Listable a, Listable b) => Listable (TermF f a b) where
|
||||
tiers = tiers1
|
||||
|
||||
instance Listable1 f => Listable1 (Term f) where
|
||||
liftTiers annotationTiers = go
|
||||
where go = liftCons1 (liftTiers2 annotationTiers go) Term
|
||||
|
||||
instance (Listable1 f, Listable a) => Listable (Term f a) where
|
||||
tiers = tiers1
|
||||
|
||||
instance Listable2 Edit where
|
||||
liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Compare
|
||||
|
||||
@ -108,16 +85,6 @@ instance (Listable a, Listable b) => Listable (Edit a b) where
|
||||
tiers = tiers2
|
||||
|
||||
|
||||
instance (Listable1 f, Listable1 (Sum (g ': fs))) => Listable1 (Sum (f ': g ': fs)) where
|
||||
liftTiers tiers = (inject `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)) \/ (weaken `mapT` ((liftTiers :: [Tier a] -> [Tier (Sum (g ': fs) a)]) tiers))
|
||||
|
||||
instance Listable1 f => Listable1 (Sum '[f]) where
|
||||
liftTiers tiers = inject `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)
|
||||
|
||||
instance (Listable1 (Sum fs), Listable a) => Listable (Sum fs a) where
|
||||
tiers = tiers1
|
||||
|
||||
|
||||
instance Listable Name.Name where
|
||||
tiers = cons1 Name.name
|
||||
|
||||
|
||||
@ -1,34 +0,0 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Parsing.Spec (spec) where
|
||||
|
||||
import Data.Blob
|
||||
import Data.ByteString.Char8 (pack)
|
||||
import Data.Duration
|
||||
import Data.Either
|
||||
import Data.Language
|
||||
import Parsing.TreeSitter
|
||||
import Source.Source
|
||||
import SpecHelpers
|
||||
import qualified System.Path as Path
|
||||
import Language.JSON.Grammar (Grammar, tree_sitter_json)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "parseToAST" $ do
|
||||
let source = toJSONSource [1 :: Int .. 10000]
|
||||
let largeBlob = fromSource (Path.relFile "large.json") JSON source
|
||||
|
||||
it "returns a result when the timeout does not expire" $ do
|
||||
let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout
|
||||
let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
|
||||
result <- runTaskOrDie parseTask
|
||||
isRight result `shouldBe` True
|
||||
|
||||
it "returns nothing when the timeout expires" $ do
|
||||
let timeout = fromMicroseconds 1000
|
||||
let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
|
||||
result <- runTaskOrDie parseTask
|
||||
isLeft result `shouldBe` True
|
||||
|
||||
toJSONSource :: Show a => a -> Source
|
||||
toJSONSource = fromUTF8 . pack . show
|
||||
@ -9,7 +9,6 @@ import qualified Data.Scientific.Spec
|
||||
import qualified Data.Semigroup.App.Spec
|
||||
import qualified Integration.Spec
|
||||
import qualified Numeric.Spec
|
||||
import qualified Parsing.Spec
|
||||
import qualified Tags.Spec
|
||||
import qualified Semantic.Spec
|
||||
import qualified Semantic.CLI.Spec
|
||||
@ -53,7 +52,6 @@ legacySpecs = parallel $ do
|
||||
describe "Tags.Spec" Tags.Spec.spec
|
||||
describe "Semantic" Semantic.Spec.spec
|
||||
describe "Semantic.IO" Semantic.IO.Spec.spec
|
||||
describe "Parsing" Parsing.Spec.spec
|
||||
|
||||
|
||||
main :: IO ()
|
||||
|
||||
@ -40,7 +40,6 @@ import Data.Monoid as X (First (..), Last (..), Monoid (..))
|
||||
import Data.Proxy as X
|
||||
import Data.Semigroup as X (Semigroup (..))
|
||||
import Data.Semilattice.Lower as X
|
||||
import Data.Term as X
|
||||
import Data.Traversable as X (for)
|
||||
import Debug.Trace as X (traceM, traceShowM)
|
||||
import Parsing.Parser as X
|
||||
|
||||
Loading…
Reference in New Issue
Block a user