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

Merge branch 'master' into my-grate

Browse Source
This commit is contained in:
Ayman Nadeem 2020-01-29 17:17:36 -05:00
commit fc3fdf7632
109 changed files with 1341 additions and 617 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
docs/coding-style.md
View File

@ -13,8 +13,6 @@ Our CI systems ensure that all patches pass `hlint`'s muster. We have our own se
We strongly recommend adding Haddock documentation to any function/data type, unless its purpose is immediately apparent from its name.
Comments should describe the "why", type signatures should describe the "what", and the code should describe the "how".
The Haskell Prelude is too minimal for serious work. The `Prologue` module should be imported in most files, as it reexports most of what you need.
# Formatting
2 spaces everywhere. Tabs are forbidden. Haskell indentation can be unpredictable, so generally stick with what your editor suggests.
@ -50,14 +48,6 @@ data Pos = Pos
}
```
### Split up imports into logical groups.
We use the following convention, each section separated by a newline:
1. Prelude/Prologue import
2. Library/stdlib imports
3. Local in-project imports.
### Align typographical symbols.
`->` in `case` statements and signatures, `=` in functions, and `::` in records should be aligned. Your editor can help with this. In certain situations, aligning symbols may decrease readability, e.g. complicated `case` statements. Use your best judgment.
@ -66,7 +56,7 @@ We use the following convention, each section separated by a newline:
Locally bound variables (such as the arguments to functions, or helpers defined in a `where` clause) can have short names, such as `x` or `go`. Globally bound functions and variables should have descriptive names.
You'll often find yourself implementing functions that conflict with Prelude/Prologue definitions. If this is the case, avoid adding a prefix to these functions, and instead import them qualified.
You'll often find yourself implementing functions that conflict with Prelude definitions. If this is the case, avoid adding a prefix to these functions, and instead import them qualified.
``` haskell
-- Broke

2
semantic.cabal
View File

@ -158,6 +158,7 @@ library
, Data.JSON.Fields
, Data.Language
, Data.Map.Monoidal
, Data.Maybe.Exts
, Data.Project
, Data.Quieterm
, Data.Semigroup.App
@ -254,7 +255,6 @@ library
, Tags.Taggable
, Tags.Tagging
-- Custom Prelude
, Prologue
autogen-modules: Paths_semantic
other-modules: Paths_semantic
build-depends: base >= 4.13 && < 5

18
src/Analysis/Abstract/Caching/FlowInsensitive.hs
View File

@ -1,17 +1,25 @@
{-# LANGUAGE DeriveFunctor, FlexibleContexts, GeneralizedNewtypeDeriving, TypeApplications, TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Analysis.Abstract.Caching.FlowInsensitive
( cachingTerms
, convergingModules
, caching
) where
import Prologue
import Control.Algebra (Effect)
import Control.Carrier.Fresh.Strict
import Control.Carrier.NonDet.Church
import Control.Carrier.Reader
import Control.Carrier.State.Strict
import Data.Bifunctor
import Data.Foldable
import Data.Functor.Classes
import Data.Maybe.Exts
import Data.Semilattice.Lower
import Data.Set (Set)
import Control.Abstract
import Data.Abstract.Module
@ -194,8 +202,8 @@ newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuratio
-- | A single point in a program’s execution.
data Configuration term address = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
}
deriving (Eq, Ord, Show)

18
src/Analysis/Abstract/Caching/FlowSensitive.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, TypeApplications, TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Analysis.Abstract.Caching.FlowSensitive
( Cache
, cachingTerms
@ -6,13 +11,18 @@ module Analysis.Abstract.Caching.FlowSensitive
, caching
) where
import Prologue
import Control.Algebra (Effect)
import Control.Carrier.Fresh.Strict
import Control.Carrier.NonDet.Church
import Control.Carrier.Reader
import Control.Carrier.Fresh.Strict
import Control.Carrier.State.Strict
import Data.Bifunctor
import Data.Foldable
import Data.Functor
import Data.Functor.Classes
import Data.Maybe.Exts
import Data.Semilattice.Lower
import Data.Set (Set)
import Control.Abstract
import Data.Abstract.Module

2
src/Analysis/Abstract/Collecting.hs
View File

@ -4,7 +4,7 @@ module Analysis.Abstract.Collecting
import Control.Abstract
import Control.Carrier.Reader
import Prologue
import Data.Semilattice.Lower
providingLiveSet :: Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a
providingLiveSet = raiseHandler (runReader lowerBound)

