mirror of
https://github.com/github/semantic.git
synced 2024-11-24 00:42:33 +03:00
Merge remote-tracking branch 'origin/master' into dockerize
This commit is contained in:
Timothy Clem
commit
3240f64de3
@ -79,9 +79,9 @@ cachingTerms recur term = do
|
||||
cachingConfiguration c pairs (recur term)
|
||||
|
||||
convergingModules :: ( AbstractValue location value effects
|
||||
, Addressable location effects
|
||||
, Cacheable term location (Cell location) value
|
||||
, Members '[ Fresh
|
||||
, Members '[ Allocator location value
|
||||
, Fresh
|
||||
, NonDet
|
||||
, Reader (Cache term location (Cell location) value)
|
||||
, Reader (Environment location value)
|
||||
|
||||
@ -25,10 +25,11 @@ import Data.Aeson hiding (Result)
|
||||
import Data.ByteString.Builder
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Graph
|
||||
import Data.Sum
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term
|
||||
import Data.Text.Encoding as T
|
||||
import Prologue hiding (packageName)
|
||||
import Prologue hiding (packageName, project)
|
||||
|
||||
-- | A vertex of some specific type.
|
||||
data Vertex
|
||||
@ -64,7 +65,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax
|
||||
=> SubtermAlgebra (Base term) term (TermEvaluator term (Located location) value effects a)
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term (Located location) value effects a)
|
||||
graphingTerms recur term@(In _ syntax) = do
|
||||
case projectSum syntax of
|
||||
case project syntax of
|
||||
Just (Syntax.Identifier name) -> do
|
||||
moduleInclusion (Variable (unName name))
|
||||
variableDefinition name
|
||||
|
||||
@ -22,7 +22,7 @@ import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Language.Markdown.Syntax as Markdown
|
||||
import qualified Language.Ruby.Syntax as Ruby.Syntax
|
||||
import Prologue
|
||||
import Prologue hiding (project)
|
||||
|
||||
-- | A declaration’s identifier and type.
|
||||
data Declaration
|
||||
@ -129,12 +129,12 @@ getSource blobSource = toText . flip Source.slice blobSource . getField
|
||||
|
||||
instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where
|
||||
customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _)
|
||||
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- projectSum fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF)
|
||||
| Just (Syntax.Identifier (Name name)) <- projectSum fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage []
|
||||
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- project fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF)
|
||||
| Just (Syntax.Identifier (Name name)) <- project fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage []
|
||||
| otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage []
|
||||
where
|
||||
memberAccess modAnn termFOut
|
||||
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In rightAnn rightF))) <- projectSum termFOut
|
||||
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In rightAnn rightF))) <- project termFOut
|
||||
= memberAccess leftAnn leftF <> memberAccess rightAnn rightF
|
||||
| otherwise = [getSource modAnn]
|
||||
getSource = toText . flip Source.slice blobSource . getField
|
||||
|
||||
@ -1,129 +1,43 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Abstract.Addressable where
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Abstract.Addressable
|
||||
( Addressable(..)
|
||||
) where
|
||||
|
||||
import Control.Abstract.Context
|
||||
import Control.Abstract.Environment
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Abstract.Heap
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment (insert)
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Semigroup.Reducer
|
||||
import Prologue
|
||||
|
||||
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
|
||||
-- | Defines allocation and dereferencing of 'Address'es in a 'Heap'.
|
||||
class (Ord location, Show location) => Addressable location effects where
|
||||
-- | The type into which stored values will be written for a given location type.
|
||||
type family Cell location :: * -> *
|
||||
|
||||
allocCell :: Name -> Evaluator location value effects location
|
||||
derefCell :: Address location value -> Cell location value -> Evaluator location value effects (Maybe value)
|
||||
|
||||
allocLoc :: Name -> Evaluator location value effects location
|
||||
|
||||
-- | Look up or allocate an address for a 'Name'.
|
||||
lookupOrAlloc :: ( Addressable location effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
] effects
|
||||
)
|
||||
=> Name
|
||||
-> Evaluator location value effects (Address location value)
|
||||
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
|
||||
|
||||
|
||||
letrec :: ( Addressable location effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> Name
|
||||
-> Evaluator location value effects value
|
||||
-> Evaluator location value effects (value, Address location value)
|
||||
letrec name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
v <- localEnv (insert name addr) body
|
||||
assign addr v
|
||||
pure (v, addr)
|
||||
|
||||
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
||||
letrec' :: ( Addressable location effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
] effects
|
||||
)
|
||||
=> Name
|
||||
-> (Address location value -> Evaluator location value effects value)
|
||||
-> Evaluator location value effects value
|
||||
letrec' name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
v <- localEnv id (body addr)
|
||||
v <$ modifyEnv (insert name addr)
|
||||
|
||||
|
||||
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
||||
variable :: ( Addressable location effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
)
|
||||
=> Name
|
||||
-> Evaluator location value effects value
|
||||
variable name = lookupEnv name >>= maybe (freeVariableError name) deref
|
||||
|
||||
-- Instances
|
||||
|
||||
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
|
||||
-- | 'Precise' locations are always allocated a fresh 'Address', and dereference to the 'Latest' value written.
|
||||
instance Member Fresh effects => Addressable Precise effects where
|
||||
type Cell Precise = Latest
|
||||
|
||||
allocCell _ = Precise <$> fresh
|
||||
derefCell _ = pure . getLast . unLatest
|
||||
allocLoc _ = Precise <$> fresh
|
||||
|
||||
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
|
||||
-- | 'Monovariant' locations allocate one 'Address' per unique variable name, and dereference once per stored value, nondeterministically.
|
||||
instance Member NonDet effects => Addressable Monovariant effects where
|
||||
derefCell _ cell | null cell = pure Nothing
|
||||
| otherwise = foldMapA (pure . Just) cell
|
||||
allocLoc = pure . Monovariant
|
||||
type Cell Monovariant = All
|
||||
|
||||
instance ( Addressable location effects
|
||||
, Members '[ Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
] effects
|
||||
)
|
||||
=> Addressable (Located location) effects where
|
||||
derefCell (Address (Located loc _ _)) = raiseEff . lowerEff . derefCell (Address loc)
|
||||
allocCell = pure . Monovariant
|
||||
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
|
||||
|
||||
allocLoc name = raiseEff (lowerEff (Located <$> allocLoc name <*> currentPackage <*> currentModule))
|
||||
-- | 'Located' locations allocate & dereference using the underlying location, contextualizing locations with the current 'PackageInfo' & 'ModuleInfo'.
|
||||
instance (Addressable location effects, Members '[Reader ModuleInfo, Reader PackageInfo] effects) => Addressable (Located location) effects where
|
||||
type Cell (Located location) = Cell location
|
||||
|
||||
-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
|
||||
deref :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Address location value -> Evaluator location value effects value
|
||||
deref addr = do
|
||||
cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr))
|
||||
derefed <- derefCell addr cell
|
||||
maybeM (throwAddressError (UninitializedAddress addr)) derefed
|
||||
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule)
|
||||
derefCell (Address (Located loc _ _)) = relocate . derefCell (Address loc)
|
||||
|
||||
alloc :: Addressable location effects => Name -> Evaluator location value effects (Address location value)
|
||||
alloc = fmap Address . allocLoc
|
||||
|
||||
data AddressError location value resume where
|
||||
UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
|
||||
UninitializedAddress :: Address location value -> AddressError location value value
|
||||
|
||||
deriving instance Eq location => Eq (AddressError location value resume)
|
||||
deriving instance Show location => Show (AddressError location value resume)
|
||||
instance Show location => Show1 (AddressError location value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
instance Eq location => Eq1 (AddressError location value) where
|
||||
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
|
||||
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
|
||||
throwAddressError :: Member (Resumable (AddressError location value)) effects => AddressError location value resume -> Evaluator location value effects resume
|
||||
throwAddressError = throwResumable
|
||||
|
||||
runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
|
||||
runAddressError = runResumable
|
||||
|
||||
runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
|
||||
runAddressErrorWith = runResumableWith
|
||||
relocate :: Evaluator location value effects a -> Evaluator (Located location) value effects a
|
||||
relocate = raiseEff . lowerEff
|
||||
|
||||
@ -4,6 +4,7 @@ module Control.Abstract.Configuration
|
||||
, getConfiguration
|
||||
) where
|
||||
|
||||
import Control.Abstract.Addressable
|
||||
import Control.Abstract.Environment
|
||||
import Control.Abstract.Heap
|
||||
import Control.Abstract.Roots
|
||||
|
||||
@ -1,17 +1,33 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Abstract.Heap
|
||||
( Heap
|
||||
, Cell
|
||||
, getHeap
|
||||
, putHeap
|
||||
, modifyHeap
|
||||
, lookupHeap
|
||||
, alloc
|
||||
, deref
|
||||
, assign
|
||||
, lookupOrAlloc
|
||||
, letrec
|
||||
, letrec'
|
||||
, variable
|
||||
-- * Effects
|
||||
, Allocator(..)
|
||||
, runAllocator
|
||||
, AddressError(..)
|
||||
, runAddressError
|
||||
, runAddressErrorWith
|
||||
) where
|
||||
|
||||
import Control.Abstract.Addressable
|
||||
import Control.Abstract.Environment
|
||||
import Control.Abstract.Evaluator
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Semigroup.Reducer
|
||||
import Prologue
|
||||
|
||||
-- | Retrieve the heap.
|
||||
getHeap :: Member (State (Heap location (Cell location) value)) effects => Evaluator location value effects (Heap location (Cell location) value)
|
||||
@ -25,9 +41,14 @@ putHeap = put
|
||||
modifyHeap :: Member (State (Heap location (Cell location) value)) effects => (Heap location (Cell location) value -> Heap location (Cell location) value) -> Evaluator location value effects ()
|
||||
modifyHeap = modify'
|
||||
|
||||
-- | Look up the cell for the given 'Address' in the 'Heap'.
|
||||
lookupHeap :: (Member (State (Heap location (Cell location) value)) effects, Ord location) => Address location value -> Evaluator location value effects (Maybe (Cell location value))
|
||||
lookupHeap = flip fmap getHeap . heapLookup
|
||||
|
||||
alloc :: Member (Allocator location value) effects => Name -> Evaluator location value effects (Address location value)
|
||||
alloc = send . Alloc
|
||||
|
||||
-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
|
||||
deref :: Member (Allocator location value) effects => Address location value -> Evaluator location value effects value
|
||||
deref = send . Deref
|
||||
|
||||
|
||||
-- | Write a value to the given 'Address' in the 'Store'.
|
||||
assign :: ( Member (State (Heap location (Cell location) value)) effects
|
||||
@ -38,3 +59,89 @@ assign :: ( Member (State (Heap location (Cell location) value)) effects
|
||||
-> value
|
||||
-> Evaluator location value effects ()
|
||||
assign address = modifyHeap . heapInsert address
|
||||
|
||||
|
||||
-- | Look up or allocate an address for a 'Name'.
|
||||
lookupOrAlloc :: Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
] effects
|
||||
=> Name
|
||||
-> Evaluator location value effects (Address location value)
|
||||
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
|
||||
|
||||
|
||||
letrec :: ( Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> Name
|
||||
-> Evaluator location value effects value
|
||||
-> Evaluator location value effects (value, Address location value)
|
||||
letrec name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
v <- localEnv (insert name addr) body
|
||||
assign addr v
|
||||
pure (v, addr)
|
||||
|
||||
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
||||
letrec' :: Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
] effects
|
||||
=> Name
|
||||
-> (Address location value -> Evaluator location value effects value)
|
||||
-> Evaluator location value effects value
|
||||
letrec' name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
v <- localEnv id (body addr)
|
||||
v <$ modifyEnv (insert name addr)
|
||||
|
||||
|
||||
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
||||
variable :: Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
=> Name
|
||||
-> Evaluator location value effects value
|
||||
variable name = lookupEnv name >>= maybe (freeVariableError name) deref
|
||||
|
||||
|
||||
-- Effects
|
||||
|
||||
data Allocator location value return where
|
||||
Alloc :: Name -> Allocator location value (Address location value)
|
||||
Deref :: Address location value -> Allocator location value value
|
||||
|
||||
runAllocator :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Evaluator location value (Allocator location value ': effects) a -> Evaluator location value effects a
|
||||
runAllocator = interpret (\ eff -> case eff of
|
||||
Alloc name -> Address <$> allocCell name
|
||||
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))
|
||||
|
||||
|
||||
data AddressError location value resume where
|
||||
UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
|
||||
UninitializedAddress :: Address location value -> AddressError location value value
|
||||
|
||||
deriving instance Eq location => Eq (AddressError location value resume)
|
||||
deriving instance Show location => Show (AddressError location value resume)
|
||||
instance Show location => Show1 (AddressError location value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
instance Eq location => Eq1 (AddressError location value) where
|
||||
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
|
||||
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
|
||||
runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
|
||||
runAddressError = runResumable
|
||||
|
||||
runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
|
||||
runAddressErrorWith = runResumableWith
|
||||
|
||||
@ -17,7 +17,7 @@ module Control.Abstract.Matching
|
||||
import Data.Algebra
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
import Prologue
|
||||
import Prologue hiding (project)
|
||||
|
||||
-- | A @Matcher t a@ is a tree automaton that matches some 'Recursive' and 'Corecursive' type @t@, yielding values of type @a@.
|
||||
-- Matching operations are implicitly recursive: when you run a 'Matcher', it is applied bottom-up.
|
||||
@ -92,11 +92,11 @@ match :: (f :< fs)
|
||||
=> (f (Term (Sum fs) ann) -> b)
|
||||
-> Matcher b a
|
||||
-> Matcher (Term (Sum fs) ann) a
|
||||
match f = Match (fmap f . projectSum . termOut)
|
||||
match f = Match (fmap f . project . termOut)
|
||||
|
||||
-- | @narrow'@ attempts to project a union-type target to a more specific type.
|
||||
narrow' :: (f :< fs) => Matcher (Term (Sum fs) ann) (Maybe (f (Term (Sum fs) ann)))
|
||||
narrow' = fmap (projectSum . termOut) Target
|
||||
narrow' = fmap (project . termOut) Target
|
||||
|
||||
-- | 'narrow' behaves as @narrow'@, but fails if the target cannot be thus projected.
|
||||
narrow :: (f :< fs) => Matcher (Term (Sum fs) ann) (f (Term (Sum fs) ann))
|
||||
|
||||
@ -10,10 +10,11 @@ module Control.Abstract.Value
|
||||
, ValueRoots(..)
|
||||
) where
|
||||
|
||||
import Control.Abstract.Addressable
|
||||
import Control.Abstract.Environment
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Abstract.Heap
|
||||
import Data.Abstract.Address (Address, Cell)
|
||||
import Data.Abstract.Address (Address)
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Live (Live)
|
||||
|
||||
@ -22,18 +22,10 @@ instance Show location => Show (Address location value) where
|
||||
showsPrec d = showsPrec d . unAddress
|
||||
|
||||
|
||||
class Location location where
|
||||
-- | The type into which stored values will be written for a given location type.
|
||||
type family Cell location :: * -> *
|
||||
|
||||
|
||||
-- | '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 }
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Location Precise where
|
||||
type Cell Precise = Latest
|
||||
|
||||
instance Show Precise where
|
||||
showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
|
||||
|
||||
@ -42,9 +34,6 @@ instance Show Precise where
|
||||
newtype Monovariant = Monovariant { unMonovariant :: Name }
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Location Monovariant where
|
||||
type Cell Monovariant = All
|
||||
|
||||
instance Show Monovariant where
|
||||
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unName . unMonovariant
|
||||
|
||||
@ -56,9 +45,6 @@ data Located location = Located
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Location (Located location) where
|
||||
type Cell (Located location) = Cell location
|
||||
|
||||
|
||||
-- | A cell holding a single value. Writes will replace any prior value.
|
||||
--
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Data.Abstract.Environment
|
||||
( Environment(..)
|
||||
, addresses
|
||||
@ -19,16 +18,15 @@ module Data.Abstract.Environment
|
||||
, roots
|
||||
) where
|
||||
|
||||
import Prelude hiding (head, lookup)
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Live
|
||||
import Data.Align
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Map as Map
|
||||
import Data.Semilattice.Lower
|
||||
import GHC.Exts (IsList (..))
|
||||
import Prelude hiding (head, lookup)
|
||||
import Prologue
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
-- $setup
|
||||
-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
|
||||
@ -37,21 +35,13 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
|
||||
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
|
||||
-- scope for "a", then the next, and so on.
|
||||
newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
|
||||
newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) }
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Eq location => Eq1 (Environment location) where liftEq _ (Environment a) (Environment b) = a == b
|
||||
instance Ord location => Ord1 (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` b
|
||||
instance Eq location => Eq1 (Environment location) where liftEq eq (Environment a) (Environment b) = liftEq (liftEq (liftEq eq)) a b
|
||||
instance Ord location => Ord1 (Environment location) where liftCompare compare (Environment a) (Environment b) = liftCompare (liftCompare (liftCompare compare)) a b
|
||||
instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec
|
||||
|
||||
-- | The provided list will be put into an Environment with one member, so fromList is total
|
||||
-- (despite NonEmpty's instance being partial). Don't pass in multiple Addresses for the
|
||||
-- same Name or you violate the axiom that toList . fromList == id.
|
||||
instance IsList (Environment location value) where
|
||||
type Item (Environment location value) = (Name, Address location value)
|
||||
fromList xs = Environment (Map.fromList (second unAddress <$> xs) :| [])
|
||||
toList (Environment (x :| _)) = second Address <$> Map.toList x
|
||||
|
||||
mergeEnvs :: Environment location value -> Environment location value -> Environment location value
|
||||
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
|
||||
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
|
||||
@ -79,29 +69,29 @@ mergeNewer (Environment a) (Environment b) =
|
||||
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
|
||||
where
|
||||
combine = Map.unionWith (flip const)
|
||||
as = NonEmpty.toList a
|
||||
bs = NonEmpty.toList b
|
||||
as = toList a
|
||||
bs = toList b
|
||||
|
||||
-- | Extract an association list of bindings from an 'Environment'.
|
||||
--
|
||||
-- >>> pairs shadowed
|
||||
-- [("foo",Precise 1)]
|
||||
pairs :: Environment location value -> [(Name, Address location value)]
|
||||
pairs = map (second Address) . Map.toList . fold . unEnvironment
|
||||
pairs = Map.toList . fold . unEnvironment
|
||||
|
||||
unpairs :: [(Name, Address location value)] -> Environment location value
|
||||
unpairs = fromList
|
||||
unpairs = Environment . pure . Map.fromList
|
||||
|
||||
-- | Lookup a 'Name' in the environment.
|
||||
--
|
||||
-- >>> lookup (name "foo") shadowed
|
||||
-- Just (Precise 1)
|
||||
lookup :: Name -> Environment location value -> Maybe (Address location value)
|
||||
lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment
|
||||
lookup k = foldMapA (Map.lookup k) . unEnvironment
|
||||
|
||||
-- | Insert a 'Name' in the environment.
|
||||
insert :: Name -> Address location value -> Environment location value -> Environment location value
|
||||
insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as)
|
||||
insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as)
|
||||
|
||||
-- | Remove a 'Name' from the environment.
|
||||
--
|
||||
@ -115,7 +105,7 @@ trim (Environment (a :| as)) = Environment (a :| filtered)
|
||||
where filtered = filter (not . Map.null) as
|
||||
|
||||
bind :: Foldable t => t Name -> Environment location value -> Environment location value
|
||||
bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
|
||||
bind names env = unpairs (mapMaybe lookupName (toList names))
|
||||
where
|
||||
lookupName name = (,) name <$> lookup name env
|
||||
|
||||
@ -125,7 +115,7 @@ names = fmap fst . pairs
|
||||
|
||||
-- | Lookup and alias name-value bindings from an environment.
|
||||
overwrite :: [(Name, Name)] -> Environment location value -> Environment location value
|
||||
overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
|
||||
overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
|
||||
where
|
||||
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
|
||||
|
||||
|
||||
@ -52,16 +52,15 @@ class Evaluatable constr where
|
||||
|
||||
type EvaluatableConstraints location term value effects =
|
||||
( AbstractValue location value effects
|
||||
, Addressable location effects
|
||||
, Declarations term
|
||||
, FreeVariables term
|
||||
, Members '[ LoopControl value
|
||||
, Members '[ Allocator location value
|
||||
, LoopControl value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, Reader Span
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, Resumable ResolutionError
|
||||
@ -72,6 +71,7 @@ type EvaluatableConstraints location term value effects =
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
|
||||
@ -139,10 +139,9 @@ instance Show1 (Unspecialized a) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
|
||||
-- | Evaluates a 'Value' returning the referenced value
|
||||
value :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
value :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
@ -156,10 +155,9 @@ value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
|
||||
value (Rval val) = pure val
|
||||
|
||||
-- | Evaluates a 'Subterm' to its rval
|
||||
subtermValue :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
subtermValue :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
@ -200,14 +198,15 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator lo
|
||||
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
||||
|
||||
|
||||
builtin :: ( Addressable location effects
|
||||
, HasCallStack
|
||||
, Members '[ Reader (Environment location value)
|
||||
builtin :: ( HasCallStack
|
||||
, Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, Reader ModuleInfo
|
||||
, Reader Span
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> String
|
||||
@ -221,20 +220,24 @@ builtin n def = withCurrentCallStack callStack $ do
|
||||
|
||||
-- | Evaluate a given package.
|
||||
evaluatePackageWith :: forall location term value inner inner' outer
|
||||
. ( Evaluatable (Base term)
|
||||
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
|
||||
. ( Addressable location (Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
, Evaluatable (Base term)
|
||||
, EvaluatableConstraints location term value inner
|
||||
, Members '[ Fail
|
||||
, Fresh
|
||||
, Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (LoadError location value)
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
, State (ModuleTable (Maybe (Environment location value, value)))
|
||||
, Trace
|
||||
] outer
|
||||
, Recursive term
|
||||
, inner ~ (Goto inner' value ': inner')
|
||||
, inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
, inner' ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
)
|
||||
=> (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value))
|
||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)))
|
||||
@ -259,6 +262,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
|
||||
runInModule info
|
||||
= runReader info
|
||||
. raiseHandler runAllocator
|
||||
. raiseHandler runReturn
|
||||
. raiseHandler runLoopControl
|
||||
. raiseHandler (runGoto Gotos getGotos)
|
||||
@ -287,7 +291,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
|
||||
pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
|
||||
|
||||
newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
|
||||
newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
|
||||
deriving (Lower)
|
||||
|
||||
|
||||
|
||||
@ -12,8 +12,6 @@ import Prologue
|
||||
newtype Heap location cell value = Heap { unHeap :: Monoidal.Map location (cell value) }
|
||||
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
|
||||
|
||||
deriving instance (Ord location, Reducer value (cell value)) => Reducer (location, value) (Heap location cell value)
|
||||
|
||||
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
|
||||
heapLookup :: Ord location => Address location value -> Heap location cell value -> Maybe (cell value)
|
||||
heapLookup (Address address) = Monoidal.lookup address . unHeap
|
||||
@ -24,7 +22,7 @@ heapLookupAll address = fmap toList . heapLookup address
|
||||
|
||||
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
|
||||
heapInsert :: (Ord location, Reducer value (cell value)) => Address location value -> value -> Heap location cell value -> Heap location cell value
|
||||
heapInsert (Address address) value = flip snoc (address, value)
|
||||
heapInsert address value = flip snoc (address, value)
|
||||
|
||||
-- | Manually insert a cell into the heap at a given address.
|
||||
heapInit :: Ord location => Address location value -> cell value -> Heap location cell value -> Heap location cell value
|
||||
@ -39,6 +37,10 @@ heapRestrict :: Ord location => Heap location cell value -> Live location value
|
||||
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)
|
||||
|
||||
|
||||
instance (Ord location, Reducer value (cell value)) => Reducer (Address location value, value) (Heap location cell value) where
|
||||
unit = Heap . unit . first unAddress
|
||||
cons (Address key, a) (Heap heap) = Heap (cons (key, a) heap)
|
||||
snoc (Heap heap) (Address key, a) = Heap (snoc heap (key, a))
|
||||
|
||||
instance (Show location, Show (cell value)) => Show (Heap location cell value) where
|
||||
showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap
|
||||
|
||||
@ -103,8 +103,8 @@ instance AbstractHole Type where
|
||||
hole = Hole
|
||||
|
||||
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
||||
instance ( Addressable location effects
|
||||
, Members '[ Fresh
|
||||
instance ( Members '[ Allocator location Type
|
||||
, Fresh
|
||||
, NonDet
|
||||
, Reader (Environment location Type)
|
||||
, Resumable (AddressError location Type)
|
||||
@ -114,6 +114,7 @@ instance ( Addressable location effects
|
||||
, State (Environment location Type)
|
||||
, State (Heap location (Cell location) Type)
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer Type (Cell location Type)
|
||||
)
|
||||
=> AbstractValue location Type effects where
|
||||
|
||||
@ -12,7 +12,7 @@ import Data.Scientific.Exts
|
||||
import Data.Semigroup.Reducer
|
||||
import qualified Data.Set as Set
|
||||
import Data.Sum
|
||||
import Prologue hiding (TypeError)
|
||||
import Prologue hiding (TypeError, project)
|
||||
import Prelude hiding (Float, Integer, String, Rational)
|
||||
import qualified Prelude
|
||||
|
||||
@ -40,13 +40,13 @@ type ValueConstructors location
|
||||
newtype Value location = Value (Sum (ValueConstructors location) (Value location))
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
|
||||
-- | Identical to 'inject', but wraps the resulting sub-entity in a 'Value'.
|
||||
injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location
|
||||
injValue = Value . injectSum
|
||||
injValue = Value . inject
|
||||
|
||||
-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
|
||||
prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location))
|
||||
prjValue (Value v) = projectSum v
|
||||
prjValue (Value v) = project v
|
||||
|
||||
-- | Convenience function for projecting two values.
|
||||
prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location)
|
||||
@ -205,18 +205,18 @@ instance AbstractHole (Value location) where
|
||||
hole = injValue Hole
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance ( Addressable location (Goto effects (Value location) ': effects)
|
||||
, Members '[ Fail
|
||||
instance ( Members '[ Allocator location (Value location)
|
||||
, Fail
|
||||
, LoopControl (Value location)
|
||||
, Reader (Environment location (Value location))
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, Resumable (AddressError location (Value location))
|
||||
, Resumable (ValueError location)
|
||||
, Return (Value location)
|
||||
, State (Environment location (Value location))
|
||||
, State (Heap location (Cell location) (Value location))
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer (Value location) (Cell location (Value location))
|
||||
, Show location
|
||||
)
|
||||
|
||||
@ -18,12 +18,9 @@ import Data.Semilattice.Lower
|
||||
import Prelude hiding (lookup)
|
||||
import Prologue hiding (Map)
|
||||
|
||||
newtype Map key value = Map (Map.Map key value)
|
||||
newtype Map key value = Map { unMap :: Map.Map key value }
|
||||
deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable)
|
||||
|
||||
unMap :: Map key value -> Map.Map key value
|
||||
unMap (Map map) = map
|
||||
|
||||
|
||||
singleton :: key -> value -> Map key value
|
||||
singleton k v = Map (Map.singleton k v)
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Data.Error as Error
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
||||
makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm a = makeTerm' a . injectSum
|
||||
makeTerm a = makeTerm' a . inject
|
||||
|
||||
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
|
||||
makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
|
||||
@ -31,11 +31,11 @@ makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
|
||||
makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm'' a children = case toList children of
|
||||
[x] -> x
|
||||
_ -> makeTerm' a (injectSum children)
|
||||
_ -> makeTerm' a (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, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm1 = makeTerm1' . injectSum
|
||||
makeTerm1 = makeTerm1' . inject
|
||||
|
||||
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
|
||||
makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
|
||||
|
||||
@ -270,9 +270,9 @@ channelType :: Assignment
|
||||
channelType = makeTerm' <$> symbol ChannelType <*> children (mkChannelType <$> optional (token AnonLAngleMinus) <* token AnonChan <*> optional (token AnonLAngleMinus) <*> expression)
|
||||
where
|
||||
mkChannelType :: Maybe a -> Maybe a -> b -> Sum Syntax b
|
||||
mkChannelType receive send | Just _ <- receive = injectSum . Go.Type.ReceiveChannel
|
||||
| Just _ <- send = injectSum . Go.Type.SendChannel
|
||||
| otherwise = injectSum . Go.Type.BidirectionalChannel
|
||||
mkChannelType receive send | Just _ <- receive = inject . Go.Type.ReceiveChannel
|
||||
| Just _ <- send = inject . Go.Type.SendChannel
|
||||
| otherwise = inject . Go.Type.BidirectionalChannel
|
||||
|
||||
fieldDeclaration :: Assignment
|
||||
fieldDeclaration = mkFieldDeclarationWithTag <$> symbol FieldDeclaration <*> children ((,,) <$> (manyTermsTill expression (void (symbol TypeIdentifier)) <|> manyTerm expression) <*> optional expression <*> optional expression)
|
||||
@ -325,25 +325,25 @@ argumentList = (symbol ArgumentList <|> symbol ArgumentList') *> children expres
|
||||
|
||||
binaryExpression :: Assignment
|
||||
binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression expression
|
||||
[ (injectSum .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (injectSum .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (injectSum .) . Expression.Times <$ symbol AnonStar
|
||||
, (injectSum .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (injectSum .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (injectSum .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (injectSum .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (injectSum .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (injectSum .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (injectSum .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (injectSum .) . invert Expression.Equal <$ symbol AnonBangEqual
|
||||
, (injectSum .) . Expression.Equal <$ symbol AnonEqualEqual
|
||||
, (injectSum .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersandCaret
|
||||
, (injectSum .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (injectSum .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (injectSum .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
[ (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (inject .) . Expression.Times <$ symbol AnonStar
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (inject .) . invert Expression.Equal <$ symbol AnonBangEqual
|
||||
, (inject .) . Expression.Equal <$ symbol AnonEqualEqual
|
||||
, (inject .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersandCaret
|
||||
, (inject .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
])
|
||||
where
|
||||
invert cons a b = Expression.Not (makeTerm1 (cons a b))
|
||||
@ -385,13 +385,13 @@ importDeclaration :: Assignment
|
||||
importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTerm (importSpec <|> importSpecList))
|
||||
where
|
||||
-- `import . "lib/Math"`
|
||||
dotImport = injectSum <$> (flip Go.Syntax.Import <$> dot <*> importFromPath)
|
||||
dotImport = inject <$> (flip Go.Syntax.Import <$> dot <*> importFromPath)
|
||||
-- `import _ "lib/Math"`
|
||||
sideEffectImport = injectSum <$> (flip Go.Syntax.SideEffectImport <$> underscore <*> importFromPath)
|
||||
sideEffectImport = inject <$> (flip Go.Syntax.SideEffectImport <$> underscore <*> importFromPath)
|
||||
-- `import m "lib/Math"`
|
||||
namedImport = injectSum <$> (flip Go.Syntax.QualifiedImport <$> packageIdentifier <*> importFromPath)
|
||||
namedImport = inject <$> (flip Go.Syntax.QualifiedImport <$> packageIdentifier <*> importFromPath)
|
||||
-- `import "lib/Math"`
|
||||
plainImport = injectSum <$> (symbol InterpretedStringLiteral >>= \loc -> do
|
||||
plainImport = inject <$> (symbol InterpretedStringLiteral >>= \loc -> do
|
||||
from <- importPath <$> source
|
||||
let alias = makeTerm loc (Syntax.Identifier (defaultAlias from)) -- Go takes `import "lib/Math"` and uses `Math` as the qualified name (e.g. `Math.Sin()`)
|
||||
Go.Syntax.QualifiedImport <$> pure from <*> pure alias)
|
||||
@ -466,13 +466,13 @@ unaryExpression = makeTerm' <$> symbol UnaryExpression <*> ( notExpression
|
||||
<|> unaryComplement
|
||||
<|> unaryPlus )
|
||||
where
|
||||
notExpression = injectSum <$> children (Expression.Not <$ symbol AnonBang <*> expression)
|
||||
unaryAmpersand = injectSum <$> children (Literal.Reference <$ symbol AnonAmpersand <*> expression)
|
||||
unaryComplement = injectSum <$> children (Expression.Complement <$ symbol AnonCaret <*> expression)
|
||||
unaryMinus = injectSum <$> children (Expression.Negate <$ symbol AnonMinus <*> expression)
|
||||
notExpression = inject <$> children (Expression.Not <$ symbol AnonBang <*> expression)
|
||||
unaryAmpersand = inject <$> children (Literal.Reference <$ symbol AnonAmpersand <*> expression)
|
||||
unaryComplement = inject <$> children (Expression.Complement <$ symbol AnonCaret <*> expression)
|
||||
unaryMinus = inject <$> children (Expression.Negate <$ symbol AnonMinus <*> expression)
|
||||
unaryPlus = children (symbol AnonPlus *> (Term.termOut <$> expression))
|
||||
unaryPointer = injectSum <$> children (Literal.Pointer <$ symbol AnonStar <*> expression)
|
||||
unaryReceive = injectSum <$> children (Go.Syntax.ReceiveOperator <$ symbol AnonLAngleMinus <*> expression)
|
||||
unaryPointer = inject <$> children (Literal.Pointer <$ symbol AnonStar <*> expression)
|
||||
unaryReceive = inject <$> children (Go.Syntax.ReceiveOperator <$ symbol AnonLAngleMinus <*> expression)
|
||||
|
||||
varDeclaration :: Assignment
|
||||
varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions
|
||||
@ -508,7 +508,7 @@ assignment' = makeTerm' <$> symbol AssignmentStatement <*> children (infixTerm
|
||||
])
|
||||
where
|
||||
assign :: Term -> Term -> Sum Syntax Term
|
||||
assign l r = injectSum (Statement.Assignment [] l r)
|
||||
assign l r = inject (Statement.Assignment [] l r)
|
||||
|
||||
augmentedAssign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term
|
||||
augmentedAssign c l r = assign l (makeTerm1 (c l r))
|
||||
@ -541,9 +541,9 @@ emptyStatement = makeTerm <$> token EmptyStatement <*> (Statement.NoOp <$> empty
|
||||
forStatement :: Assignment
|
||||
forStatement = makeTerm' <$> symbol ForStatement <*> children (forClause <|> forSimpleClause <|> rangeClause)
|
||||
where
|
||||
forClause = injectSum <$> (symbol ForClause *> children (Statement.For <$> (expression <|> emptyTerm) <*> (expression <|> emptyTerm) <*> (expression <|> emptyTerm)) <*> expression)
|
||||
forSimpleClause = injectSum <$> (Statement.For <$> emptyTerm <*> (expression <|> emptyTerm) <*> emptyTerm <*> expression)
|
||||
rangeClause = injectSum <$> (symbol RangeClause *> children (Statement.ForEach <$> (expression <|> emptyTerm) <*> expression) <*> expression)
|
||||
forClause = inject <$> (symbol ForClause *> children (Statement.For <$> (expression <|> emptyTerm) <*> (expression <|> emptyTerm) <*> (expression <|> emptyTerm)) <*> expression)
|
||||
forSimpleClause = inject <$> (Statement.For <$> emptyTerm <*> (expression <|> emptyTerm) <*> emptyTerm <*> expression)
|
||||
rangeClause = inject <$> (symbol RangeClause *> children (Statement.ForEach <$> (expression <|> emptyTerm) <*> expression) <*> expression)
|
||||
|
||||
goStatement :: Assignment
|
||||
goStatement = makeTerm <$> symbol GoStatement <*> children (Go.Syntax.Go <$> expression)
|
||||
|
||||
@ -77,9 +77,9 @@ list :: Assignment
|
||||
list = termIn <$> symbol List <*> (makeList . termFAnnotation . termFOut <$> currentNode <*> children (many item))
|
||||
where
|
||||
makeList (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) = case listType of
|
||||
CMarkGFM.BULLET_LIST -> injectSum . Markup.UnorderedList
|
||||
CMarkGFM.ORDERED_LIST -> injectSum . Markup.OrderedList
|
||||
makeList _ = injectSum . Markup.UnorderedList
|
||||
CMarkGFM.BULLET_LIST -> inject . Markup.UnorderedList
|
||||
CMarkGFM.ORDERED_LIST -> inject . Markup.OrderedList
|
||||
makeList _ = inject . Markup.UnorderedList
|
||||
|
||||
item :: Assignment
|
||||
item = makeTerm <$> symbol Item <*> children (many blockElement)
|
||||
|
||||
@ -8,6 +8,7 @@ module Language.PHP.Assignment
|
||||
|
||||
import Assigning.Assignment hiding (Assignment, Error)
|
||||
import Data.Record
|
||||
import Data.Sum
|
||||
import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm1, contextualize, postContextualize)
|
||||
import Language.PHP.Grammar as Grammar
|
||||
import qualified Assigning.Assignment as Assignment
|
||||
@ -229,34 +230,34 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
|
||||
, assign Expression.BXOr <$ symbol AnonCaretEqual
|
||||
, assign Expression.BOr <$ symbol AnonPipeEqual ])
|
||||
where
|
||||
assign c l r = injectSum (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
|
||||
binaryExpression :: Assignment
|
||||
binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term (expression <|> classTypeDesignator))
|
||||
[ (injectSum .) . Expression.And <$ symbol AnonAnd
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonOr
|
||||
, (injectSum .) . Expression.XOr <$ symbol AnonXor
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (injectSum .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (injectSum .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (injectSum .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right.
|
||||
, (injectSum .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (injectSum .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle <|> symbol AnonBangEqualEqual)
|
||||
, (injectSum .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (injectSum .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (injectSum .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (injectSum .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (injectSum .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
|
||||
, (injectSum .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (injectSum .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (injectSum .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (injectSum .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (injectSum .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonDot)
|
||||
, (injectSum .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (injectSum .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (injectSum .) . Expression.InstanceOf <$ symbol AnonInstanceof
|
||||
[ (inject .) . Expression.And <$ symbol AnonAnd
|
||||
, (inject .) . Expression.Or <$ symbol AnonOr
|
||||
, (inject .) . Expression.XOr <$ symbol AnonXor
|
||||
, (inject .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (inject .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (inject .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (inject .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right.
|
||||
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle <|> symbol AnonBangEqualEqual)
|
||||
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
|
||||
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonDot)
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
|
||||
]) where invert cons a b = Expression.Not (makeTerm1 (cons a b))
|
||||
|
||||
conditionalExpression :: Assignment
|
||||
|
||||
@ -52,12 +52,11 @@ resolvePHPName n = do
|
||||
where name = toName n
|
||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
include :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Modules location value
|
||||
include :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
|
||||
@ -292,25 +292,25 @@ unaryOperator = symbol UnaryOperator >>= \ location -> arithmetic location <|> b
|
||||
|
||||
binaryOperator :: Assignment
|
||||
binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm expression (term expression)
|
||||
[ (injectSum .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (injectSum .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (injectSum .) . Expression.Times <$ symbol AnonStar
|
||||
, (injectSum .) . Expression.Times <$ symbol AnonAt -- Matrix multiplication, TODO: May not want to assign to Expression.Times.
|
||||
, (injectSum .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (injectSum .) . Expression.FloorDivision <$ symbol AnonSlashSlash
|
||||
, (injectSum .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (injectSum .) . Expression.Power <$ symbol AnonStarStar
|
||||
, (injectSum .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (injectSum .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (injectSum .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (injectSum .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
[ (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (inject .) . Expression.Times <$ symbol AnonStar
|
||||
, (inject .) . Expression.Times <$ symbol AnonAt -- Matrix multiplication, TODO: May not want to assign to Expression.Times.
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.FloorDivision <$ symbol AnonSlashSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.Power <$ symbol AnonStarStar
|
||||
, (inject .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (inject .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
])
|
||||
|
||||
booleanOperator :: Assignment
|
||||
booleanOperator = makeTerm' <$> symbol BooleanOperator <*> children (infixTerm expression (term expression)
|
||||
[ (injectSum .) . Expression.And <$ symbol AnonAnd
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonOr
|
||||
[ (inject .) . Expression.And <$ symbol AnonAnd
|
||||
, (inject .) . Expression.Or <$ symbol AnonOr
|
||||
])
|
||||
|
||||
assignment' :: Assignment
|
||||
@ -333,7 +333,7 @@ assignment' = makeAssignment <$> symbol Assignment <*> children ((,,) <$> term
|
||||
where rvalue = expressionList <|> assignment' <|> yield
|
||||
makeAssignment loc (lhs, maybeType, rhs) = makeTerm loc (Statement.Assignment (maybeToList maybeType) lhs rhs)
|
||||
assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term
|
||||
assign c l r = injectSum (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
|
||||
yield :: Assignment
|
||||
yield = makeTerm <$> symbol Yield <*> (Statement.Yield <$> children (term ( expression <|> emptyTerm )))
|
||||
@ -348,7 +348,7 @@ dictionary :: Assignment
|
||||
dictionary = makeTerm <$> symbol Dictionary <*> children (Literal.Hash <$> manyTerm expression)
|
||||
|
||||
pair :: Assignment
|
||||
pair = makeTerm' <$> symbol Pair <*> children (infixTerm expression (term expression) [ (injectSum .) . Literal.KeyValue <$ symbol AnonColon ])
|
||||
pair = makeTerm' <$> symbol Pair <*> children (infixTerm expression (term expression) [ (inject .) . Literal.KeyValue <$ symbol AnonColon ])
|
||||
|
||||
list' :: Assignment
|
||||
list' = makeTerm <$> symbol List <*> children (Literal.Array <$> manyTerm expression)
|
||||
|
||||
@ -128,17 +128,18 @@ instance Evaluatable Import where
|
||||
|
||||
|
||||
-- Evaluate a qualified import
|
||||
evalQualifiedImport :: ( AbstractValue location a effects
|
||||
, Addressable location effects
|
||||
, Reducer.Reducer a (Cell location a)
|
||||
, Members '[ (State (Exports location a))
|
||||
, (State (Environment location a))
|
||||
, (State (Heap location (Cell location) a))
|
||||
, (Reader (Environment location a))
|
||||
, (Modules location a)
|
||||
evalQualifiedImport :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer.Reducer value (Cell location value)
|
||||
)
|
||||
=> Name -> ModulePath -> Evaluator location a effects a
|
||||
=> Name -> ModulePath -> Evaluator location value effects value
|
||||
evalQualifiedImport name path = letrec' name $ \addr -> do
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
|
||||
@ -341,7 +341,7 @@ args = (symbol ArgumentList <|> symbol ArgumentListWithParens) *> children (many
|
||||
methodCall :: Assignment
|
||||
methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|> send)
|
||||
where
|
||||
send = injectSum <$> ((regularCall <|> funcCall <|> scopeCall <|> dotCall) <*> optional block)
|
||||
send = inject <$> ((regularCall <|> funcCall <|> scopeCall <|> dotCall) <*> optional block)
|
||||
|
||||
funcCall = Ruby.Syntax.Send Nothing <$> selector <*> args
|
||||
regularCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> postContextualize heredoc expression) <*> selector) <*> args
|
||||
@ -349,11 +349,11 @@ methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|>
|
||||
dotCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args)
|
||||
|
||||
selector = Just <$> term methodSelector
|
||||
require = injectSum <$> (symbol Identifier *> do
|
||||
require = inject <$> (symbol Identifier *> do
|
||||
s <- source
|
||||
guard (s `elem` ["require", "require_relative"])
|
||||
Ruby.Syntax.Require (s == "require_relative") <$> nameExpression)
|
||||
load = injectSum <$> (symbol Identifier *> do
|
||||
load = inject <$> (symbol Identifier *> do
|
||||
s <- source
|
||||
guard (s == "load")
|
||||
Ruby.Syntax.Load <$> loadArgs)
|
||||
@ -407,7 +407,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Statement.As
|
||||
])
|
||||
where
|
||||
assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term
|
||||
assign c l r = injectSum (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
|
||||
lhs = makeTerm <$> symbol LeftAssignmentList <*> children (many expr) <|> expr
|
||||
rhs = makeTerm <$> symbol RightAssignmentList <*> children (many expr) <|> expr
|
||||
@ -442,30 +442,30 @@ unary = symbol Unary >>= \ location ->
|
||||
-- TODO: Distinguish `===` from `==` ?
|
||||
binary :: Assignment
|
||||
binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression
|
||||
[ (injectSum .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (injectSum .) . Expression.Minus <$ symbol AnonMinus'
|
||||
, (injectSum .) . Expression.Times <$ symbol AnonStar'
|
||||
, (injectSum .) . Expression.Power <$ symbol AnonStarStar
|
||||
, (injectSum .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (injectSum .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (injectSum .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (injectSum .) . Ruby.Syntax.LowAnd <$ symbol AnonAnd
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (injectSum .) . Ruby.Syntax.LowOr <$ symbol AnonOr
|
||||
, (injectSum .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (injectSum .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (injectSum .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (injectSum .) . invert Expression.Equal <$ symbol AnonBangEqual
|
||||
, (injectSum .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (injectSum .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (injectSum .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
|
||||
, (injectSum .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (injectSum .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (injectSum .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (injectSum .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (injectSum .) . Expression.Matches <$ symbol AnonEqualTilde
|
||||
, (injectSum .) . Expression.NotMatches <$ symbol AnonBangTilde
|
||||
[ (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus'
|
||||
, (inject .) . Expression.Times <$ symbol AnonStar'
|
||||
, (inject .) . Expression.Power <$ symbol AnonStarStar
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (inject .) . Ruby.Syntax.LowAnd <$ symbol AnonAnd
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (inject .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (inject .) . Ruby.Syntax.LowOr <$ symbol AnonOr
|
||||
, (inject .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (inject .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (inject .) . invert Expression.Equal <$ symbol AnonBangEqual
|
||||
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
|
||||
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
, (inject .) . Expression.Matches <$ symbol AnonEqualTilde
|
||||
, (inject .) . Expression.NotMatches <$ symbol AnonBangTilde
|
||||
])
|
||||
where invert cons a b = Expression.Not (makeTerm1 (cons a b))
|
||||
|
||||
|
||||
@ -248,7 +248,7 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
|
||||
, assign Expression.LShift <$ symbol AnonLAngleLAngleEqual
|
||||
, assign Expression.BOr <$ symbol AnonPipeEqual ])
|
||||
where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term
|
||||
assign c l r = injectSum (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r)))
|
||||
|
||||
|
||||
awaitExpression :: Assignment
|
||||
@ -645,9 +645,9 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr
|
||||
<|> makeTerm' <$> symbol Grammar.ImportStatement <*> children (requireImport <|> sideEffectImport)
|
||||
where
|
||||
-- `import foo = require "./foo"`
|
||||
requireImport = injectSum <$> (symbol Grammar.ImportRequireClause *> children (TypeScript.Syntax.QualifiedAliasedImport <$> term identifier <*> fromClause))
|
||||
requireImport = inject <$> (symbol Grammar.ImportRequireClause *> children (TypeScript.Syntax.QualifiedAliasedImport <$> term identifier <*> fromClause))
|
||||
-- `import "./foo"`
|
||||
sideEffectImport = injectSum <$> (TypeScript.Syntax.SideEffectImport <$> fromClause)
|
||||
sideEffectImport = inject <$> (TypeScript.Syntax.SideEffectImport <$> fromClause)
|
||||
-- `import { bar } from "./foo"`
|
||||
namedImport = (,) Nothing <$> (symbol Grammar.NamedImports *> children (many importSymbol))
|
||||
-- `import defaultMember from "./foo"`
|
||||
@ -832,27 +832,27 @@ tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term state
|
||||
|
||||
binaryExpression :: Assignment
|
||||
binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression)
|
||||
[ (injectSum .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (injectSum .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (injectSum .) . Expression.Times <$ symbol AnonStar
|
||||
, (injectSum .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (injectSum .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (injectSum .) . Expression.Member <$ symbol AnonIn
|
||||
, (injectSum .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (injectSum .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (injectSum .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (injectSum .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (injectSum .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (injectSum .) . Expression.InstanceOf <$ symbol AnonInstanceof
|
||||
, (injectSum .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (injectSum .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonBangEqualEqual)
|
||||
, (injectSum .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (injectSum .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (injectSum .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle
|
||||
, (injectSum .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (injectSum .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (injectSum .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (injectSum .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
[ (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (inject .) . Expression.Times <$ symbol AnonStar
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.Member <$ symbol AnonIn
|
||||
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
|
||||
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
|
||||
, (inject .) . Expression.Or <$ symbol AnonPipePipe
|
||||
, (inject .) . Expression.BOr <$ symbol AnonPipe
|
||||
, (inject .) . Expression.BXOr <$ symbol AnonCaret
|
||||
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
|
||||
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
|
||||
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonBangEqualEqual)
|
||||
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (inject .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle
|
||||
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
|
||||
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
|
||||
])
|
||||
where invert cons a b = Expression.Not (makeTerm1 (cons a b))
|
||||
|
||||
|
||||
@ -134,14 +134,15 @@ javascriptExtensions :: [String]
|
||||
javascriptExtensions = ["js"]
|
||||
|
||||
evalRequire :: ( AbstractValue location value effects
|
||||
, Addressable location effects
|
||||
, Members '[ Modules location value
|
||||
, Members '[ Allocator location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
] effects
|
||||
, Ord location
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> M.ModulePath
|
||||
|
||||
@ -21,7 +21,7 @@ import Data.Maybe as X
|
||||
import Data.Monoid (Alt (..))
|
||||
import Data.Sequence as X (Seq)
|
||||
import Data.Set as X (Set)
|
||||
import Data.Sum as X
|
||||
import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject)
|
||||
import Data.Text as X (Text)
|
||||
import Data.These as X
|
||||
import Data.Union as X
|
||||
|
||||
@ -60,6 +60,7 @@ import Data.ByteString.Builder
|
||||
import Data.Diff
|
||||
import qualified Data.Error as Error
|
||||
import Data.Record
|
||||
import Data.Sum
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term
|
||||
import Diffing.Algorithm (Diffable)
|
||||
@ -67,7 +68,7 @@ import Diffing.Interpreter
|
||||
import Parsing.CMark
|
||||
import Parsing.Parser
|
||||
import Parsing.TreeSitter
|
||||
import Prologue hiding (MonadError (..))
|
||||
import Prologue hiding (MonadError (..), project)
|
||||
import Semantic.Distribute
|
||||
import qualified Semantic.IO as IO
|
||||
import Semantic.Resolution
|
||||
@ -217,5 +218,5 @@ runParser blob@Blob{..} parser = case parser of
|
||||
languageTag = maybe [] (pure . (,) ("language" :: String) . show) blobLanguage
|
||||
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) (Record Assignment.Location) -> [Error.Error String]
|
||||
errors = cata $ \ (In a syntax) -> case syntax of
|
||||
_ | Just err@Syntax.Error{} <- projectSum syntax -> [Syntax.unError (getField a) err]
|
||||
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError (getField a) err]
|
||||
_ -> fold syntax
|
||||
|
||||
@ -16,11 +16,12 @@ import Data.Blob
|
||||
import Data.Project
|
||||
import Data.Functor.Foldable
|
||||
import qualified Data.Language as Language
|
||||
import Data.Sum (weaken)
|
||||
import Data.Term
|
||||
import qualified GHC.TypeLits as TypeLevel
|
||||
import Language.Preluded
|
||||
import Parsing.Parser
|
||||
import Prologue
|
||||
import Prologue hiding (weaken)
|
||||
import Semantic.Graph
|
||||
import Semantic.IO as IO
|
||||
import Semantic.Task
|
||||
@ -99,10 +100,10 @@ blob = runTask . readBlob . file
|
||||
|
||||
|
||||
injectConst :: a -> SomeExc (Sum '[Const a])
|
||||
injectConst = SomeExc . injectSum . Const
|
||||
injectConst = SomeExc . inject . Const
|
||||
|
||||
mergeExcs :: Either (SomeExc (Sum excs)) (Either (SomeExc exc) result) -> Either (SomeExc (Sum (exc ': excs))) result
|
||||
mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weakenSum sum))) (either (\ (SomeExc exc) -> Left (SomeExc (injectSum exc))) Right)
|
||||
mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weaken sum))) (either (\ (SomeExc exc) -> Left (SomeExc (inject exc))) Right)
|
||||
|
||||
reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . first injectConst
|
||||
reassociateTypes = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . first injectConst
|
||||
|
||||
@ -31,7 +31,7 @@ spec = parallel $ do
|
||||
|
||||
it "evaluates load with wrapper" $ do
|
||||
((res, state), _) <- evaluate "load-wrap.rb"
|
||||
res `shouldBe` Left (SomeExc (injectSum @(EnvironmentError (Value Precise)) (FreeVariable "foo")))
|
||||
res `shouldBe` Left (SomeExc (inject @(EnvironmentError (Value Precise)) (FreeVariable "foo")))
|
||||
Env.names (environment state) `shouldContain` [ "Object" ]
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
|
||||
@ -32,7 +32,7 @@ spec = parallel $ do
|
||||
|
||||
it "fails exporting symbols not defined in the module" $ do
|
||||
((res, _), _) <- evaluate "bad-export.ts"
|
||||
res `shouldBe` Left (SomeExc (injectSum @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip"))))
|
||||
res `shouldBe` Left (SomeExc (inject @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip"))))
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
((res, _), _) <- evaluate "early-return.ts"
|
||||
|
||||
@ -37,6 +37,7 @@ evaluate
|
||||
. Value.runValueError
|
||||
. runEnvironmentError
|
||||
. runAddressError
|
||||
. runAllocator
|
||||
. runReturn
|
||||
. runLoopControl
|
||||
. fmap fst
|
||||
@ -46,5 +47,5 @@ evaluate
|
||||
newtype Gotos effects = Gotos { getGotos :: GotoTable (State (Gotos effects) ': effects) (Value Precise) }
|
||||
|
||||
reassociate :: Either Prelude.String (Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result))) -> Either (SomeExc (Sum '[Const Prelude.String, exc1, exc2, exc3])) result
|
||||
reassociate (Left s) = Left (SomeExc (injectSum (Const s)))
|
||||
reassociate (Left s) = Left (SomeExc (inject (Const s)))
|
||||
reassociate (Right (Right (Right (Right a)))) = Right a
|
||||
|
||||
@ -213,10 +213,10 @@ instance (Listable a, Listable b) => Listable (Patch a b) where
|
||||
|
||||
|
||||
instance (Listable1 f, Listable1 (Sum (g ': fs))) => Listable1 (Sum (f ': g ': fs)) where
|
||||
liftTiers tiers = (injectSum `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)) \/ (weakenSum `mapT` ((liftTiers :: [Tier a] -> [Tier (Sum (g ': fs) a)]) tiers))
|
||||
liftTiers tiers = (inject `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)) \/ (weaken `mapT` ((liftTiers :: [Tier a] -> [Tier (Sum (g ': fs) a)]) tiers))
|
||||
|
||||
instance Listable1 f => Listable1 (Sum '[f]) where
|
||||
liftTiers tiers = injectSum `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)
|
||||
liftTiers tiers = inject `mapT` ((liftTiers :: [Tier a] -> [Tier (f a)]) tiers)
|
||||
|
||||
instance (Listable1 (Sum fs), Listable a) => Listable (Sum fs a) where
|
||||
tiers = tiers1
|
||||
|
||||
@ -29,12 +29,12 @@ spec = parallel $ do
|
||||
prop "produces correct diffs" $
|
||||
\ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax (Record '[])])
|
||||
tbs = decorate <$> (bs :: [Term ListableSyntax (Record '[])])
|
||||
wrap = termIn Nil . injectSum
|
||||
diff = merge (Nil, Nil) (injectSum (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
|
||||
wrap = termIn Nil . inject
|
||||
diff = merge (Nil, Nil) (inject (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
|
||||
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs)))
|
||||
|
||||
it "produces unbiased insertions within branches" $
|
||||
let (a, b) = (decorate (termIn Nil (injectSum [ termIn Nil (injectSum (Syntax.Identifier "a")) ])), decorate (termIn Nil (injectSum [ termIn Nil (injectSum (Syntax.Identifier "b")) ]))) in
|
||||
let (a, b) = (decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "a")) ])), decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "b")) ]))) in
|
||||
fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
|
||||
|
||||
where decorate = defaultFeatureVectorDecorator
|
||||
|
||||
@ -17,8 +17,8 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "diffTerms" $ do
|
||||
it "returns a replacement when comparing two unicode equivalent terms" $
|
||||
let termA = termIn Nil (injectSum (Syntax.Identifier "t\776"))
|
||||
termB = termIn Nil (injectSum (Syntax.Identifier "\7831")) in
|
||||
let termA = termIn Nil (inject (Syntax.Identifier "t\776"))
|
||||
termB = termIn Nil (inject (Syntax.Identifier "\7831")) in
|
||||
diffTerms termA termB `shouldBe` replacing termA (termB :: Term ListableSyntax (Record '[]))
|
||||
|
||||
prop "produces correct diffs" $
|
||||
@ -30,24 +30,24 @@ spec = parallel $ do
|
||||
length (diffPatches diff) `shouldBe` 0
|
||||
|
||||
it "produces unbiased insertions within branches" $
|
||||
let term s = termIn Nil (injectSum [ termIn Nil (injectSum (Syntax.Identifier s)) ]) :: Term ListableSyntax (Record '[])
|
||||
wrap = termIn Nil . injectSum in
|
||||
diffTerms (wrap [ term "b" ]) (wrap [ term "a", term "b" ]) `shouldBe` merge (Nil, Nil) (injectSum [ inserting (term "a"), merging (term "b") ])
|
||||
let term s = termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier s)) ]) :: Term ListableSyntax (Record '[])
|
||||
wrap = termIn Nil . inject in
|
||||
diffTerms (wrap [ term "b" ]) (wrap [ term "a", term "b" ]) `shouldBe` merge (Nil, Nil) (inject [ inserting (term "a"), merging (term "b") ])
|
||||
|
||||
prop "compares nodes against context" $
|
||||
\ a b -> diffTerms a (termIn Nil (injectSum (Syntax.Context (pure b) a))) `shouldBe` insertF (In Nil (injectSum (Syntax.Context (pure (inserting b)) (merging (a :: Term ListableSyntax (Record '[]))))))
|
||||
\ a b -> diffTerms a (termIn Nil (inject (Syntax.Context (pure b) a))) `shouldBe` insertF (In Nil (inject (Syntax.Context (pure (inserting b)) (merging (a :: Term ListableSyntax (Record '[]))))))
|
||||
|
||||
prop "diffs forward permutations as changes" $
|
||||
\ a -> let wrap = termIn Nil . injectSum
|
||||
\ a -> let wrap = termIn Nil . inject
|
||||
b = wrap [a]
|
||||
c = wrap [a, b] in
|
||||
diffTerms (wrap [a, b, c]) (wrap [c, a, b :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (injectSum [ inserting c, merging a, merging b, deleting c ])
|
||||
diffTerms (wrap [a, b, c]) (wrap [c, a, b :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (inject [ inserting c, merging a, merging b, deleting c ])
|
||||
|
||||
prop "diffs backward permutations as changes" $
|
||||
\ a -> let wrap = termIn Nil . injectSum
|
||||
\ a -> let wrap = termIn Nil . inject
|
||||
b = wrap [a]
|
||||
c = wrap [a, b] in
|
||||
diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (injectSum [ deleting a, merging b, merging c, inserting a ])
|
||||
diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (inject [ deleting a, merging b, merging c, inserting a ])
|
||||
|
||||
describe "diffTermPair" $ do
|
||||
prop "produces an Insert when the first term is missing" $ do
|
||||
|
||||
@ -44,7 +44,7 @@ spec = parallel $ do
|
||||
|
||||
prop "produces changed entries for relevant nodes containing irrelevant patches" $
|
||||
\ diff -> do
|
||||
let diff' = merge (True, True) (injectSum [bimap (const False) (const False) (diff :: Diff ListableSyntax Bool Bool)])
|
||||
let diff' = merge (True, True) (inject [bimap (const False) (const False) (diff :: Diff ListableSyntax Bool Bool)])
|
||||
let toc = tableOfContentsBy (\ (n `In` _) -> if n then Just n else Nothing) diff'
|
||||
toc `shouldBe` if null (diffPatches diff') then []
|
||||
else [Changed True]
|
||||
@ -173,17 +173,17 @@ numTocSummaries diff = length $ filter isValidSummary (diffTOC diff)
|
||||
|
||||
-- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff.
|
||||
programWithChange :: Term' -> Diff'
|
||||
programWithChange body = merge (programInfo, programInfo) (injectSum [ function' ])
|
||||
programWithChange body = merge (programInfo, programInfo) (inject [ function' ])
|
||||
where
|
||||
function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (injectSum (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (injectSum [ inserting body ]))))
|
||||
name' = let info = Nothing :. emptyInfo in merge (info, info) (injectSum (Syntax.Identifier (name "foo")))
|
||||
function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [ inserting body ]))))
|
||||
name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo")))
|
||||
|
||||
-- Return a diff where term is inserted in the program, below a function found on both sides of the diff.
|
||||
programWithChangeOutsideFunction :: Term' -> Diff'
|
||||
programWithChangeOutsideFunction term = merge (programInfo, programInfo) (injectSum [ function', term' ])
|
||||
programWithChangeOutsideFunction term = merge (programInfo, programInfo) (inject [ function', term' ])
|
||||
where
|
||||
function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (injectSum (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (injectSum []))))
|
||||
name' = let info = Nothing :. emptyInfo in merge (info, info) (injectSum (Syntax.Identifier (name "foo")))
|
||||
function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject []))))
|
||||
name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo")))
|
||||
term' = inserting term
|
||||
|
||||
programWithInsert :: Text -> Term' -> Diff'
|
||||
@ -196,12 +196,12 @@ programWithReplace :: Text -> Term' -> Diff'
|
||||
programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body)
|
||||
|
||||
programOf :: Diff' -> Diff'
|
||||
programOf diff = merge (programInfo, programInfo) (injectSum [ diff ])
|
||||
programOf diff = merge (programInfo, programInfo) (inject [ diff ])
|
||||
|
||||
functionOf :: Text -> Term' -> Term'
|
||||
functionOf n body = termIn (Just (FunctionDeclaration n mempty Nothing) :. emptyInfo) (injectSum (Declaration.Function [] name' [] (termIn (Nothing :. emptyInfo) (injectSum [body]))))
|
||||
functionOf n body = termIn (Just (FunctionDeclaration n mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (termIn (Nothing :. emptyInfo) (inject [body]))))
|
||||
where
|
||||
name' = termIn (Nothing :. emptyInfo) (injectSum (Syntax.Identifier (name (encodeUtf8 n))))
|
||||
name' = termIn (Nothing :. emptyInfo) (inject (Syntax.Identifier (name (encodeUtf8 n))))
|
||||
|
||||
programInfo :: Record '[Maybe Declaration, Range, Span]
|
||||
programInfo = Nothing :. emptyInfo
|
||||
@ -212,15 +212,15 @@ emptyInfo = Range 0 0 :. Span (Pos 0 0) (Pos 0 0) :. Nil
|
||||
-- Filter tiers for terms that we consider "meaniningful" in TOC summaries.
|
||||
isMeaningfulTerm :: Term ListableSyntax a -> Bool
|
||||
isMeaningfulTerm a
|
||||
| Just (_:_) <- projectSum (termOut a) = False
|
||||
| Just [] <- projectSum (termOut a) = False
|
||||
| Just (_:_) <- project (termOut a) = False
|
||||
| Just [] <- project (termOut a) = False
|
||||
| otherwise = True
|
||||
|
||||
-- Filter tiers for terms if the Syntax is a Method or a Function.
|
||||
isMethodOrFunction :: Term' -> Bool
|
||||
isMethodOrFunction a
|
||||
| Just Declaration.Method{} <- projectSum (termOut a) = True
|
||||
| Just Declaration.Function{} <- projectSum (termOut a) = True
|
||||
| Just Declaration.Method{} <- project (termOut a) = True
|
||||
| Just Declaration.Function{} <- project (termOut a) = True
|
||||
| any isJust (foldMap ((:[]) . rhead) a) = True
|
||||
| otherwise = False
|
||||
|
||||
@ -228,7 +228,7 @@ blobsForPaths :: Both FilePath -> IO BlobPair
|
||||
blobsForPaths = readFilePair . fmap ("test/fixtures" </>)
|
||||
|
||||
blankDiff :: Diff'
|
||||
blankDiff = merge (arrayInfo, arrayInfo) (injectSum [ inserting (termIn literalInfo (injectSum (Syntax.Identifier (name "\"a\"")))) ])
|
||||
blankDiff = merge (arrayInfo, arrayInfo) (inject [ inserting (termIn literalInfo (inject (Syntax.Identifier (name "\"a\"")))) ])
|
||||
where
|
||||
arrayInfo = Nothing :. Range 0 3 :. Span (Pos 1 1) (Pos 1 5) :. Nil
|
||||
literalInfo = Nothing :. Range 1 2 :. Span (Pos 1 2) (Pos 1 4) :. Nil
|
||||
|
||||
2
vendor/fastsum
vendored
2
vendor/fastsum
vendored
@ -1 +1 @@
|
||||
Subproject commit 4a8f1359233bbb2bea7a0eee478c28d0184ebe6d
|
||||
Subproject commit 2310af6de3d3c337d671cdf9fe3e007990fdb1e4
|
||||
Loading…
Reference in New Issue
Block a user