11
src/Analysis/Abstract/Dead.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
module Analysis.Abstract.Dead
( Dead(..)
, revivingTerms
@ -9,9 +13,10 @@ module Analysis.Abstract.Dead
import Control.Abstract
import Control.Carrier.State.Strict
import Data.Abstract.Module
import Data.Functor.Foldable
import Data.Semigroup.Reducer as Reducer
import Data.Set (delete)
import Prologue
import Data.Semilattice.Lower
import Data.Set (Set, delete)
-- | A set of “dead” (unreachable) terms.
newtype Dead term = Dead { unDead :: Set term }

17
src/Analysis/Abstract/Graph.hs
View File

@ -1,4 +1,13 @@
{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.Abstract.Graph
( Graph(..)
, ControlFlowVertex(..)
@ -17,7 +26,7 @@ module Analysis.Abstract.Graph
) where
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract hiding (Function(..))
import Control.Abstract hiding (Function (..))
import Control.Algebra
import Control.Carrier.Reader
import Control.Carrier.State.Strict
@ -27,9 +36,9 @@ import Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..))
import Data.ByteString.Builder
import Data.Graph.Algebraic
import Data.Graph.ControlFlowVertex
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Text.Encoding as T
import Prologue
import Source.Loc
style :: Style ControlFlowVertex Builder
@ -123,7 +132,7 @@ graphingModules recur m = do
where
-- NB: path is null for Languages like Ruby that have module imports that require concrete value semantics.
includeModule path
= let path' = if Prologue.null path then "unknown, concrete semantics required" else path
= let path' = if Prelude.null path then "unknown, concrete semantics required" else path
info = moduleInfo m
in moduleInclusion (moduleVertex (ModuleInfo path' (moduleLanguage info) (moduleOid info)))

11
src/Analysis/ConstructorName.hs
View File

@ -1,12 +1,19 @@
{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.ConstructorName
( ConstructorName(..)
) where
import Data.Proxy
import Data.Sum
import Data.Term
import GHC.Generics
import Prologue
-- | A typeclass to retrieve the name of the data constructor for a value.
--

18
src/Analysis/CyclomaticComplexity.hs
View File

@ -1,16 +1,24 @@
{-# LANGUAGE DataKinds, DefaultSignatures, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
{-# 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.Sum
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
import Prologue
import Data.Term
-- | The cyclomatic complexity of a (sub)term.
newtype CyclomaticComplexity = CyclomaticComplexity Int

7
src/Analysis/Decorator.hs
View File

@ -1,10 +1,13 @@
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Analysis.Decorator
( decoratorWithAlgebra
) where
import Data.Algebra
import Data.Bifunctor
import Data.Functor.Foldable
import Data.Term
import Prologue
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: (Functor (Syntax term), IsTerm term, Recursive (term a), Base (term a) ~ TermF (Syntax term) a)

2
src/Analysis/HasTextElement.hs
View File

@ -4,7 +4,7 @@ module Analysis.HasTextElement
) where
import Data.Sum
import Prologue
import Data.Proxy
import qualified Data.Syntax.Literal as Literal
class HasTextElement syntax where

22
src/Analysis/PackageDef.hs
View File

@ -1,18 +1,26 @@
{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.PackageDef
( PackageDef(..)
, HasPackageDef
, packageDefAlgebra
) where
import Data.Blob
import Source.Source as Source
import Data.Sum
import Data.Term
import Data.Algebra
import Data.Blob
import Data.Proxy
import Data.Sum
import Data.Term
import qualified Data.Text as T
import qualified Language.Go.Syntax
import Prologue
import Source.Loc
import Source.Loc
import Source.Source as Source
newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
deriving (Eq, Show)

24
src/Analysis/TOCSummary.hs
View File

@ -1,4 +1,18 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Analysis.TOCSummary
( Declaration(..)
, formatIdentifier
@ -8,15 +22,19 @@ module Analysis.TOCSummary
, declarationAlgebra
) where
import Prologue hiding (project)
import Data.Algebra
import Data.Blob
import qualified Data.Error as Error
import Data.Flag
import Data.Foldable (toList)
import Data.Language as Language
import Data.List.NonEmpty (nonEmpty)
import Data.Semigroup (sconcat)
import Data.Sum
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Data.Term
import Data.Text (Text)
import qualified Data.Text as T
import qualified Language.Markdown.Syntax as Markdown
import Source.Loc as Loc

83
src/Assigning/Assignment.hs
View File

@ -1,4 +1,15 @@
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | Assignment of AST onto some other structure (typically terms).
--
-- Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and Span). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference.
@ -90,20 +101,32 @@ module Assigning.Assignment
, module Parsers
) where
import Prologue
import Prelude hiding (fail)
import qualified Assigning.Assignment.Table as Table
import Control.Monad.Except (MonadError (..))
import Data.AST
import Data.Error
import qualified Source.Source as Source
import Data.Term
import Data.Text.Encoding (decodeUtf8')
import Control.Applicative
import Control.Monad
import Control.Monad.Except (MonadError (..))
import Data.AST
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Error
import Data.Foldable
import Data.Function
import Data.Functor.Classes
import Data.Ix
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Term
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import GHC.Stack
import Prelude hiding (fail)
import qualified Source.Loc as L
import Source.Range as Range
import Source.Span as Span
import Text.Parser.Combinators as Parsers hiding (choice)
import TreeSitter.Language
import Source.Range as Range
import qualified Source.Source as Source
import Source.Span as Span
import Text.Parser.Combinators as Parsers hiding (choice)
import TreeSitter.Language
-- | Assignment from an AST with some set of 'symbol's onto some other value.
--
@ -129,12 +152,12 @@ data Tracing f a where
assignmentCallSite :: Assignment ast grammar a -> Maybe (String, SrcLoc)
assignmentCallSite (Tracing site _ `Then` _) = site
assignmentCallSite _ = Nothing
assignmentCallSite _ = Nothing
tracing :: HasCallStack => f a -> Tracing f a
tracing f = case getCallStack callStack of
(_ : site : _) -> Tracing (Just site) f
_ -> Tracing Nothing f
_ -> Tracing Nothing f
-- | Zero-width production of the current location.
--
@ -209,8 +232,8 @@ nodeError cs expected n@Node{..} = Error (nodeSpan n) expected (Just (Right node
firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
firstSet = iterFreer (\ _ (Tracing _ assignment) -> case assignment of
Choose table _ _ -> Table.tableAddresses table
Label child _ -> firstSet child
_ -> []) . ([] <$)
Label child _ -> firstSet child
_ -> []) . ([] <$)
-- | Run an assignment over an AST exhaustively.
@ -275,7 +298,7 @@ requireExhaustive callSite (a, state) =
let state' = skipTokens state
stack = fromCallSiteList (maybe id (:) callSite (stateCallSites state))
in case stateNodes state' of
[] -> Right (a, state')
[] -> Right (a, state')
Term (In node _) : _ -> Left (nodeError stack [] node)
skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
@ -289,11 +312,11 @@ advanceState state@State{..}
-- | State kept while running 'Assignment's.
data State ast grammar = State
{ stateOffset :: {-# UNPACK #-} !Int -- ^ The offset into the Source thus far reached, measured in bytes.
, statePos :: {-# UNPACK #-} !Pos -- ^ The (1-indexed) line/column position in the Source thus far reached.
{ stateOffset :: {-# UNPACK #-} !Int -- ^ The offset into the Source thus far reached, measured in bytes.
, statePos :: {-# UNPACK #-} !Pos -- ^ The (1-indexed) line/column position in the Source thus far reached.
, stateCallSites :: ![(String, SrcLoc)] -- ^ The symbols & source locations of the calls thus far.
, stateNodes :: ![AST ast grammar] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
, stateLocals :: ![Text] -- Special state necessary for the Ruby assignment. When we refactor Assignment to use effects we should pull this out into Language.Ruby.Assignment.
, stateNodes :: ![AST ast grammar] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
, stateLocals :: ![Text] -- Special state necessary for the Ruby assignment. When we refactor Assignment to use effects we should pull this out into Language.Ruby.Assignment.
}
deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar)
@ -315,13 +338,13 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast gram
l@(Tracing callSiteL la `Then` continueL) <|> r@(Tracing callSiteR ra `Then` continueR) = go callSiteL la continueL callSiteR ra continueR
where go :: forall l r . Maybe (String, SrcLoc) -> AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> Maybe (String, SrcLoc) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
go callSiteL la continueL callSiteR ra continueR = case (la, ra) of
(Fail _, _) -> r
(Alt [], _) -> r
(_, Alt []) -> l
(Fail _, _) -> r
(Alt [], _) -> r
(_, Alt []) -> l
(Alt ls, Alt rs) -> alternate (Alt ((Left <$> ls) <> (Right <$> rs)))
(Alt ls, _) -> rebuild (Alt ((continueL <$> ls) <> pure r)) id
(_, Alt rs) -> rebuild (Alt (pure l <> (continueR <$> rs))) id
_ -> rebuild (Alt [l, r]) id
(Alt ls, _) -> rebuild (Alt ((continueL <$> ls) <> pure r)) id
(_, Alt rs) -> rebuild (Alt (pure l <> (continueR <$> rs))) id
_ -> rebuild (Alt [l, r]) id
where alternate :: AssignmentF ast grammar (Either l r) -> Assignment ast grammar a
alternate a = rebuild a (either continueL continueR)
rebuild :: AssignmentF ast grammar x -> (x -> Assignment ast grammar a) -> Assignment ast grammar a
@ -368,7 +391,7 @@ infixl 1 `Then`
instance Functor (Freer f) where
fmap f = go
where go (Return result) = Return (f result)
where go (Return result) = Return (f result)
go (Then step yield) = Then step (go . yield)
{-# INLINE go #-}
{-# INLINE fmap #-}
@ -405,7 +428,7 @@ instance Monad (Freer f) where
-- 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
where go (Return result) = result
go (Then action continue) = algebra (go . continue) action
{-# INLINE go #-}
{-# INLINE iterFreer #-}

14
src/Assigning/Assignment/Table.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE DeriveGeneric, DeriveTraversable, DerivingVia, RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RecordWildCards #-}
module Assigning.Assignment.Table
( Table(tableAddresses)
, singleton
@ -7,10 +10,15 @@ module Assigning.Assignment.Table
, lookup
) where
import Prologue
import Prelude hiding (lookup)
import Data.Bifunctor
import Data.Functor.Classes
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Monoid.Generic
import Data.Traversable
import GHC.Generics (Generic)
import Prelude hiding (lookup)
data Table i a = Table { tableAddresses :: [i], tableBranches :: IntMap a }
deriving (Eq, Foldable, Functor, Show, Traversable, Generic)

2
src/Control/Abstract/Context.hs
View File

@ -17,8 +17,8 @@ import Control.Effect.Reader
import Control.Effect.State
import Data.Abstract.Module
import Data.Abstract.Package
import Data.Maybe
import GHC.Stack
import Prologue
import Source.Span
-- | Get the currently evaluating 'ModuleInfo'.

23
src/Control/Abstract/Heap.hs
View File

@ -1,6 +1,15 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeOperators,
UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.Heap
( Heap
, HeapError(..)
@ -60,8 +69,14 @@ import qualified Data.Abstract.Heap as Heap
import Data.Abstract.Live
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.ScopeGraph (Kind (..), Path (..), putDeclarationScopeAtPosition)
import Data.Functor.Classes
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Prologue
import Data.Maybe.Exts
import Data.Semilattice.Lower
import Data.Set (Set)
import GHC.Generics (Generic1)
import GHC.Stack
import Source.Span (Span)

26
src/Control/Abstract/Modules.hs
View File

@ -1,6 +1,17 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving,
KindSignatures, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators,
OverloadedStrings, UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.Modules
( ModuleResult
, lookupModule
@ -21,13 +32,18 @@ module Control.Abstract.Modules
, ModuleTable
) where
import Prologue
import Control.Algebra
import Control.Carrier.Reader
import qualified Control.Carrier.Resumable.Either as Either
import qualified Control.Carrier.Resumable.Resume as With
import Control.Monad.IO.Class
import Data.Foldable
import Data.Functor.Classes
import Data.Maybe.Exts
import Data.Semilattice.Lower
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic1)
import Source.Span
import System.FilePath.Posix (takeDirectory)

26
src/Control/Abstract/Primitive.hs
View File

@ -1,20 +1,26 @@
{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Control.Abstract.Primitive
( defineClass
, defineNamespace
, defineBuiltIn
) where
import Analysis.Name
import Control.Abstract.Context
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph
import Control.Abstract.Value
import Data.Abstract.BaseError
import Analysis.Name
import Control.Abstract.Context
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph
import Control.Abstract.Value
import Control.Monad
import Data.Abstract.BaseError
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Map.Strict as Map
import Prologue
import Data.Map.Strict as Map
import Data.Maybe
import Data.Semilattice.Lower
import Data.Traversable
import GHC.Stack
defineBuiltIn :: ( HasCallStack
, Has (Deref value) sig m

10
src/Control/Abstract/PythonPackage.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.PythonPackage
( runPythonPackaging, Strategy(..) ) where
@ -6,10 +10,12 @@ import Analysis.Name (name)
import Control.Abstract as Abstract
import Control.Algebra
import Control.Effect.Sum.Project
import Control.Monad
import Data.Abstract.Path (stripQuotes)
import Data.Abstract.Value.Concrete (Value (..))
import qualified Data.Map as Map
import Prologue
import Data.Semilattice.Lower
import Data.Text (Text)
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)

34
src/Control/Abstract/ScopeGraph.hs
View File

@ -1,4 +1,16 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.ScopeGraph
( lookup
, declare
@ -46,14 +58,28 @@ module Control.Abstract.ScopeGraph
import Analysis.Name hiding (name)
import Control.Abstract.Evaluator hiding (Local)
import Control.Algebra
import qualified Control.Carrier.Resumable.Resume as With
import qualified Control.Carrier.Resumable.Either as Either
import qualified Control.Carrier.Resumable.Resume as With
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.ScopeGraph (Kind, Declaration(..), EdgeLabel, Reference, Relation(..), Scope (..), ScopeGraph, Slot(..), Info(..), AccessControl(..))
import Data.Abstract.ScopeGraph
( AccessControl (..)
, Declaration (..)
, EdgeLabel
, Info (..)
, Kind
, Reference
, Relation (..)
, Scope (..)
, ScopeGraph
, Slot (..)
)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes
import Data.Map (Map)
import Data.Maybe.Exts
import GHC.Generics (Generic1)
import Prelude hiding (lookup)
import Prologue
import Source.Span
lookup :: ( Ord address

16
src/Control/Abstract/Value.hs
View File

@ -1,5 +1,13 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractIntro(..)
@ -81,9 +89,11 @@ import Control.Carrier.Reader
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.Number (Number, SomeNumber)
import Data.Bits
import Data.Scientific (Scientific)
import Data.Text (Text)
import GHC.Generics (Generic, Generic1)
import Prelude hiding (String)
import Prologue hiding (TypeError, hash)
import Source.Span
-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP

16
src/Control/Carrier/Parse/Measured.hs
View File

@ -1,4 +1,11 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | A carrier for 'Parse' effects suitable for use in production.
module Control.Carrier.Parse.Measured
( -- * Parse carrier
@ -16,17 +23,18 @@ import Control.Effect.Parse
import Control.Effect.Reader
import Control.Effect.Trace
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Blob
import qualified Data.Error as Error
import qualified Data.Flag as Flag
import Data.Foldable
import qualified Data.Syntax as Syntax
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (project)
import Semantic.Config
import Semantic.Task (TaskSession(..))
import Semantic.Task (TaskSession (..))
import Semantic.Telemetry
import Semantic.Timeout
import Source.Source (Source)
@ -43,7 +51,7 @@ instance ( Has (Error SomeException) sig m
)
=> Algebra (Parse :+: sig) (ParseC m) where
alg (L (Parse parser blob k)) = runParser blob parser >>= k
alg (R other) = ParseC (alg (handleCoercible other))
alg (R other) = ParseC (alg (handleCoercible other))
-- | Parse a 'Blob' in 'IO'.
runParser :: (Has (Error SomeException) sig m, Has (Reader TaskSession) sig m, Has Telemetry sig m, Has Timeout sig m, Has Trace sig m, MonadIO m)

20
src/Control/Effect/REPL.hs
View File

@ -1,4 +1,12 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Effect.REPL
( REPL (..)
@ -8,12 +16,14 @@ module Control.Effect.REPL
, runREPL
) where
import Prologue
import Control.Algebra
import Control.Carrier.Reader
import System.Console.Haskeline
import Control.Algebra
import Control.Carrier.Reader
import Control.Monad.IO.Class
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic1)
import System.Console.Haskeline
data REPL (m :: * -> *) k
= Prompt Text (Maybe Text -> m k)

10
src/Data/Abstract/Address/Hole.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Address.Hole
( Hole(..)
, toMaybe
@ -6,7 +10,7 @@ module Data.Abstract.Address.Hole
import Control.Abstract
import Control.Algebra
import Prologue
import Data.Semilattice.Lower
data Hole context a = Partial context | Total a
deriving (Foldable, Functor, Eq, Ord, Show, Traversable)
@ -27,7 +31,7 @@ instance ( Algebra (Allocator address :+: sig) (AllocatorC address m)
, Monad m
)
=> Algebra (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
alg (R other) = AllocatorC . alg . handleCoercible $ other
alg (R other) = AllocatorC . alg . handleCoercible $ other
alg (L (Alloc name k)) = Total <$> promoteA (alg (L (Alloc name pure))) >>= k

22
src/Data/Abstract/Address/Monovariant.hs
View File

@ -1,13 +1,17 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Address.Monovariant
( Monovariant(..)
) where
import Prologue
import Analysis.Name
import Control.Abstract
import Control.Algebra
import Analysis.Name
import Control.Abstract
import Control.Algebra
import Data.Foldable
import Data.Functor.Classes
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Set as Set
-- | 'Monovariant' models using one address for a particular name. It tracks the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
@ -20,9 +24,9 @@ instance Show Monovariant where
instance Algebra sig m => Algebra (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
alg (L (Alloc name k)) = k (Monovariant name)
alg (R other) = AllocatorC . alg . handleCoercible $ other
alg (R other) = AllocatorC . alg . handleCoercible $ other
instance (Ord value, Algebra sig m, Alternative m, Monad m) => Algebra (Deref value :+: sig) (DerefC Monovariant value m) where
alg (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k
alg (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k
alg (L (AssignCell value cell k)) = k (Set.insert value cell)
alg (R other) = DerefC . alg . handleCoercible $ other
alg (R other) = DerefC . alg . handleCoercible $ other

7
src/Data/Abstract/Address/Precise.hs
View File

@ -1,12 +1,15 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Address.Precise
( Precise(..)
) where
import Control.Abstract
import Control.Algebra
import Data.Functor.Classes
import qualified Data.Set as Set
import Prologue
-- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
newtype Precise = Precise { unPrecise :: Int }

10
src/Data/Abstract/BaseError.hs
View File

@ -1,14 +1,16 @@
{-# LANGUAGE FlexibleContexts, KindSignatures, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Abstract.BaseError (
BaseError(..)
, throwBaseError
)
where
import Control.Abstract.Context
import Control.Abstract.Evaluator
import Control.Abstract.Context
import Control.Abstract.Evaluator
import qualified Data.Abstract.Module as M
import Prologue
import Data.Functor.Classes
import qualified Source.Span as S
data BaseError (exc :: * -> *) resume = BaseError { baseErrorModuleInfo :: ModuleInfo, baseErrorSpan :: Span, baseErrorException :: exc resume }

72
src/Data/Abstract/Evaluatable.hs
View File

@ -1,4 +1,13 @@
{-# LANGUAGE DataKinds, FlexibleContexts, GADTs, KindSignatures, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
@ -18,31 +27,58 @@ module Data.Abstract.Evaluatable
, __self
) where
import Prologue
import Control.Algebra
import qualified Control.Carrier.Resumable.Either as Either
import qualified Control.Carrier.Resumable.Resume as With
import Data.Foldable
import Data.Functor.Classes
import Data.List.NonEmpty (nonEmpty)
import Data.Scientific (Scientific)
import Data.Semigroup.Foldable
import Source.Span (HasSpan(..))
import Data.Semilattice.Lower
import Data.Sum
import Data.Text
import GHC.Stack
import Source.Span (HasSpan (..))
import Analysis.Name as X
import Control.Abstract hiding (Load, String)
import Analysis.Name as X
import Control.Abstract hiding (Load, String)
import qualified Control.Abstract as Abstract
import Control.Abstract.Context as X
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..))
import Data.Abstract.BaseError as X
import Data.Abstract.Declarations as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Control.Abstract.Context as X
import Control.Abstract.Evaluator as X hiding
(LoopControl (..), Return (..), catchLoopControl, catchReturn, runLoopControl, runReturn)
import Control.Abstract.Modules as X
( ModuleResult
, Modules
, ResolutionError (..)
, listModulesInDir
, load
, lookupModule
, require
, resolve
, throwResolutionError
)
import Control.Abstract.Value as X hiding
( Array (..)
, Bitwise (..)
, Boolean (..)
, Function (..)
, Hash (..)
, Numeric (..)
, Object (..)
, String (..)
, Unit (..)
, While (..)
)
import Data.Abstract.AccessControls.Class as X
import Data.Abstract.BaseError as X
import Data.Abstract.Declarations as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.AccessControls.Class as X
import Data.Language
import Data.Semigroup.App
import Data.Term
import Data.Language
import Data.Semigroup.App
import Data.Term
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
class (Show1 constr, Foldable constr) => Evaluatable constr where

8
src/Data/Abstract/FreeVariables.hs
View File

@ -1,13 +1,17 @@
{-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeApplications, UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.FreeVariables
( FreeVariables (..)
, FreeVariables1 (..)
) where
import Analysis.Name
import Data.Set (Set)
import Data.Sum
import Data.Term
import Prologue
-- | Types which can contain unbound variables.
class FreeVariables term where

11
src/Data/Abstract/Heap.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Abstract.Heap
( Heap(..)
, Frame(..)
@ -36,10 +38,15 @@ import Data.Abstract.ScopeGraph
, pathDeclaration
, pathPosition
)
import Data.Foldable
import Data.Functor.Classes
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Semilattice.Lower
import Data.Set (Set)
import Prelude hiding (lookup)
import Prologue
-- | A Frame describes the vertices of the Heap. Think of it as an instance of a Scope in the ScopeGraph.
data Frame scopeAddress frameAddress value = Frame

13
src/Data/Abstract/Live.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Abstract.Live
( Live (..)
, fromAddresses
@ -11,15 +14,17 @@ module Data.Abstract.Live
, liveMap
) where
import Data.Set as Set
import Prologue
import Data.Function
import Data.Functor.Classes
import Data.Semilattice.Lower
import Data.Set as Set hiding (foldr)
-- | A set of live addresses (whether roots or reachable).
newtype Live address = Live { unLive :: Set address }
deriving (Eq, Lower, Monoid, Ord, Semigroup)
fromAddresses :: (Foldable t, Ord address) => t address -> Live address
fromAddresses = Prologue.foldr liveInsert lowerBound
fromAddresses = foldr liveInsert lowerBound
-- | Construct a 'Live' set containing only the given address.
liveSingleton :: address -> Live address

13
src/Data/Abstract/ModuleTable.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Abstract.ModuleTable
( ModulePath
, ModuleTable (..)
@ -13,11 +14,13 @@ module Data.Abstract.ModuleTable
, toPairs
) where
import Data.Abstract.Module
import Data.Abstract.Module
import Data.Functor.Classes
import qualified Data.Map as Map
import Prelude hiding (lookup)
import Prologue
import System.FilePath.Posix
import Data.Semilattice.Lower
import Data.Set (Set)
import Prelude hiding (lookup)
import System.FilePath.Posix
newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)

16
src/Data/Abstract/Number.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE GADTs, StandaloneDeriving, RankNTypes, TypeApplications #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Data.Abstract.Number
( Number (..)
@ -9,10 +13,10 @@ module Data.Abstract.Number
, liftedFloorDiv
) where
import Data.Scientific
import Data.Function (on)
import Data.Scientific
import Prelude hiding (Integer)
import qualified Prelude
import Prelude hiding (Integer)
import Prologue
-- | A generalized number type that unifies all interpretable numeric types.
-- This is a GADT, so you can specialize the 'a' parameter and be confident
@ -34,13 +38,13 @@ deriving instance Eq a => Eq (Number a)
instance Show (Number a) where
show (Integer i) = show i
show (Ratio r) = show r
show (Ratio r) = show r
show (Decimal d) = show d
-- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance.
toScientific :: Number a -> Scientific
toScientific (Integer i) = fromInteger i
toScientific (Ratio r) = fromRational r
toScientific (Ratio r) = fromRational r
toScientific (Decimal s) = s
instance Eq a => Ord (Number a) where compare = compare `on` toScientific

4
src/Data/Abstract/Path.hs
View File

@ -4,9 +4,9 @@ module Data.Abstract.Path
, stripQuotes
) where
import Prologue
import Data.Text (Text)
import qualified Data.Text as T
import System.FilePath.Posix
import System.FilePath.Posix
-- | Join two paths a and b. Handles walking up relative directories in b. e.g.
--

38
src/Data/Abstract/Value/Abstract.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Value.Abstract
( Abstract (..)
, runFunction
@ -6,12 +10,12 @@ module Data.Abstract.Value.Abstract
, runWhile
) where
import Control.Abstract as Abstract
import Control.Algebra
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Control.Abstract as Abstract
import Control.Algebra
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Foldable
import qualified Data.Map.Strict as Map
import Prologue
data Abstract = Abstract
deriving (Eq, Ord, Show)
@ -76,7 +80,7 @@ instance ( Has (Abstract.Boolean Abstract) sig m
instance Algebra sig m
=> Algebra (Unit Abstract :+: sig) (UnitC Abstract m) where
alg (R other) = UnitC . alg . handleCoercible $ other
alg (R other) = UnitC . alg . handleCoercible $ other
alg (L (Abstract.Unit k)) = k Abstract
instance Algebra sig m
@ -90,18 +94,18 @@ instance Algebra sig m
=> Algebra (Numeric Abstract :+: sig) (NumericC Abstract m) where
alg (R other) = NumericC . alg . handleCoercible $ other
alg (L op) = case op of
Integer _ k -> k Abstract
Float _ k -> k Abstract
Rational _ k -> k Abstract
LiftNumeric _ _ k -> k Abstract
Integer _ k -> k Abstract
Float _ k -> k Abstract
Rational _ k -> k Abstract
LiftNumeric _ _ k -> k Abstract
LiftNumeric2 _ _ _ k -> k Abstract
instance Algebra sig m
=> Algebra (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where
alg (R other) = BitwiseC . alg . handleCoercible $ other
alg (L op) = case op of
CastToInteger _ k -> k Abstract
LiftBitwise _ _ k -> k Abstract
CastToInteger _ k -> k Abstract
LiftBitwise _ _ k -> k Abstract
LiftBitwise2 _ _ _ k -> k Abstract
UnsignedRShift _ _ k -> k Abstract
@ -109,22 +113,22 @@ instance Algebra sig m
=> Algebra (Object address Abstract :+: sig) (ObjectC address Abstract m) where
alg (R other) = ObjectC . alg . handleCoercible $ other
alg (L op) = case op of
Object _ k -> k Abstract
Object _ k -> k Abstract
ScopedEnvironment _ k -> k Nothing
Klass _ _ k -> k Abstract
Klass _ _ k -> k Abstract
instance Algebra sig m
=> Algebra (Array Abstract :+: sig) (ArrayC Abstract m) where
alg (R other) = ArrayC . alg . handleCoercible $ other
alg (L op) = case op of
Array _ k -> k Abstract
Array _ k -> k Abstract
AsArray _ k -> k []
instance Algebra sig m
=> Algebra (Hash Abstract :+: sig) (HashC Abstract m) where
alg (R other) = HashC . alg . handleCoercible $ other
alg (L op) = case op of
Hash _ k -> k Abstract
Hash _ k -> k Abstract
KvPair _ _ k -> k Abstract

25
src/Data/Abstract/Value/Concrete.hs
View File

@ -1,5 +1,14 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, LambdaCase, MultiParamTypeClasses, RankNTypes,
ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Value.Concrete
( Value (..)
, ValueError (..)
@ -7,15 +16,21 @@ module Data.Abstract.Value.Concrete
, runValueErrorWith
) where
import Prologue
import Control.Carrier.Resumable.Either (SomeError)
import qualified Control.Carrier.Resumable.Either as Either
import qualified Control.Carrier.Resumable.Resume as With
import Control.Exception (ArithException)
import Data.Bits (shiftR)
import Data.Foldable
import Data.Function
import Data.Functor
import Data.Functor.Classes
import Data.List (genericIndex, genericLength)
import qualified Data.Map.Strict as Map
import Data.Scientific.Exts
import Data.Text (pack)
import Data.Semilattice.Lower
import Data.Text (Text, pack)
import Data.Word
import Analysis.Name
import Control.Abstract hiding

85
src/Data/Abstract/Value/Type.hs
View File

@ -1,4 +1,15 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, LambdaCase, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Value.Type
( Type (..)
, TypeError (..)
@ -11,21 +22,23 @@ module Data.Abstract.Value.Type
, runWhile
) where
import Prologue hiding (TypeError)
import Control.Algebra
import Control.Carrier.State.Strict
import qualified Control.Carrier.Resumable.Resume as With
import Control.Carrier.Resumable.Either (SomeError)
import qualified Control.Carrier.Resumable.Either as Either
import qualified Control.Carrier.Resumable.Resume as With
import Control.Carrier.State.Strict
import Control.Monad
import Data.Functor
import Data.Functor.Classes
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.Map as Map
import Control.Abstract.ScopeGraph
import Control.Abstract hiding
(Array (..), Boolean (..), Function (..), Hash (..), Numeric (..), Object (..), String (..), Unit (..), While (..))
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..))
import Data.Abstract.BaseError
import Data.Semigroup.Foldable (foldMap1)
import Data.Abstract.Evaluatable
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Semigroup.Foldable (foldMap1)
type TName = Int
@ -81,14 +94,14 @@ deriving instance Show (TypeError resume)
instance Eq1 TypeError where
liftEq _ (UnificationError a1 b1) (UnificationError a2 b2) = a1 == a2 && b1 == b2
liftEq _ (InfiniteType a1 b1) (InfiniteType a2 b2) = a1 == a2 && b1 == b2
liftEq _ _ _ = False
liftEq _ (InfiniteType a1 b1) (InfiniteType a2 b2) = a1 == a2 && b1 == b2
liftEq _ _ _ = False
instance Ord1 TypeError where
liftCompare _ (UnificationError a1 b1) (UnificationError a2 b2) = compare a1 a2 <> compare b1 b2
liftCompare _ (InfiniteType a1 b1) (InfiniteType a2 b2) = compare a1 a2 <> compare b1 b2
liftCompare _ (InfiniteType _ _) (UnificationError _ _) = LT
liftCompare _ (UnificationError _ _) (InfiniteType _ _) = GT
liftCompare _ (InfiniteType a1 b1) (InfiniteType a2 b2) = compare a1 a2 <> compare b1 b2
liftCompare _ (InfiniteType _ _) (UnificationError _ _) = LT
liftCompare _ (UnificationError _ _) (InfiniteType _ _) = GT
instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
@ -210,17 +223,17 @@ unify a b = do
b' <- prune b
case (a', b') of
(a1 :-> b1, a2 :-> b2) -> (:->) <$> unify a1 a2 <*> unify b1 b2
(a, Null) -> pure a
(Null, b) -> pure b
(Var id, ty) -> substitute id ty
(ty, Var id) -> substitute id ty
(Array t1, Array t2) -> Array <$> unify t1 t2
(a, Null) -> pure a
(Null, b) -> pure b
(Var id, ty) -> substitute id ty
(ty, Var id) -> substitute id ty
(Array t1, Array t2) -> Array <$> unify t1 t2
-- FIXME: unifying with sums should distribute nondeterministically.
-- FIXME: ordering shouldn’t be significant for undiscriminated sums.
(a1 :+ b1, a2 :+ b2) -> (:+) <$> unify a1 a2 <*> unify b1 b2
(a1 :* b1, a2 :* b2) -> (:*) <$> unify a1 a2 <*> unify b1 b2
(t1, t2) | t1 == t2 -> pure t2
_ -> throwTypeError (UnificationError a b)
(a1 :+ b1, a2 :+ b2) -> (:+) <$> unify a1 a2 <*> unify b1 b2
(a1 :* b1, a2 :* b2) -> (:*) <$> unify a1 a2 <*> unify b1 b2
(t1, t2) | t1 == t2 -> pure t2
_ -> throwTypeError (UnificationError a b)
instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
@ -290,7 +303,7 @@ instance ( Has (Reader ModuleInfo) sig m
, Alternative m
)
=> Algebra (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
alg (R other) = BooleanC . alg . handleCoercible $ other
alg (R other) = BooleanC . alg . handleCoercible $ other
alg (L (Abstract.Boolean _ k)) = k Bool
alg (L (Abstract.AsBool t k)) = unify t Bool *> (k True <|> k False)
@ -309,7 +322,7 @@ instance ( Has (Abstract.Boolean Type) sig m
instance Algebra sig m
=> Algebra (Abstract.Unit Type :+: sig) (UnitC Type m) where
alg (R other) = UnitC . alg . handleCoercible $ other
alg (R other) = UnitC . alg . handleCoercible $ other
alg (L (Abstract.Unit k)) = k Unit
instance ( Has (Reader ModuleInfo) sig m
@ -320,8 +333,8 @@ instance ( Has (Reader ModuleInfo) sig m
, Alternative m
)
=> Algebra (Abstract.String Type :+: sig) (StringC Type m) where
alg (R other) = StringC . alg . handleCoercible $ other
alg (L (Abstract.String _ k)) = k String
alg (R other) = StringC . alg . handleCoercible $ other
alg (L (Abstract.String _ k)) = k String
alg (L (Abstract.AsString t k)) = unify t String *> k ""
instance ( Has (Reader ModuleInfo) sig m
@ -353,17 +366,17 @@ instance ( Has (Reader ModuleInfo) sig m
=> Algebra (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where
alg (R other) = BitwiseC . alg . handleCoercible $ other
alg (L op) = case op of
CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int
LiftBitwise _ t k -> unify t Int >>= k
CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int
LiftBitwise _ t k -> unify t Int >>= k
LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= k
UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= k
instance ( Algebra sig m ) => Algebra (Abstract.Object address Type :+: sig) (ObjectC address Type m) where
alg (R other) = ObjectC . alg . handleCoercible $ other
alg (L op) = case op of
Abstract.Object _ k -> k Object
Abstract.Object _ k -> k Object
Abstract.ScopedEnvironment _ k -> k Nothing
Abstract.Klass _ _ k -> k Object
Abstract.Klass _ _ k -> k Object
instance ( Has Fresh sig m
, Has (Reader ModuleInfo) sig m
@ -384,8 +397,8 @@ instance ( Has Fresh sig m
unify t (Array (Var field)) >> k mempty
instance ( Algebra sig m ) => Algebra (Abstract.Hash Type :+: sig) (HashC Type m) where
alg (R other) = HashC . alg . handleCoercible $ other
alg (L (Abstract.Hash t k)) = k (Hash t)
alg (R other) = HashC . alg . handleCoercible $ other
alg (L (Abstract.Hash t k)) = k (Hash t)
alg (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2)
@ -422,8 +435,8 @@ instance ( Has Fresh sig m
liftComparison (Concrete _) left right = case (left, right) of
(Float, Int) -> pure Bool
(Int, Float) -> pure Bool
_ -> unify left right $> Bool
_ -> unify left right $> Bool
liftComparison Generalized left right = case (left, right) of
(Float, Int) -> pure Int
(Int, Float) -> pure Int
_ -> unify left right $> Bool
_ -> unify left right $> Bool

8
src/Data/Blob.hs
View File

@ -25,15 +25,19 @@ module Data.Blob
, pathKeyForBlobPair
) where
import Prologue
import Analysis.File (File (..))
import Control.Effect.Error
import Control.Exception
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString.Lazy as BL
import Data.Edit
import Data.JSON.Fields
import Data.Maybe
import Data.Maybe.Exts
import Data.Module
import GHC.Generics (Generic)
import Source.Language as Language
import Source.Source (Source, totalSpan)
import qualified Source.Source as Source
@ -102,7 +106,7 @@ instance FromJSON BlobPair where
>>= maybeM (Prelude.fail "Expected object with 'before' and/or 'after' keys only")
maybeBlobPair :: MonadFail m => Maybe Blob -> Maybe Blob -> m BlobPair
maybeBlobPair a b = maybeM (Prologue.fail "expected file pair with content on at least one side") (fromMaybes a b)
maybeBlobPair a b = maybeM (fail "expected file pair with content on at least one side") (fromMaybes a b)
languageForBlobPair :: BlobPair -> Language
languageForBlobPair = mergeEdit combine . bimap blobLanguage blobLanguage where

4
src/Data/Blob/IO.hs
View File

@ -9,13 +9,13 @@ module Data.Blob.IO
, readFilePair
) where
import Prologue
import Analysis.File as File
import qualified Control.Concurrent.Async as Async
import Control.Monad.IO.Class
import Data.Blob
import qualified Data.ByteString as B
import Data.Language
import Data.Maybe.Exts
import Semantic.IO
import qualified Source.Source as Source
import qualified System.Path as Path

12
src/Data/Error.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DeriveFunctor, FlexibleInstances, GADTs, RankNTypes, RecordWildCards #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Error
( Error (..)
, formatError
@ -11,10 +15,12 @@ module Data.Error
, Colourize (..)
) where
import Prologue
import Control.Exception (Exception)
import Data.ByteString.Char8 (unpack)
import Data.Foldable
import Data.Ix (inRange)
import Data.List (intersperse, isSuffixOf)
import GHC.Stack
import System.Console.ANSI
import Data.Blob

2
src/Data/Flag.hs
View File

@ -8,7 +8,7 @@ module Data.Flag
, choose
) where
import Prologue
import Data.Coerce
-- | To declare a new flag, declare a singly-inhabited type:
-- @data MyFlag = MyFlag@

14
src/Data/Graph/Algebraic.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Graph.Algebraic
( Graph(..)
, overlay
@ -13,16 +18,19 @@ module Data.Graph.Algebraic
, edgeList
) where
import Prologue
import qualified Algebra.Graph as G
import qualified Algebra.Graph.AdjacencyMap as A
import Algebra.Graph.Class (connect, overlay, vertex)
import qualified Algebra.Graph.Class as Class
import qualified Algebra.Graph.ToGraph as Class
import Control.Applicative
import Control.Carrier.State.Strict
import Control.Lens (view)
import Data.Aeson
import Data.Foldable
import Data.Function
import Data.Semilattice.Lower
import Data.Set (Set)
import qualified Data.Set as Set
import Proto.Semantic as P
import Proto.Semantic_Fields as P

20
src/Data/Graph/ControlFlowVertex.hs
View File

@ -1,4 +1,14 @@
{-# LANGUAGE DataKinds, EmptyCase, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Graph.ControlFlowVertex
( ControlFlowVertex (..)
, packageVertex
@ -20,15 +30,19 @@ import Data.Abstract.Module (ModuleInfo (..))
import Data.Abstract.Package (PackageInfo (..))
import Data.Aeson
import Data.Graph.Algebraic (VertexTag (..))
import Data.Quieterm (Quieterm(..))
import Data.Hashable
import Data.Proxy
import Data.Quieterm (Quieterm (..))
import Data.Semilattice.Lower
import Data.Sum
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression
import Data.Term
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (V1)
import Prelude hiding (span)
import Prologue
import qualified Source.Loc as Loc
import Source.Span

10
src/Data/Handle.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, GADTs, StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
module Data.Handle
( Handle (..)
@ -14,9 +17,8 @@ module Data.Handle
, InvalidJSONException (..)
) where
import Prologue
import Control.Exception (throw)
import Control.Exception (Exception, throw)
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC

8
src/Data/ImportPath.hs
View File

@ -1,12 +1,14 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.ImportPath (IsRelative(..), ImportPath(..), importPath, toName, defaultAlias) where
import Prologue
import Analysis.Name
import Data.Abstract.Path (stripQuotes)
import Data.Aeson
import Data.Hashable
import Data.Text
import qualified Data.Text as T
import GHC.Generics (Generic)
import System.FilePath.Posix
data IsRelative = Unknown | Relative | NonRelative

5
src/Data/JSON/Fields.hs
View File

@ -17,12 +17,15 @@ module Data.JSON.Fields
) where
import Data.Aeson
import Data.Bifunctor.Join
import Data.Edit
import qualified Data.Map as Map
import Data.Maybe
import Data.ScopeGraph
import Data.Sum
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics
import Prologue
import Source.Loc
import Source.Range

13
src/Data/Map/Monoidal.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type.
module Data.Map.Monoidal
( Map
@ -15,11 +17,12 @@ module Data.Map.Monoidal
, module Reducer
) where
import Data.Aeson (ToJSON)
import Data.Aeson (ToJSON)
import Data.Functor.Classes
import qualified Data.Map as Map
import Data.Semigroup.Reducer as Reducer
import Prelude hiding (lookup)
import Prologue hiding (Map, empty)
import Data.Semigroup.Reducer as Reducer
import Data.Semilattice.Lower
import Prelude hiding (lookup)
newtype Map key value = Map { unMap :: Map.Map key value }
deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable, Lower)

20
src/Data/Maybe/Exts.hs Normal file
View File

@ -0,0 +1,20 @@
module Data.Maybe.Exts
( module Data.Maybe
, maybeLast
, fromMaybeLast
, maybeM
) where
import Data.Maybe
import Data.Monoid
maybeLast :: Foldable t => b -> (a -> b) -> t a -> b
maybeLast b f = maybe b f . getLast . foldMap (Last . Just)
fromMaybeLast :: Foldable t => a -> t a -> a
fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just)
-- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action.
maybeM :: Applicative f => f a -> Maybe a -> f a
maybeM f = maybe f pure
{-# INLINE maybeM #-}

4
src/Data/Project.hs
View File

@ -7,12 +7,14 @@ module Data.Project
) where
import Prelude hiding (readFile)
import Prologue
import Analysis.File
import Control.Monad.IO.Class
import Data.Blob
import Data.Blob.IO
import Data.Language
import Data.Semilattice.Lower
import Data.Text (Text)
import qualified Data.Text as T
import Semantic.IO
import System.FilePath.Posix

10
src/Data/Scientific/Exts.hs
View File

@ -6,16 +6,16 @@ module Data.Scientific.Exts
) where
import Control.Applicative
import Control.Exception as Exc (evaluate, try)
import Control.Exception as Exc (ArithException, evaluate, try)
import Control.Monad hiding (fail)
import Control.Monad.Fail
import Data.Attoparsec.Text
import Data.Text hiding (takeWhile)
import Data.Char (isDigit)
import Data.Scientific
import Prelude hiding (fail, filter, null, takeWhile)
import Prologue hiding (null)
import System.IO.Unsafe
import Data.Text hiding (takeWhile)
import Numeric.Exts
import Prelude hiding (fail, filter, null, takeWhile)
import System.IO.Unsafe
parseScientific :: Text -> Either String Scientific
parseScientific = parseOnly parser

75
src/Data/Syntax.hs
View File

@ -1,25 +1,54 @@
{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DataKinds, DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax (module Data.Syntax) where
import Data.Abstract.Evaluatable hiding (Empty, Error)
import Data.Aeson as Aeson (ToJSON(..), object)
import Data.JSON.Fields
import qualified Data.Set as Set
import Data.Sum
import Data.Term
import GHC.Types (Constraint)
import GHC.TypeLits
import Diffing.Algorithm
import Prelude
import Prologue
import Source.Loc
import Source.Range as Range
import Source.Span as Span
import qualified Assigning.Assignment as Assignment
import qualified Data.Error as Error
import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..))
import Control.Abstract.Heap (deref, lookupSlot)
import Control.Abstract.Heap (deref, lookupSlot)
import Control.Abstract.ScopeGraph (Declaration (..), Reference (..), reference)
import Data.Abstract.Evaluatable hiding (Empty, Error)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Aeson as Aeson (ToJSON (..), object)
import Data.Bifunctor
import qualified Data.Error as Error
import Data.Foldable
import Data.Function
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Functor.Foldable (cata)
import Data.Hashable
import Data.Hashable.Lifted
import Data.Ix
import Data.JSON.Fields
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Proxy
import Data.Semigroup (sconcat)
import qualified Data.Set as Set
import Data.Sum
import Data.Term
import Data.Text (Text)
import Diffing.Algorithm
import GHC.Generics
import GHC.Stack
import GHC.TypeLits
import GHC.Types (Constraint)
import Source.Loc
import Source.Range as Range
import Source.Span as Span
-- Combinators
@ -35,7 +64,7 @@ makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax
makeTerm'' :: (Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, Foldable syntax, IsTerm term) => ann -> syntax (term ann) -> term ann
makeTerm'' ann children = case toList children of
[x] -> x
_ -> makeTerm' ann (inject children)
_ -> makeTerm' ann (inject children)
-- | 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, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => syntax (term ann) -> term ann
@ -45,7 +74,7 @@ makeTerm1 = makeTerm1' . inject
makeTerm1' :: (HasCallStack, Semigroup ann, Foldable (Syntax term), IsTerm term) => Syntax term (term ann) -> term ann
makeTerm1' syntax = case toList syntax of
a : _ -> makeTerm' (termAnnotation a) syntax
_ -> error "makeTerm1': empty structure"
_ -> error "makeTerm1': empty structure"
-- | Construct an empty term at the current position.
emptyTerm :: (Empty :< syntaxes, Sum syntaxes ~ Syntax term, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment ast grammar (term Loc)
@ -68,7 +97,7 @@ contextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term,
contextualize context rule = make <$> Assignment.manyThrough context rule
where make (cs, node) = case nonEmpty cs of
Just cs -> makeTerm1 (Context cs node)
_ -> node
_ -> 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 :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term)
@ -79,7 +108,7 @@ postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ S
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
where make node (cs, end) = case nonEmpty cs of
Just cs -> (makeTerm1 (Context cs node), end)
_ -> (node, end)
_ -> (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 :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term)
@ -89,7 +118,7 @@ postContextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax t
postContextualize context rule = make <$> rule <*> many context
where make node cs = case nonEmpty cs of
Just cs -> makeTerm1 (Context cs node)
_ -> node
_ -> node
-- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
infixContext :: (Context :< syntaxes, Sum syntaxes ~ Syntax term, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes, IsTerm term)

12
src/Data/Syntax/Comment.hs
View File

@ -1,11 +1,17 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DerivingVia, MultiParamTypeClasses #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Syntax.Comment (module Data.Syntax.Comment) where
import Prologue
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.Text (Text)
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | An unnested comment (line or block).
newtype Comment a = Comment { commentContent :: Text }

42
src/Data/Syntax/Declaration.hs
View File

@ -1,11 +1,27 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TypeApplications, TupleSections, UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax.Declaration (module Data.Syntax.Declaration) where
import Prologue
import Control.Lens.Getter
import Control.Monad
import Data.Foldable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Semilattice.Lower
import qualified Data.Set as Set
import Data.Traversable
import GHC.Generics (Generic1)
import Control.Abstract hiding (AccessControl (..), Function)
import Data.Abstract.Evaluatable
@ -65,11 +81,11 @@ instance FreeVariables1 Function where
liftFreeVariables freeVariables f@Function{..} = foldMap freeVariables f `Set.difference` foldMap freeVariables functionParameters
data Method a = Method
{ methodContext :: [a]
, methodReceiver :: a
, methodName :: a
, methodParameters :: [a]
, methodBody :: a
{ methodContext :: [a]
, methodReceiver :: a
, methodName :: a
, methodParameters :: [a]
, methodBody :: a
, methodAccessControl :: ScopeGraph.AccessControl
}
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1)
@ -106,9 +122,9 @@ instance FreeVariables1 Method where
-- | A method signature in TypeScript or a method spec in Go.
data MethodSignature a = MethodSignature
{ methodSignatureContext :: [a]
, methodSignatureName :: a
, methodSignatureParameters :: [a]
{ methodSignatureContext :: [a]
, methodSignatureName :: a
, methodSignatureParameters :: [a]
, methodSignatureAccessControl :: ScopeGraph.AccessControl
}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
@ -193,9 +209,9 @@ instance Declarations a => Declarations (InterfaceDeclaration a) where
-- | A public field definition such as a field definition in a JavaScript class.
data PublicFieldDefinition a = PublicFieldDefinition
{ publicFieldContext :: [a]
, publicFieldPropertyName :: a
, publicFieldValue :: a
{ publicFieldContext :: [a]
, publicFieldPropertyName :: a
, publicFieldValue :: a
, publicFieldAccessControl :: ScopeGraph.AccessControl
}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)

12
src/Data/Syntax/Directive.hs
View File

@ -1,13 +1,19 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax.Directive (module Data.Syntax.Directive) where
import Prologue
import Data.Abstract.Evaluatable
import Data.Abstract.Module (ModuleInfo (..))
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Source.Span
-- A file directive like the Ruby constant `__FILE__`.

28
src/Data/Syntax/Expression.hs
View File

@ -1,19 +1,39 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax.Expression (module Data.Syntax.Expression) where
import Prelude hiding (null)
import Prologue hiding (index, null)
import Analysis.Name as Name
import Control.Abstract hiding (Bitwise (..), Call)
import Control.Applicative
import Control.Monad
import Data.Abstract.Evaluatable as Abstract
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Bits
import Data.Fixed
import Data.Foldable (for_)
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Exts
import Diffing.Algorithm hiding (Delete)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import GHC.Generics (Generic1)
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
@ -454,7 +474,7 @@ instance Evaluatable MemberAccess where
case lhsFrame of
Just lhsFrame -> withScopeAndFrame lhsFrame (ref' rhs)
-- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object.
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
-- | Subscript (e.g a[1])

15
src/Data/Syntax/Literal.hs
View File

@ -1,14 +1,25 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Data.Syntax.Literal (module Data.Syntax.Literal) where
import Prelude hiding (Float, null)
import Prologue hiding (Set, hash, null)
import Control.Monad
import Data.Abstract.Evaluatable as Eval
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.Scientific.Exts
import Data.Text (Text)
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Numeric.Exts
import Text.Read (readMaybe)

21
src/Data/Syntax/Statement.hs
View File

@ -1,17 +1,28 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, RecordWildCards, ScopedTypeVariables, TypeApplications, UndecidableInstances, ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Syntax.Statement (module Data.Syntax.Statement) where
import Prologue
import Control.Abstract hiding (Break, Catch, Continue, Return, Throw, While)
import Data.Abstract.Evaluatable as Abstract hiding (Catch, Throw)
import Data.Aeson (ToJSON1 (..))
import Data.JSON.Fields
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Aeson (ToJSON1 (..))
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | Imperative sequence of statements/declarations s.t.:
--

15
src/Data/Syntax/Type.hs
View File

@ -1,11 +1,20 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, MultiParamTypeClasses, RecordWildCards, UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax.Type (module Data.Syntax.Type) where
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Diffing.Algorithm
import Prelude hiding (Bool, Float, Int, Double)
import Prologue hiding (Map)
import GHC.Generics (Generic1)
import Prelude hiding (Bool, Double, Float, Int)
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)

19
src/Data/Term.hs
View File

@ -1,4 +1,12 @@
{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Term
( Term(..)
, TermF(..)
@ -15,12 +23,17 @@ module Data.Term
, injectTerm
) where
import Prologue
import Control.Lens.Lens
import Data.Aeson
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Sum
import qualified Data.Sum as Sum
import GHC.Generics (Generic1)
import Source.Span
import Text.Show

33
src/Diffing/Algorithm.hs
View File

@ -1,4 +1,14 @@
{-# LANGUAGE DefaultSignatures, DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeApplications, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Diffing.Algorithm
( Diff (..)
, Algorithm(..)
@ -14,14 +24,19 @@ module Diffing.Algorithm
, algorithmForTerms
) where
import Control.Algebra hiding ((:+:))
import Control.Effect.NonDet
import Control.Algebra hiding ((:+:))
import Control.Applicative
import Control.Effect.NonDet
import qualified Data.Diff as Diff
import qualified Data.Edit as Edit
import Data.Sum
import Data.Term
import GHC.Generics
import Prologue
import Data.Functor
import Data.Functor.Classes
import Data.List.NonEmpty
import Data.Maybe
import Data.Maybe.Exts
import Data.Sum
import Data.Term
import GHC.Generics
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
data Diff term1 term2 diff (m :: * -> *) k
@ -257,12 +272,12 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
galgorithmFor (L1 a1) (L1 a2) = L1 <$> galgorithmFor a1 a2
galgorithmFor (R1 b1) (R1 b2) = R1 <$> galgorithmFor b1 b2
galgorithmFor _ _ = empty
galgorithmFor _ _ = empty
gtryAlignWith f a b = case (a, b) of
(L1 a, L1 b) -> L1 <$> gtryAlignWith f a b
(R1 a, R1 b) -> R1 <$> gtryAlignWith f a b
_ -> empty
_ -> empty
gcomparableTo (L1 _) (L1 _) = True
gcomparableTo (R1 _) (R1 _) = True

39
src/Diffing/Algorithm/RWS.hs
View File

@ -1,4 +1,10 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, GADTs, RankNTypes, RecordWildCards, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
module Diffing.Algorithm.RWS
( rws
@ -14,16 +20,27 @@ module Diffing.Algorithm.RWS
, equalTerms
) where
import Control.Monad.State.Strict
import Data.Diff (DiffF(..), comparing, deleting, inserting, merge)
import Data.Edit
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad.State.Strict
import Data.Diff (DiffF (..), comparing, deleting, inserting, merge)
import Data.Edit
import Data.Foldable
import Data.Function
import Data.Functor.Classes
import Data.Functor.Foldable (cata)
import Data.Hashable
import Data.Hashable.Lifted
import Data.Ix (inRange)
import qualified Data.KdMap.Static as KdMap
import Data.List (sortOn)
import Data.Term as Term
import Diffing.Algorithm (Diffable(..))
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
import Prologue
import Data.List (sortOn)
import Data.Maybe
import Data.Term as Term
import Data.Traversable
import Diffing.Algorithm (Diffable (..))
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
import GHC.Generics (Generic)
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
--
@ -158,7 +175,7 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b)
where diffCost = flip . cata $ \ diff m -> case diff of
_ | m <= 0 -> 0
Merge body -> sum (fmap ($ pred m) body)
body -> succ (sum (fmap ($ pred m) body))
body -> succ (sum (fmap ($ pred m) body))
approximateDiff a b = maybe (comparing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . edit deleting inserting approximateDiff) (termOut a) (termOut b))

25
src/Diffing/Interpreter.hs
View File

@ -1,18 +1,27 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Diffing.Interpreter
( diffTerms
, DiffTerms(..)
, stripDiff
) where
import Control.Algebra
import Control.Carrier.Cull.Church
import Control.Algebra
import Control.Carrier.Cull.Church
import Control.Monad.IO.Class
import Data.Bifunctor
import qualified Data.Diff as Diff
import Data.Edit (Edit, edit)
import Data.Term
import Diffing.Algorithm
import Diffing.Algorithm.RWS
import Prologue
import Data.Edit (Edit, edit)
import Data.Functor.Classes
import Data.Hashable.Lifted
import Data.Maybe
import Data.Term
import Diffing.Algorithm
import Diffing.Algorithm.RWS
-- | Diff two à la carte terms recursively.
diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)

16
src/Language/Go/Assignment.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.Go.Assignment
( assignment
, Go.Syntax
@ -6,12 +10,14 @@ module Language.Go.Assignment
, Go.Term(..)
) where
import Prologue
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..))
import Control.Monad
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..))
import Data.ImportPath (defaultAlias, importPath)
import Data.List.NonEmpty (NonEmpty (..), some1)
import Data.Sum
import Data.Syntax
(contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError)
import qualified Data.Syntax as Syntax
@ -22,7 +28,7 @@ import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Language.Go.Syntax as Go.Syntax hiding (runeLiteral, labelName)
import Language.Go.Syntax as Go.Syntax hiding (labelName, runeLiteral)
import Language.Go.Term as Go
import Language.Go.Type as Go.Type
import Data.ImportPath (importPath, defaultAlias)

20
src/Language/Go/Syntax.hs
View File

@ -1,8 +1,11 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, RecordWildCards, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Language.Go.Syntax (module Language.Go.Syntax) where
import Prologue
import Control.Abstract
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
@ -10,13 +13,20 @@ import Data.Abstract.Module
import qualified Data.Abstract.Package as Package
import Data.Abstract.Path
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.ImportPath
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as Map
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Text (Text)
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import System.FilePath.Posix
resolveGoImport :: ( Has (Modules address value) sig m
@ -34,7 +44,7 @@ resolveGoImport (ImportPath path Relative) = do
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
case paths of
[] -> throwResolutionError $ GoImportError path
_ -> pure paths
_ -> pure paths
resolveGoImport (ImportPath path NonRelative) = do
package <- T.unpack . formatName . Package.packageName <$> currentPackage
trace ("attempting to resolve " <> show path <> " for package " <> package)
@ -43,7 +53,7 @@ resolveGoImport (ImportPath path NonRelative) = do
-- First two are source, next is package name, remaining are path to package
-- (e.g. github.com/golang/<package>/path...).
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
_ -> throwResolutionError $ GoImportError path
_ -> throwResolutionError $ GoImportError path
-- | Import declarations (symbols are added directly to the calling environment).
--

10
src/Language/Go/Type.hs
View File

@ -1,11 +1,15 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Language.Go.Type (module Language.Go.Type) where
import Prologue
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | A Bidirectional channel in Go (e.g. `chan`).
newtype BidirectionalChannel a = BidirectionalChannel { value :: a }

21
src/Language/Markdown/Assignment.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, RecordWildCards, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.Markdown.Assignment
( assignment
, Markdown.Syntax
@ -6,11 +11,11 @@ module Language.Markdown.Assignment
, Markdown.Term(..)
) where
import Prologue
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import qualified CMarkGFM
import Control.Monad
import Data.Sum
import Data.Syntax (makeTerm)
import qualified Data.Syntax as Syntax
import qualified Data.Term as Term
@ -46,7 +51,7 @@ list :: Assignment (Term Loc)
list = Term.termIn <$> symbol List <*> (makeList . Term.termFAnnotation . Term.termFOut <$> currentNode <*> children (many item))
where
makeList (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) = case listType of
CMarkGFM.BULLET_LIST -> inject . Markup.UnorderedList
CMarkGFM.BULLET_LIST -> inject . Markup.UnorderedList
CMarkGFM.ORDERED_LIST -> inject . Markup.OrderedList
makeList _ = inject . Markup.UnorderedList
@ -57,7 +62,7 @@ heading :: Assignment (Term Loc)
heading = makeTerm <$> symbol Heading <*> (makeHeading . Term.termFAnnotation . Term.termFOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
where
makeHeading (CMarkGFM.HEADING level) = Markup.Heading level
makeHeading _ = Markup.Heading 0
makeHeading _ = Markup.Heading 0
blockQuote :: Assignment (Term Loc)
blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement)
@ -66,7 +71,7 @@ codeBlock :: Assignment (Term Loc)
codeBlock = makeTerm <$> symbol CodeBlock <*> (makeCode . Term.termFAnnotation . Term.termFOut <$> currentNode <*> source)
where
makeCode (CMarkGFM.CODE_BLOCK language _) = Markup.Code (nullText language)
makeCode _ = Markup.Code Nothing
makeCode _ = Markup.Code Nothing
thematicBreak :: Assignment (Term Loc)
thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak
@ -118,13 +123,13 @@ link :: Assignment (Term Loc)
link = makeTerm <$> symbol Link <*> (makeLink . Term.termFAnnotation . Term.termFOut <$> currentNode) <* advance
where
makeLink (CMarkGFM.LINK url title) = Markup.Link url (nullText title)
makeLink _ = Markup.Link mempty Nothing
makeLink _ = Markup.Link mempty Nothing
image :: Assignment (Term Loc)
image = makeTerm <$> symbol Image <*> (makeImage . Term.termFAnnotation . Term.termFOut <$> currentNode) <* advance
where
makeImage (CMarkGFM.IMAGE url title) = Markup.Image url (nullText title)
makeImage _ = Markup.Image mempty Nothing
makeImage _ = Markup.Image mempty Nothing
code :: Assignment (Term Loc)
code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source)

10
src/Language/Markdown/Syntax.hs
View File

@ -1,11 +1,17 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Language.Markdown.Syntax (module Language.Markdown.Syntax) where
import Data.Abstract.Declarations
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import Prologue hiding (Text)
import GHC.Generics (Generic1)
newtype Document a = Document { values :: [a] }
deriving (Declarations1, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1)

13
src/Language/PHP/Assignment.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.PHP.Assignment
( assignment
, PHP.Syntax
@ -6,13 +10,14 @@ module Language.PHP.Assignment
, PHP.Term(..)
) where
import Prologue
import qualified Analysis.Name as Name
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..))
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..), some1)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sum
import Data.Syntax
( contextualize
, emptyTerm

14
src/Language/PHP/Syntax.hs
View File

@ -1,11 +1,19 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
module Language.PHP.Syntax (module Language.PHP.Syntax) where
import Prologue hiding (Text)
import Control.Lens.Getter
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import qualified Data.Text as T
import GHC.Generics (Generic1)
import Control.Abstract as Abstract
import Data.Abstract.BaseError

14
src/Language/Python/Assignment.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.Python.Assignment
( assignment
, Python.Syntax
@ -9,7 +13,11 @@ module Language.Python.Assignment
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Control.Monad
import Data.Functor
import Data.List.NonEmpty (some1)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import Data.Sum
import Data.Syntax
( contextualize
@ -166,14 +174,14 @@ forStatement = symbol ForStatement >>= \ loc -> children (make loc <$> (symbol V
where
make loc binding subject body forElseClause = case forElseClause of
Nothing -> makeTerm loc (Statement.ForEach binding subject body)
Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.ForEach binding subject body) a)
Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.ForEach binding subject body) a)
whileStatement :: Assignment (Term Loc)
whileStatement = symbol WhileStatement >>= \ loc -> children (make loc <$> term expression <*> term block <*> optional (symbol ElseClause *> children expressions))
where
make loc whileCondition whileBody whileElseClause = case whileElseClause of
Nothing -> makeTerm loc (Statement.While whileCondition whileBody)
Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.While whileCondition whileBody) a)
Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.While whileCondition whileBody) a)
tryStatement :: Assignment (Term Loc)
tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term block <*> manyTerm (expression <|> elseClause))

21
src/Language/Python/Syntax.hs
View File

@ -1,14 +1,27 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, RecordWildCards, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Language.Python.Syntax (module Language.Python.Syntax) where
import Prologue
import Control.Lens.Getter
import Data.Aeson hiding (object)
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable
import Data.Hashable.Lifted
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable
import GHC.Generics (Generic, Generic1)
import System.FilePath.Posix
import Control.Abstract.Heap
@ -160,7 +173,7 @@ instance Evaluatable Import where
-- Last module path is the one we want to import
let path = NonEmpty.last modulePaths
((moduleScope, moduleFrame), _) <- require path
if Prologue.null xs then do
if Prelude.null xs then do
insertImportEdge moduleScope
insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame)
else do

15
src/Language/Ruby/Assignment.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedStrings, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.Ruby.Assignment
( assignment
, Ruby.Syntax
@ -6,13 +11,15 @@ module Language.Ruby.Assignment
, Ruby.Term(..)
) where
import Prologue hiding (for, unless)
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..))
import Control.Monad hiding (unless)
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..))
import Data.List.NonEmpty (some1)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import Data.Sum
import Data.Syntax
( contextualize
, emptyTerm

21
src/Language/Ruby/Syntax.hs
View File

@ -1,22 +1,37 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, FlexibleContexts, OverloadedStrings, RecordWildCards, TupleSections, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Language.Ruby.Syntax (module Language.Ruby.Syntax) where
import Prologue
import Analysis.Name as Name
import Control.Abstract as Abstract hiding (Load, String)
import Control.Monad
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import qualified Data.Abstract.Module as M
import Data.Abstract.Path
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Language as Language
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (for)
import Diffing.Algorithm
import GHC.Generics (Generic1)
import System.FilePath.Posix
-- TODO: Fully sort out ruby require/load mechanics

33
src/Language/TSX/Assignment.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedStrings, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.TSX.Assignment
( assignment
, TSX.Syntax
@ -6,12 +11,17 @@ module Language.TSX.Assignment
, TSX.Term(..)
) where
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..))
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Sum
import Data.Syntax
import Control.Monad
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..))
import Data.Foldable
import Data.Function
import Data.List.NonEmpty (nonEmpty, some1)
import Data.Maybe
import Data.Sum
import Data.Syntax
( contextualize
, emptyTerm
, handleError
@ -31,10 +41,9 @@ import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Language.TSX.Syntax as TSX.Syntax
import Language.TSX.Term as TSX
import qualified Language.TypeScript.Resolution as TypeScript.Resolution
import Language.TSX.Term as TSX
import Prologue
import TreeSitter.TSX as Grammar
import TreeSitter.TSX as Grammar
type Assignment = Assignment.Assignment [] Grammar
@ -567,11 +576,11 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr
makeImportTerm1 loc from (Just alias, _) = makeTerm loc (TSX.Syntax.QualifiedAliasedImport alias from)
makeImportTerm1 loc from (Nothing, symbols) = makeTerm loc (TSX.Syntax.Import (uncurry TSX.Syntax.Alias <$> symbols) from)
makeImportTerm loc ([x], from) = makeImportTerm1 loc from x
makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs
makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs
importSymbol = symbol Grammar.ImportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> ((Just <$> rawIdentifier) <|> pure Nothing))
rawIdentifier = symbol Identifier *> (name <$> source)
makeNameAliasPair from (Just alias) = (from, alias)
makeNameAliasPair from Nothing = (from, from)
makeNameAliasPair from Nothing = (from, from)
-- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.Term (Sum TSX.Syntax).
fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)
@ -627,7 +636,7 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip
exportSymbol = symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> (Just <$> rawIdentifier))
<|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing)
makeNameAliasPair from (Just alias) = TSX.Syntax.Alias from alias
makeNameAliasPair from Nothing = TSX.Syntax.Alias from from
makeNameAliasPair from Nothing = TSX.Syntax.Alias from from
rawIdentifier = symbol Identifier *> (name <$> source)
-- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.Term (Sum TSX.Syntax).
fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)

10
src/Language/TSX/Syntax/JSX.hs
View File

@ -1,12 +1,16 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Language.TSX.Syntax.JSX (module Language.TSX.Syntax.JSX) where
import Prologue
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
data JsxElement a = JsxElement { jsxOpeningElement :: !a, jsxElements :: ![a], jsxClosingElement :: !a }

35
src/Language/TypeScript/Assignment.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedStrings, RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Language.TypeScript.Assignment
( assignment
, TypeScript.Syntax
@ -6,12 +11,17 @@ module Language.TypeScript.Assignment
, TypeScript.Term(..)
) where
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..))
import Analysis.Name (name)
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Sum
import Data.Syntax
import Control.Monad
import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..))
import Data.Foldable
import Data.Function
import Data.List.NonEmpty (nonEmpty, some1)
import Data.Maybe
import Data.Sum
import Data.Syntax
( contextualize
, emptyTerm
, handleError
@ -30,11 +40,10 @@ import qualified Data.Syntax.Expression as Expression
import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Language.TypeScript.Syntax as TypeScript.Syntax
import qualified Language.TypeScript.Resolution as TypeScript.Resolution
import Language.TypeScript.Term as TypeScript
import Prologue
import Language.TypeScript.Grammar as Grammar
import qualified Language.TypeScript.Syntax as TypeScript.Syntax
import Language.TypeScript.Term as TypeScript
import Language.TypeScript.Grammar as Grammar
type Assignment = Assignment.Assignment [] Grammar
@ -529,11 +538,11 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr
makeImportTerm1 loc from (Just alias, _) = makeTerm loc (TypeScript.Syntax.QualifiedAliasedImport alias from)
makeImportTerm1 loc from (Nothing, symbols) = makeTerm loc (TypeScript.Syntax.Import (uncurry TypeScript.Syntax.Alias <$> symbols) from)
makeImportTerm loc ([x], from) = makeImportTerm1 loc from x
makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs
makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs
importSymbol = symbol Grammar.ImportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> ((Just <$> rawIdentifier) <|> pure Nothing))
rawIdentifier = symbol Identifier *> (name <$> source)
makeNameAliasPair from (Just alias) = (from, alias)
makeNameAliasPair from Nothing = (from, from)
makeNameAliasPair from Nothing = (from, from)
-- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.
fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)
@ -589,7 +598,7 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip
exportSymbol = symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> (Just <$> rawIdentifier))
<|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing)
makeNameAliasPair from (Just alias) = TypeScript.Syntax.Alias from alias
makeNameAliasPair from Nothing = TypeScript.Syntax.Alias from from
makeNameAliasPair from Nothing = TypeScript.Syntax.Alias from from
rawIdentifier = symbol Identifier *> (name <$> source)
-- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.
fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)

25
src/Language/TypeScript/Syntax/Import.hs
View File

@ -1,17 +1,28 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, OverloadedStrings, RecordWildCards, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Language.TypeScript.Syntax.Import (module Language.TypeScript.Syntax.Import) where
import Prologue
import qualified Analysis.Name as Name
import Control.Abstract hiding (Import)
import Control.Monad
import Data.Abstract.Evaluatable as Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Aeson (ToJSON)
import Data.Foldable
import Data.Functor.Classes.Generic
import Data.Hashable
import Data.Hashable.Lifted
import Data.JSON.Fields
import Diffing.Algorithm
import Language.TypeScript.Resolution
import qualified Data.Map.Strict as Map
import Data.Aeson (ToJSON)
import Data.Semilattice.Lower
import Diffing.Algorithm
import GHC.Generics (Generic, Generic1)
import Language.TypeScript.Resolution
data Import a = Import { importSymbols :: ![Alias], importFrom :: ImportPath }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
@ -25,7 +36,7 @@ instance Evaluatable Import where
eval _ _ (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
((moduleScope, moduleFrame), _) <- require modulePath
if Prologue.null symbols then do
if Prelude.null symbols then do
insertImportEdge moduleScope
insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame)
else do

12
src/Language/TypeScript/Syntax/JavaScript.hs
View File

@ -1,15 +1,21 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, RecordWildCards, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Language.TypeScript.Syntax.JavaScript (module Language.TypeScript.Syntax.JavaScript) where
import Prologue
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph hiding (Import)
import Data.Abstract.Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Map.Strict as Map
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Language.TypeScript.Resolution
newtype ImplementsClause a = ImplementsClause { implementsClauseTypes :: [a] }

21
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -1,17 +1,30 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, FlexibleContexts, RecordWildCards, TupleSections, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Language.TypeScript.Syntax.TypeScript (module Language.TypeScript.Syntax.TypeScript) where
import Prologue
import Control.Abstract hiding (Import)
import Control.Monad
import Data.Abstract.Evaluatable as Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Foldable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Semigroup.App
import Data.Semigroup.Foldable
import qualified Data.Text as T
import Data.Traversable
import Diffing.Algorithm
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import GHC.Generics (Generic1)
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier { contents :: T.Text }

14
src/Language/TypeScript/Syntax/Types.hs
View File

@ -1,14 +1,20 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DuplicateRecordFields, RecordWildCards, TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Language.TypeScript.Syntax.Types (module Language.TypeScript.Syntax.Types) where
import Prologue
import Control.Abstract hiding (Import)
import Data.Abstract.Evaluatable as Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import GHC.Generics (Generic1)
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }

9
src/Numeric/Exts.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings, TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Numeric.Exts
( parseInteger
, hex
@ -11,11 +12,11 @@ module Numeric.Exts
import Control.Applicative
import Control.Monad hiding (fail)
import Data.Attoparsec.Text
import Data.Char (isDigit, isOctDigit, isHexDigit)
import Data.Char (isDigit, isHexDigit, isOctDigit)
import Data.Maybe.Exts
import Data.Text
import Numeric
import Prelude hiding (fail, filter)
import Prologue
import Prelude hiding (filter)
import Text.Read (readMaybe)
-- The ending stanza. Note the explicit endOfInput call to ensure we haven't left any dangling input.

9
src/Parsing/Parser.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, TypeApplications, TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Parsing.Parser
( Parser(..)
-- * Parsers
@ -40,7 +44,9 @@ module Parsing.Parser
import Assigning.Assignment
import qualified CMarkGFM
import Data.AST
import Data.Functor.Classes
import Data.Language
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Syntax as Syntax
import Data.Term
@ -60,7 +66,6 @@ import qualified Language.TSX.Assignment as TSXALaCarte
import qualified Language.TypeScript as TypeScriptPrecise
import qualified Language.TypeScript.Assignment as TypeScriptALaCarte
import Prelude hiding (fail)
import Prologue
import Language.Go.Grammar
import qualified TreeSitter.Language as TS (Language, Symbol)
import TreeSitter.PHP

25
src/Parsing/TreeSitter.hs
View File

@ -1,5 +1,11 @@
{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleContexts, GADTs, LambdaCase, RecordWildCards, ScopedTypeVariables,
TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Parsing.TreeSitter
( TSParseException (..)
, Duration(..)
@ -7,15 +13,18 @@ module Parsing.TreeSitter
, parseToPreciseAST
) where
import Prologue
import Control.Carrier.Reader
import qualified Control.Exception as Exc
import Foreign
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
@ -66,7 +75,7 @@ parseToPreciseAST parseTimeout unmarshalTimeout language blob = runParse parseTi
withTimeout :: IO a -> IO a
withTimeout action = System.timeout (toMicroseconds unmarshalTimeout) action >>= maybeM (Exc.throw UnmarshalTimedOut)
instance Exception TSParseException where
instance Exc.Exception TSParseException where
displayException = \case
ParserTimedOut -> "tree-sitter: parser timed out"
IncompatibleVersions -> "tree-sitter: incompatible versions"

77
src/Prologue.hs
View File

@ -1,77 +0,0 @@
{-# LANGUAGE UndecidableInstances #-}
module Prologue
( module X
, eitherM
, maybeM
, maybeLast
, fromMaybeLast
) where
import Data.Bifunctor.Join as X
import Data.Bits as X
import Data.ByteString as X (ByteString)
import Data.Coerce as X
import Data.Either as X (fromLeft, fromRight)
import Data.Int as X (Int16, Int32, Int64, Int8)
import Data.IntMap as X (IntMap)
import Data.IntSet as X (IntSet)
import Data.Ix as X (Ix (..))
import Data.List.NonEmpty as X (NonEmpty (..), nonEmpty, some1)
import Data.Map as X (Map)
import Data.Maybe as X
import Data.Semilattice.Lower as X (Lower (..))
import Data.Sequence as X (Seq)
import Data.Set as X (Set)
import Data.Sum as X ((:<), (:<:), Apply (..), Element, Elements, Sum, inject)
import Data.Text as X (Text)
import Data.Word as X (Word16, Word32, Word64, Word8)
import Debug.Trace as X (traceM, traceShowM)
import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo)
-- Typeclasses
import Control.Applicative as X
import Control.Arrow as X ((&&&), (***))
import Control.Effect.NonDet as X (foldMapA)
import Control.Monad as X hiding (fail, return)
import Control.Monad.Fail as X (MonadFail (..))
import Control.Monad.IO.Class as X (MonadIO (..))
import Data.Algebra as X
import Data.Bifoldable as X
import Data.Bifunctor as X (Bifunctor (..))
import Data.Bitraversable as X
import Data.Foldable as X hiding (product, sum)
import Data.Function as X (fix, on, (&))
import Data.Functor as X (($>))
import Data.Functor.Classes as X
import Data.Functor.Classes.Generic as X
import Data.Functor.Foldable as X (Base, Corecursive (..), Recursive (..))
import Data.Hashable as X (Hashable, hash, hashUsing, hashWithSalt)
import Data.Hashable.Lifted as X (Hashable1 (..), hashWithSalt1)
import Data.Monoid as X (First (..), Last (..), Monoid (..))
import Data.Monoid.Generic as X
import Data.Proxy as X (Proxy (..))
import Data.Semigroup as X (Semigroup (..))
import Data.Traversable as X
import Data.Typeable as X (Typeable)
-- Generics
import GHC.Generics as X (Generic, Generic1)
import GHC.Stack as X
maybeLast :: Foldable t => b -> (a -> b) -> t a -> b
maybeLast b f = maybe b f . getLast . foldMap (Last . Just)
fromMaybeLast :: Foldable t => a -> t a -> a
fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just)
-- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action.
maybeM :: Applicative f => f a -> Maybe a -> f a
maybeM f = maybe f pure
{-# INLINE maybeM #-}
-- Promote a function to either-applicatives.
eitherM :: Applicative f => (a -> f b) -> Either a b -> f b
eitherM f = either f pure
{-# INLINE eitherM #-}

11
src/Rendering/Graph.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MonoLocalBinds, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Rendering.Graph
( renderTreeGraph
, termStyle
@ -14,14 +18,15 @@ import Control.Carrier.State.Strict
import Control.Lens
import Data.Diff
import Data.Edit
import Data.Foldable
import Data.Functor.Foldable
import Data.Graph
import Data.ProtoLens (defMessage)
import Data.String (IsString (..))
import Data.Term
import Prologue
import Semantic.Api.Bridge
import Proto.Semantic as P
import Proto.Semantic_Fields as P
import Semantic.Api.Bridge
import Source.Loc as Loc
import qualified Data.Text as T

11
src/Rendering/JSON.hs
View File

@ -1,4 +1,11 @@
{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Rendering.JSON
( JSON(..)
, renderJSONDiff
@ -15,10 +22,10 @@ module Rendering.JSON
import Data.Aeson as A
import Data.Blob
import Data.Foldable (fold)
import Data.JSON.Fields
import Data.Text (pack)
import GHC.TypeLits
import Prologue
newtype JSON (key :: Symbol) a = JSON { unJSON :: [a] }
deriving (Eq, Monoid, Semigroup, Show)

36
src/Rendering/TOC.hs
View File

@ -1,4 +1,12 @@
{-# LANGUAGE DeriveGeneric, DerivingVia, DuplicateRecordFields, LambdaCase, OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Rendering.TOC
( diffTOC
, Summaries(..)
@ -10,17 +18,25 @@ module Rendering.TOC
, summarizeChange
) where
import Prologue hiding (index)
import Analysis.TOCSummary
import Data.Aeson (ToJSON(..), Value, (.=), object)
import Data.Diff
import Data.Edit
import Data.Language as Language
import Data.List (sortOn)
import Analysis.TOCSummary
import Control.Applicative
import Control.Arrow ((&&&))
import Data.Aeson (ToJSON (..), Value, object, (.=))
import Data.Bifoldable
import Data.Bifunctor
import Data.Diff
import Data.Edit
import Data.Foldable
import Data.Functor.Foldable (cata)
import Data.Language as Language
import Data.List (sortOn)
import qualified Data.Map.Monoidal as Map
import Data.Term
import Data.Maybe
import Data.Monoid.Generic
import Data.Term
import qualified Data.Text as T
import Source.Loc
import GHC.Generics (Generic)
import Source.Loc
data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] }
deriving (Eq, Show, Generic)

32
src/Semantic/Analysis.hs
View File

@ -1,24 +1,28 @@
{-# LANGUAGE DataKinds, FlexibleContexts, TypeFamilies, TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Semantic.Analysis
( evaluate
, runDomainEffects
, evalTerm
) where
import Prologue
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 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.Language (Language)
import Source.Span
import Source.Span
type ModuleC address value m
= ErrorC (LoopControl value)
@ -77,7 +81,7 @@ evaluate lang runModule modules = 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 Prologue.null scopeEdges then newPreludeScope scopeEdges else newScope scopeEdges
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)

20
src/Semantic/Api/Diffs.hs
View File

@ -1,4 +1,10 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MonoLocalBinds, RankNTypes, UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Api.Diffs
( parseDiffBuilder
, DiffOutputFormat(..)
@ -13,23 +19,27 @@ import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifoldable
import Data.Blob
import Data.ByteString.Builder
import Data.Diff
import Data.Edit
import Data.Foldable
import Data.Functor.Classes
import Data.Graph
import Data.JSON.Fields (ToJSONFields1)
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Term (IsTerm(..))
import Data.Term (IsTerm (..))
import qualified Data.Text as T
import Diffing.Interpreter (DiffTerms(..))
import Diffing.Interpreter (DiffTerms (..))
import Parsing.Parser
import Prologue
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON()
import Proto.Semantic_JSON ()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON

3
src/Semantic/Api/LegacyTypes.hs
View File

@ -16,7 +16,8 @@ module Semantic.Api.LegacyTypes
import Data.Aeson
import Data.Blob
import Prologue
import Data.Text (Text)
import GHC.Generics (Generic)
newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] }
deriving (Eq, Show, Generic, FromJSON)

5
src/Semantic/Api/Symbols.hs
View File

@ -24,12 +24,15 @@ import Control.Lens
import Data.Abstract.Declarations
import Data.Blob
import Data.ByteString.Builder
import Data.Foldable
import Data.Functor.Foldable
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Term (IsTerm (..), TermF)
import Data.Text (Text)
import Data.Text (pack)
import qualified Parsing.Parser as Parser
import Prologue
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()

23
src/Semantic/Api/Terms.hs
View File

@ -1,4 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -freduction-depth=0 #-}
module Semantic.Api.Terms
( termGraph
@ -16,17 +26,20 @@ import Data.Aeson (ToJSON)
import Data.Blob
import Data.ByteString.Builder
import Data.Either
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Graph
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Quieterm
import Data.Term
import qualified Data.Text as T
import Parsing.Parser
import Prologue
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON()
import Proto.Semantic_JSON ()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
@ -39,13 +52,13 @@ import qualified Serializing.SExpression as SExpr
import qualified Serializing.SExpression.Precise as SExpr.Precise (serializeSExpression)
import Source.Loc
import qualified Language.Go as GoPrecise
import qualified Language.Java as Java
import qualified Language.JSON as JSON
import qualified Language.Go as GoPrecise
import qualified Language.Python as PythonPrecise
import qualified Language.Ruby as RubyPrecise
import qualified Language.TypeScript as TypeScriptPrecise
import qualified Language.TSX as TSXPrecise
import qualified Language.TypeScript as TypeScriptPrecise
termGraph :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m) => t Blob -> m ParseTreeGraphResponse

6
src/Semantic/CLI.hs
View File

@ -5,15 +5,18 @@ module Semantic.CLI (main) where
import qualified Analysis.File as File
import qualified Control.Carrier.Parse.Measured as Parse
import Control.Carrier.Reader
import Control.Exception
import Control.Monad.IO.Class
import Data.Blob.IO
import Data.Either
import qualified Data.Flag as Flag
import Data.Foldable
import Data.Handle
import qualified Data.Language as Language
import Data.List (intercalate)
import Data.Maybe.Exts
import Data.Project
import Options.Applicative hiding (style)
import Prologue
import Semantic.Api hiding (File)
import Semantic.Config
import qualified Semantic.Graph as Graph
@ -28,7 +31,6 @@ import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
import Control.Concurrent (mkWeakThreadId, myThreadId)
import Control.Exception (throwTo)
import Proto.Semantic_JSON ()
import System.Mem.Weak (deRefWeak)
import System.Posix.Signals

4
src/Semantic/Config.hs
View File

@ -21,11 +21,11 @@ module Semantic.Config
) where
import Data.Duration
import Data.Error (LogPrintSource(..))
import Data.Error (LogPrintSource (..))
import Data.Flag
import Data.Maybe
import Network.HostName
import Network.URI
import Prologue
import Semantic.Env
import Semantic.Telemetry
import qualified Semantic.Telemetry.Error as Error

13
src/Semantic/Distribute.hs
View File

@ -1,5 +1,12 @@
{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- TODO: We should kill this entirely, because with fused-effects 1.0 we can unlift the various runConcurrently operations.
module Semantic.Distribute
@ -18,7 +25,7 @@ import Control.Carrier.Reader
import qualified Control.Concurrent.Async as Async
import Control.Monad.IO.Unlift
import Control.Parallel.Strategies
import Prologue
import Data.Foldable (fold)
-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
--

3
src/Semantic/Env.hs
View File

@ -4,7 +4,8 @@ module Semantic.Env
, envLookupString
) where
import Prologue
import Control.Monad.IO.Class
import Data.Maybe
import System.Environment
import Text.Read (readMaybe)

7
src/Semantic/Graph.hs
View File

@ -53,6 +53,7 @@ import Control.Carrier.Resumable.Resume
import Control.Carrier.State.Strict
import Control.Effect.Parse
import Control.Lens.Getter
import Control.Monad
import Data.Abstract.AccessControls.Instances ()
import Data.Abstract.Address.Hole as Hole
import Data.Abstract.Address.Monovariant as Monovariant
@ -66,17 +67,19 @@ import Data.Abstract.Value.Abstract as Abstract
import Data.Abstract.Value.Concrete as Concrete (Value, ValueError (..), runValueErrorWith)
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.Functor.Foldable
import Data.Graph
import Data.Graph.ControlFlowVertex (VertexDeclaration)
import Data.Language as Language
import Data.List (isPrefixOf)
import Data.List (find, isPrefixOf)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Project
import Data.Proxy
import Data.Text (pack, unpack)
import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Parsing.Parser
import Prologue hiding (TypeError (..))
import Semantic.Analysis
import Semantic.Task as Task
import Source.Loc as Loc

2
src/Semantic/IO.hs
View File

@ -9,8 +9,8 @@ module Semantic.IO
) where
import Prelude hiding (readFile)
import Prologue
import Control.Monad.IO.Class
import System.Directory (doesDirectoryExist)
import System.Directory.Tree (AnchoredDirTree (..))
import qualified System.Directory.Tree as Tree

7
src/Semantic/Resolution.hs
View File

@ -21,13 +21,18 @@ module Semantic.Resolution
import Analysis.File as File
import Control.Algebra
import Control.Monad.IO.Class
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Blob
import Data.Foldable
import Data.Language
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe.Exts
import Data.Project
import Prologue
import Data.Text (Text)
import GHC.Generics (Generic1)
import Semantic.Task.Files
import qualified Source.Source as Source
import System.FilePath.Posix

Some files were not shown because too many files have changed in this diff Show More