1
1
mirror of https://github.com/github/semantic.git synced 2024-12-01 00:33:59 +03:00

Merge branch 'master' into allocator-effect

This commit is contained in:
Rob Rix 2018-05-16 18:33:00 -04:00 committed by GitHub
commit 19bc0ab637
86 changed files with 1062 additions and 930 deletions

View File

@ -275,6 +275,7 @@ test-suite test
, filepath
, free
, Glob
, hashable
, haskell-tree-sitter
, hspec >= 2.4.1
, hspec-core

View File

@ -7,6 +7,7 @@ module Analysis.Abstract.Caching
import Control.Abstract
import Data.Abstract.Cache
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Semilattice.Lower
import Prologue
@ -35,8 +36,8 @@ lookupCache configuration = cacheLookup configuration <$> get
cachingConfiguration :: (Cacheable term location (Cell location) value, Members '[State (Cache term location (Cell location) value), State (Heap location (Cell location) value)] effects)
=> Configuration term location (Cell location) value
-> Set (Cached location (Cell location) value)
-> TermEvaluator term location value effects value
-> TermEvaluator term location value effects value
-> TermEvaluator term location value effects (ValueRef value)
-> TermEvaluator term location value effects (ValueRef value)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- Cached <$> action <*> TermEvaluator getHeap
@ -66,8 +67,8 @@ cachingTerms :: ( Cacheable term location (Cell location) value
, State (Heap location (Cell location) value)
] effects
)
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
@ -77,11 +78,17 @@ cachingTerms recur term = do
pairs <- consultOracle c
cachingConfiguration c pairs (recur term)
convergingModules :: ( Cacheable term location (Cell location) value
convergingModules :: ( AbstractValue location value effects
, Addressable location effects
, Cacheable term location (Cell location) value
, Members '[ Fresh
, NonDet
, Reader (Cache term location (Cell location) value)
, Reader (Environment location value)
, Reader (Live location value)
, Resumable (AddressError location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Cache term location (Cell location) value)
, State (Environment location value)
, State (Heap location (Cell location) value)
@ -103,7 +110,7 @@ convergingModules recur m = do
-- would never complete). We dont need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gatherM (const ()) (recur m)))
maybe empty scatter (cacheLookup c cache)
TermEvaluator (value =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
-- | Iterate a monadic action starting from some initial seed until the results converge.
@ -122,7 +129,7 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects value
scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects (ValueRef value)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)

View File

@ -1,16 +1,11 @@
{-# LANGUAGE DataKinds, TypeOperators #-}
module Analysis.Decorator
( decoratorWithAlgebra
, constructorNameAndConstantFields
) where
import Prologue
import Data.Aeson
import Data.ByteString.Char8 (ByteString, pack)
import Data.JSON.Fields
import Data.Record
import Data.Term
import Data.Text.Encoding (decodeUtf8)
import Prologue
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: Functor syntax
@ -18,17 +13,3 @@ decoratorWithAlgebra :: Functor syntax
-> Term syntax (Record fs) -- ^ A term to decorate with values produced by the R-algebra.
-> Term syntax (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . termAnnotation)) c) :. a) (fmap snd f)
newtype Identifier = Identifier ByteString
deriving (Eq, Show)
instance ToJSONFields Identifier where
toJSONFields (Identifier i) = [ "identifier" .= decodeUtf8 i ]
-- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
--
-- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
-- constant fields will be included and parametric fields will not be.
constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")

View File

@ -1,6 +1,7 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Control.Abstract.Evaluator
( Evaluator(..)
, ValueRef(..)
-- * Effects
, Return(..)
, earlyReturn
@ -29,6 +30,7 @@ import Control.Monad.Effect.Reader
import Control.Monad.Effect.Resumable
import Control.Monad.Effect.State
import Control.Monad.Effect.Trace
import Data.Abstract.FreeVariables
import Prologue
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
@ -41,6 +43,16 @@ newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff eff
deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members)
data ValueRef value where
-- Represents a value:
Rval :: value -> ValueRef value
-- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed:
LvalLocal :: Name -> ValueRef value
-- Represents an object member:
LvalMember :: value -> Name -> ValueRef value
deriving (Eq, Ord, Show)
-- Effects

View File

@ -139,8 +139,8 @@ class Show value => AbstractValue location value effects where
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value))
-- | Build a closure (a binder like a lambda or method definition).
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
-> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
-> Evaluator location value effects value
-- | Evaluate an application (like a function call).

View File

@ -1,6 +1,7 @@
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
module Data.Abstract.Cache where
import Control.Abstract.Evaluator
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Map.Monoidal as Monoidal
@ -12,7 +13,7 @@ newtype Cache term location cell value = Cache { unCache :: Monoidal.Map (Config
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term location cell value, Cached location cell value), Semigroup)
data Cached location cell value = Cached
{ cachedValue :: value
{ cachedValue :: ValueRef value
, cachedHeap :: Heap location cell value
}
deriving (Eq, Ord, Show)

View File

@ -75,7 +75,7 @@ mergeNewer (Environment a) (Environment b) =
-- | Extract an association list of bindings from an 'Environment'.
--
-- >>> pairs shadowed
-- [(Name {unName = "foo"},Precise 1)]
-- [("foo",Precise 1)]
pairs :: Environment location value -> [(Name, Address location value)]
pairs = Map.toList . fold . unEnvironment

View File

@ -8,6 +8,8 @@ module Data.Abstract.Evaluatable
, EvalError(..)
, runEvalError
, runEvalErrorWith
, value
, subtermValue
, evaluateInScopedEnv
, evaluatePackageWith
, throwEvalError
@ -44,8 +46,8 @@ class Evaluatable constr where
eval :: ( EvaluatableConstraints location term value effects
, Member Fail effects
)
=> SubtermAlgebra constr term (Evaluator location value effects value)
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects value)
=> SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
type EvaluatableConstraints location term value effects =
@ -126,7 +128,7 @@ throwEvalError = throwResumable
data Unspecialized a b where
Unspecialized :: Prelude.String -> Unspecialized value value
Unspecialized :: Prelude.String -> Unspecialized value (ValueRef value)
instance Eq1 (Unspecialized a) where
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
@ -136,13 +138,44 @@ deriving instance Show (Unspecialized a b)
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)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
)
=> ValueRef value
-> Evaluator location value effects value
value (LvalLocal var) = variable var
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)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> Evaluator location value effects value
subtermValue = value <=< subtermRef
runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
runUnspecialized = runResumable
runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
runUnspecializedWith = runResumableWith
-- Instances
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
@ -160,7 +193,7 @@ instance Evaluatable s => Evaluatable (TermF s a) where
--- 3. Only the last statements return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statements result instead of 'unit' for non-empty lists.
eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
@ -209,7 +242,7 @@ evaluatePackageWith :: forall location term value inner inner' 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 value) -> SubtermAlgebra (Base term) 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)))
-> Package term
-> TermEvaluator term location value outer [value]
evaluatePackageWith analyzeModule analyzeTerm package
@ -221,11 +254,13 @@ evaluatePackageWith analyzeModule analyzeTerm package
. withPrelude (packagePrelude (packageBody package))
. raiseHandler (runModules (runTermEvaluator . evalModule))
$ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package)))
where evalModule m
where
evalModule m
= pairValueWithEnv
. runInModule (moduleInfo m)
. analyzeModule (subtermValue . moduleBody)
$ fmap (Subterm <*> foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator)))) m
. analyzeModule (subtermRef . moduleBody)
$ evalTerm <$> m
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
runInModule info
= runReader info

View File

@ -9,7 +9,7 @@ import Prologue
-- | The type of variable names.
newtype Name = Name { unName :: ByteString }
deriving (Eq, Ord, Show)
deriving (Eq, Hashable, Ord)
name :: ByteString -> Name
name = Name
@ -17,6 +17,8 @@ name = Name
instance IsString Name where
fromString = Name . BC.pack
instance Show Name where showsPrec d (Name str) = showsPrec d str
-- | Types which can contain unbound variables.
class FreeVariables term where

View File

@ -9,6 +9,7 @@ module Data.Abstract.Type
import Control.Abstract
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Semigroup.Foldable (foldMap1)
import Data.Semigroup.Reducer (Reducer)
import Prologue hiding (TypeError)
@ -105,6 +106,9 @@ instance AbstractHole Type where
instance ( Members '[ Allocator location Type
, Fresh
, NonDet
, Reader (Environment location Type)
, Resumable (AddressError location Type)
, Resumable (EvalError Type)
, Resumable TypeError
, Return Type
, State (Environment location Type)

View File

@ -48,7 +48,7 @@ type OpenFAlgebra f a = forall b . (b -> a) -> f b -> a
type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a }
data Subterm t a = Subterm { subterm :: !t, subtermRef :: !a }
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance Bifunctor Subterm where

View File

@ -102,7 +102,7 @@ infixContext context left right operators = uncurry (&) <$> postContextualizeThr
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
newtype Identifier a = Identifier Name
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Identifier where liftEq = genericLiftEq
instance Ord1 Identifier where liftCompare = genericLiftCompare
@ -112,7 +112,7 @@ instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Identifier
instance Evaluatable Identifier where
eval (Identifier name) = variable name
eval (Identifier name) = pure (LvalLocal name)
instance FreeVariables1 Identifier where
liftFreeVariables _ (Identifier x) = pure x
@ -121,7 +121,7 @@ instance Declarations1 Identifier where
liftDeclaredName _ (Identifier x) = pure x
newtype Program a = Program [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Program where liftEq = genericLiftEq
instance Ord1 Program where liftCompare = genericLiftCompare
@ -134,7 +134,7 @@ instance Evaluatable Program where
-- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
@ -149,7 +149,7 @@ instance Evaluatable AccessibilityModifier
--
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
data Empty a = Empty
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Empty
@ -158,12 +158,12 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Evaluatable Empty where
eval _ = unit
eval _ = Rval <$> unit
-- | Syntax representing a parsing or assignment error.
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Error where liftEq = genericLiftEq
instance Ord1 Error where liftCompare = genericLiftCompare
@ -199,6 +199,9 @@ instance ToJSON ErrorStack where
, "endColumn" .= srcLocEndCol
]
instance Hashable ErrorStack where
hashWithSalt = hashUsing (map (second ((,,,,,,) <$> srcLocPackage <*> srcLocModule <*> srcLocFile <*> srcLocStartLine <*> srcLocStartCol <*> srcLocEndLine <*> srcLocEndCol)) . unErrorStack)
instance Ord ErrorStack where
compare = liftCompare (liftCompare compareSrcLoc) `on` unErrorStack
where compareSrcLoc s1 s2 = mconcat
@ -222,9 +225,11 @@ instance Diffable Context where
equivalentBySubterm = Just . contextSubject
instance Hashable1 Context where liftHashWithSalt = foldl
instance Eq1 Context where liftEq = genericLiftEq
instance Ord1 Context where liftCompare = genericLiftCompare
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Context where
eval Context{..} = subtermValue contextSubject
eval Context{..} = subtermRef contextSubject

View File

@ -9,7 +9,7 @@ import Diffing.Algorithm
-- | An unnested comment (line or block).
newtype Comment a = Comment { commentContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comment where liftEq = genericLiftEq
instance Ord1 Comment where liftCompare = genericLiftCompare
@ -19,7 +19,7 @@ instance ToJSONFields1 Comment where
toJSONFields1 f@Comment{..} = withChildren f ["contents" .= unpack commentContent ]
instance Evaluatable Comment where
eval _ = unit
eval _ = Rval <$> unit
-- TODO: nested comment types
-- TODO: documentation comment types

View File

@ -9,7 +9,7 @@ import Diffing.Algorithm
import Prologue
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Diffable Function where
equivalentBySubterm = Just . functionName
@ -28,7 +28,7 @@ instance Evaluatable Function where
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
modifyEnv (Env.insert name addr)
pure v
pure (Rval v)
where paramNames = foldMap (freeVariables . subterm)
instance Declarations a => Declarations (Function a) where
@ -36,7 +36,7 @@ instance Declarations a => Declarations (Function a) where
data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Method where liftEq = genericLiftEq
instance Ord1 Method where liftCompare = genericLiftCompare
@ -54,13 +54,13 @@ instance Evaluatable Method where
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
modifyEnv (Env.insert name addr)
pure v
pure (Rval v)
where paramNames = foldMap (freeVariables . subterm)
-- | A method signature in TypeScript or a method spec in Go.
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 MethodSignature where liftEq = genericLiftEq
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
@ -73,7 +73,7 @@ instance Evaluatable MethodSignature
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 RequiredParameter where liftEq = genericLiftEq
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@ -86,7 +86,7 @@ instance Evaluatable RequiredParameter
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 OptionalParameter where liftEq = genericLiftEq
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@ -103,7 +103,7 @@ instance Evaluatable OptionalParameter
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
@ -112,8 +112,8 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 VariableDeclaration
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = unit
eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
eval (VariableDeclaration []) = Rval <$> unit
eval (VariableDeclaration decs) = Rval <$> (multiple =<< traverse subtermValue decs)
instance Declarations a => Declarations (VariableDeclaration a) where
declaredName (VariableDeclaration vars) = case vars of
@ -123,7 +123,7 @@ instance Declarations a => Declarations (VariableDeclaration a) where
-- | A TypeScript/Java style interface declaration to implement.
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@ -140,7 +140,7 @@ 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 }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
@ -153,7 +153,7 @@ instance Evaluatable PublicFieldDefinition
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Variable where liftEq = genericLiftEq
instance Ord1 Variable where liftCompare = genericLiftCompare
@ -165,7 +165,7 @@ instance ToJSONFields1 Variable
instance Evaluatable Variable
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Declarations a => Declarations (Class a) where
declaredName (Class _ name _ _) = declaredName name
@ -187,11 +187,11 @@ instance Evaluatable Class where
void $ subtermValue classBody
classEnv <- Env.head <$> getEnv
klass name supers classEnv
v <$ modifyEnv (Env.insert name addr)
Rval <$> (v <$ modifyEnv (Env.insert name addr))
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Decorator where liftEq = genericLiftEq
instance Ord1 Decorator where liftCompare = genericLiftCompare
@ -207,7 +207,7 @@ instance Evaluatable Decorator
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
@ -221,7 +221,7 @@ instance Evaluatable Data.Syntax.Declaration.Datatype
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
@ -235,7 +235,7 @@ instance Evaluatable Data.Syntax.Declaration.Constructor
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comprehension where liftEq = genericLiftEq
instance Ord1 Comprehension where liftCompare = genericLiftCompare
@ -249,7 +249,7 @@ instance Evaluatable Comprehension
-- | A declared type (e.g. `a []int` in Go).
data Type a = Type { typeName :: !a, typeKind :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Type where liftEq = genericLiftEq
instance Ord1 Type where liftCompare = genericLiftCompare
@ -263,7 +263,7 @@ instance Evaluatable Type
-- | Type alias declarations in Javascript/Haskell, etc.
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeAlias where liftEq = genericLiftEq
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
@ -278,7 +278,7 @@ instance Evaluatable TypeAlias where
v <- subtermValue typeAliasKind
addr <- lookupOrAlloc name
assign addr v
modifyEnv (Env.insert name addr) $> v
Rval <$> (modifyEnv (Env.insert name addr) $> v)
instance Declarations a => Declarations (TypeAlias a) where
declaredName TypeAlias{..} = declaredName typeAliasIdentifier

View File

@ -11,7 +11,7 @@ import Prologue
-- A file directive like the Ruby constant `__FILE__`.
data File a = File
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 File where liftEq = genericLiftEq
instance Ord1 File where liftCompare = genericLiftCompare
@ -20,12 +20,12 @@ instance Show1 File where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 File
instance Evaluatable File where
eval File = currentModule >>= string . BC.pack . modulePath
eval File = Rval <$> (currentModule >>= string . BC.pack . modulePath)
-- A line directive like the Ruby constant `__LINE__`.
data Line a = Line
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Line where liftEq = genericLiftEq
instance Ord1 Line where liftCompare = genericLiftCompare
@ -34,4 +34,4 @@ instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Line
instance Evaluatable Line where
eval Line = currentSpan >>= integer . fromIntegral . posLine . spanStart
eval Line = Rval <$> (currentSpan >>= integer . fromIntegral . posLine . spanStart)

View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
module Data.Syntax.Expression where
import Data.Abstract.Evaluatable
@ -10,7 +10,7 @@ import Prologue hiding (index)
-- | 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 }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Call where liftEq = genericLiftEq
instance Ord1 Call where liftCompare = genericLiftCompare
@ -21,7 +21,7 @@ instance ToJSONFields1 Call
instance Evaluatable Call where
eval Call{..} = do
op <- subtermValue callFunction
call op (map subtermValue callParams)
Rval <$> call op (map subtermValue callParams)
data Comparison a
= LessThan !a !a
@ -30,7 +30,7 @@ data Comparison a
| GreaterThanEqual !a !a
| Equal !a !a
| Comparison !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comparison where liftEq = genericLiftEq
instance Ord1 Comparison where liftCompare = genericLiftCompare
@ -39,7 +39,7 @@ instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Comparison
instance Evaluatable Comparison where
eval = traverse subtermValue >=> go where
eval t = Rval <$> (traverse subtermValue t >>= go) where
go x = case x of
(LessThan a b) -> liftComparison (Concrete (<)) a b
(LessThanEqual a b) -> liftComparison (Concrete (<=)) a b
@ -58,7 +58,7 @@ data Arithmetic a
| Modulo !a !a
| Power !a !a
| Negate !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Arithmetic where liftEq = genericLiftEq
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
@ -67,7 +67,7 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Arithmetic
instance Evaluatable Arithmetic where
eval = traverse subtermValue >=> go where
eval t = Rval <$> (traverse subtermValue t >>= go) where
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
@ -81,7 +81,7 @@ instance Evaluatable Arithmetic where
data Match a
= Matches !a !a
| NotMatches !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
@ -98,7 +98,7 @@ data Boolean a
| And !a !a
| Not !a
| XOr !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Boolean where liftEq = genericLiftEq
instance Ord1 Boolean where liftCompare = genericLiftCompare
@ -108,7 +108,7 @@ instance ToJSONFields1 Boolean
instance Evaluatable Boolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval = go . fmap subtermValue where
eval t = Rval <$> go (fmap subtermValue t) where
go (And a b) = do
cond <- a
ifthenelse cond b (pure cond)
@ -120,7 +120,7 @@ instance Evaluatable Boolean where
-- | Javascript delete operator
newtype Delete a = Delete a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Delete where liftEq = genericLiftEq
instance Ord1 Delete where liftCompare = genericLiftCompare
@ -134,7 +134,7 @@ instance Evaluatable Delete
-- | A sequence expression such as Javascript or C's comma operator.
data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 SequenceExpression where liftEq = genericLiftEq
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
@ -148,7 +148,7 @@ instance Evaluatable SequenceExpression
-- | Javascript void operator
newtype Void a = Void a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Void where liftEq = genericLiftEq
instance Ord1 Void where liftCompare = genericLiftCompare
@ -162,7 +162,7 @@ instance Evaluatable Void
-- | Javascript typeof operator
newtype Typeof a = Typeof a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Typeof where liftEq = genericLiftEq
instance Ord1 Typeof where liftCompare = genericLiftCompare
@ -183,7 +183,7 @@ data Bitwise a
| RShift !a !a
| UnsignedRShift !a !a
| Complement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Bitwise where liftEq = genericLiftEq
instance Ord1 Bitwise where liftCompare = genericLiftCompare
@ -192,7 +192,7 @@ instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Bitwise
instance Evaluatable Bitwise where
eval = traverse subtermValue >=> go where
eval t = Rval <$> (traverse subtermValue t >>= go) where
genLShift x y = shiftL x (fromIntegral y)
genRShift x y = shiftR x (fromIntegral y)
go x = case x of
@ -207,7 +207,7 @@ instance Evaluatable Bitwise where
-- | Member Access (e.g. a.b)
data MemberAccess a
= MemberAccess !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 MemberAccess where liftEq = genericLiftEq
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
@ -216,13 +216,18 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 MemberAccess
instance Evaluatable MemberAccess where
eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem acc
eval (MemberAccess obj prop) = do
obj <- subtermValue obj
prop <- subtermRef prop
case prop of
LvalLocal propName -> pure (LvalMember obj propName)
_ -> raiseEff (Prologue.fail "Non-Identifier as right hand side of MemberAccess!")
-- | Subscript (e.g a[1])
data Subscript a
= Subscript !a ![a]
| Member !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Subscript where liftEq = genericLiftEq
instance Ord1 Subscript where liftCompare = genericLiftCompare
@ -231,15 +236,16 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Subscript
-- TODO: Finish Eval instance for Subscript
-- TODO return a special LvalSubscript instance here
instance Evaluatable Subscript where
eval (Subscript l [r]) = join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Member _ _) = throwResumable (Unspecialized "Eval unspecialized for member access")
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Enumeration where liftEq = genericLiftEq
instance Ord1 Enumeration where liftCompare = genericLiftCompare
@ -253,7 +259,7 @@ instance Evaluatable Enumeration
-- | InstanceOf (e.g. a instanceof b in JavaScript
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InstanceOf where liftEq = genericLiftEq
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
@ -267,7 +273,7 @@ instance Evaluatable InstanceOf
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
newtype ScopeResolution a = ScopeResolution [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeResolution where liftEq = genericLiftEq
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
@ -281,7 +287,7 @@ instance Evaluatable ScopeResolution
-- | A non-null expression such as Typescript or Swift's ! expression.
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NonNullExpression where liftEq = genericLiftEq
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
@ -295,7 +301,7 @@ instance Evaluatable NonNullExpression
-- | An await expression in Javascript or C#.
newtype Await a = Await { awaitSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Await where liftEq = genericLiftEq
instance Ord1 Await where liftCompare = genericLiftCompare
@ -309,7 +315,7 @@ instance Evaluatable Await
-- | An object constructor call in Javascript, Java, etc.
newtype New a = New { newSubject :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 New where liftEq = genericLiftEq
instance Ord1 New where liftCompare = genericLiftCompare
@ -323,7 +329,7 @@ instance Evaluatable New
-- | A cast expression to a specified type.
data Cast a = Cast { castSubject :: !a, castType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Cast where liftEq = genericLiftEq
instance Ord1 Cast where liftCompare = genericLiftCompare

View File

@ -1,7 +1,6 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-}
module Data.Syntax.Literal where
import Control.Arrow ((>>>))
import Data.JSON.Fields
import Data.Abstract.Evaluatable
import Data.ByteString.Char8 (readInteger, unpack)
@ -15,7 +14,7 @@ import Text.Read (readMaybe)
-- Boolean
newtype Boolean a = Boolean Bool
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
true :: Boolean a
true = Boolean True
@ -28,7 +27,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Boolean where
eval (Boolean x) = boolean x
eval (Boolean x) = Rval <$> boolean x
instance ToJSONFields1 Boolean where
toJSONFields1 (Boolean b) = noChildren [ "value" .= b ]
@ -37,7 +36,7 @@ instance ToJSONFields1 Boolean where
-- | A literal integer of unspecified width. No particular base is implied.
newtype Integer a = Integer { integerContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
@ -46,7 +45,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
instance Evaluatable Data.Syntax.Literal.Integer where
-- TODO: This instance probably shouldn't have readInteger?
eval (Data.Syntax.Literal.Integer x) =
integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x)
Rval <$> (integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x))
instance ToJSONFields1 Data.Syntax.Literal.Integer where
toJSONFields1 (Integer i) = noChildren ["asString" .= unpack i]
@ -58,7 +57,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where
-- | A literal float of unspecified width.
newtype Float a = Float { floatContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@ -66,14 +65,14 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
instance Evaluatable Data.Syntax.Literal.Float where
eval (Float s) =
float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
Rval <$> (float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
instance ToJSONFields1 Float where
toJSONFields1 (Float f) = noChildren ["asString" .= unpack f]
-- Rational literals e.g. `2/3r`
newtype Rational a = Rational ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
@ -84,14 +83,14 @@ instance Evaluatable Data.Syntax.Literal.Rational where
let
trimmed = B.takeWhile (/= 'r') r
parsed = readMaybe @Prelude.Integer (unpack trimmed)
in rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
in Rval <$> (rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed)
instance ToJSONFields1 Data.Syntax.Literal.Rational where
toJSONFields1 (Rational r) = noChildren ["asString" .= unpack r]
-- Complex literals e.g. `3 + 2i`
newtype Complex a = Complex ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
@ -106,7 +105,7 @@ instance ToJSONFields1 Complex where
-- Strings, symbols
newtype String a = String { stringElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
@ -121,7 +120,7 @@ instance ToJSONFields1 Data.Syntax.Literal.String
-- | An interpolation element within a string literal.
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InterpolationElement where liftEq = genericLiftEq
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
@ -134,7 +133,7 @@ instance ToJSONFields1 InterpolationElement
-- | A sequence of textual contents within a string literal.
newtype TextElement a = TextElement { textElementContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TextElement where liftEq = genericLiftEq
instance Ord1 TextElement where liftCompare = genericLiftCompare
@ -144,21 +143,21 @@ instance ToJSONFields1 TextElement where
toJSONFields1 (TextElement c) = noChildren ["asString" .= unpack c]
instance Evaluatable TextElement where
eval (TextElement x) = string x
eval (TextElement x) = Rval <$> string x
data Null a = Null
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Null where eval = const null
instance Evaluatable Null where eval _ = Rval <$> null
instance ToJSONFields1 Null
newtype Symbol a = Symbol { symbolContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Symbol where liftEq = genericLiftEq
instance Ord1 Symbol where liftCompare = genericLiftCompare
@ -167,10 +166,10 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Symbol
instance Evaluatable Symbol where
eval (Symbol s) = symbol s
eval (Symbol s) = Rval <$> symbol s
newtype Regex a = Regex { regexContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Regex where liftEq = genericLiftEq
instance Ord1 Regex where liftCompare = genericLiftCompare
@ -190,7 +189,7 @@ instance Evaluatable Regex
-- Collections
newtype Array a = Array { arrayElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -199,10 +198,10 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Array
instance Evaluatable Array where
eval (Array a) = array =<< traverse subtermValue a
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
newtype Hash a = Hash { hashElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Hash where liftEq = genericLiftEq
instance Ord1 Hash where liftCompare = genericLiftCompare
@ -211,10 +210,10 @@ instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Hash
instance Evaluatable Hash where
eval = hashElements >>> traverse (subtermValue >=> asPair) >=> hash
eval t = Rval <$> (traverse (subtermValue >=> asPair) (hashElements t) >>= hash)
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 KeyValue where liftEq = genericLiftEq
instance Ord1 KeyValue where liftCompare = genericLiftCompare
@ -224,22 +223,22 @@ instance ToJSONFields1 KeyValue
instance Evaluatable KeyValue where
eval (fmap subtermValue -> KeyValue{..}) =
join (kvPair <$> key <*> value)
Rval <$> join (kvPair <$> key <*> value)
instance ToJSONFields1 Tuple
newtype Tuple a = Tuple { tupleContents :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple where
eval (Tuple cs) = multiple =<< traverse subtermValue cs
eval (Tuple cs) = Rval <$> (multiple =<< traverse subtermValue cs)
newtype Set a = Set { setElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Set where liftEq = genericLiftEq
instance Ord1 Set where liftCompare = genericLiftCompare
@ -255,7 +254,7 @@ instance Evaluatable Set
-- | A declared pointer (e.g. var pointer *int in Go)
newtype Pointer a = Pointer a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -269,7 +268,7 @@ instance Evaluatable Pointer
-- | A reference to a pointer's address (e.g. &pointer in Go)
newtype Reference a = Reference a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Reference where liftEq = genericLiftEq
instance Ord1 Reference where liftCompare = genericLiftCompare

View File

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
module Data.Syntax.Statement where
import Control.Abstract.Evaluator (ValueRef(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.ByteString.Char8 (unpack)
@ -11,7 +12,7 @@ import Prologue
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 If where liftEq = genericLiftEq
instance Ord1 If where liftCompare = genericLiftCompare
@ -22,11 +23,11 @@ instance ToJSONFields1 If
instance Evaluatable If where
eval (If cond if' else') = do
bool <- subtermValue cond
ifthenelse bool (subtermValue if') (subtermValue else')
Rval <$> ifthenelse bool (subtermValue if') (subtermValue else')
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
data Else a = Else { elseCondition :: !a, elseBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Else where liftEq = genericLiftEq
instance Ord1 Else where liftCompare = genericLiftCompare
@ -41,7 +42,7 @@ instance Evaluatable Else
-- | Goto statement (e.g. `goto a` in Go).
newtype Goto a = Goto { gotoLocation :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Goto where liftEq = genericLiftEq
instance Ord1 Goto where liftCompare = genericLiftCompare
@ -55,7 +56,7 @@ instance Evaluatable Goto
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
@ -69,7 +70,7 @@ instance Evaluatable Match
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
data Pattern a = Pattern { _pattern :: !a, patternBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pattern where liftEq = genericLiftEq
instance Ord1 Pattern where liftCompare = genericLiftCompare
@ -83,7 +84,7 @@ instance Evaluatable Pattern
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Let where liftEq = genericLiftEq
instance Ord1 Let where liftCompare = genericLiftCompare
@ -95,14 +96,14 @@ instance Evaluatable Let where
eval Let{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
addr <- snd <$> letrec name (subtermValue letValue)
localEnv (Env.insert name addr) (subtermValue letBody)
Rval <$> localEnv (Env.insert name addr) (subtermValue letBody)
-- Assignment
-- | Assignment to a variable or other lvalue.
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
@ -112,17 +113,26 @@ instance ToJSONFields1 Assignment
instance Evaluatable Assignment where
eval Assignment{..} = do
case freeVariables (subterm assignmentTarget) of
[name] -> do
v <- subtermValue assignmentValue
addr <- lookupOrAlloc name
assign addr v
modifyEnv (Env.insert name addr) $> v
_ -> evaluateInScopedEnv (subtermValue assignmentTarget) (subtermValue assignmentValue)
lhs <- subtermRef assignmentTarget
rhs <- subtermValue assignmentValue
case lhs of
LvalLocal nam -> do
addr <- lookupOrAlloc nam
assign addr rhs
modifyEnv (Env.insert nam addr)
LvalMember _ _ ->
-- we don't yet support mutable object properties:
pure ()
Rval _ ->
-- the left hand side of the assignment expression is invalid:
pure ()
pure (Rval rhs)
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PostIncrement where liftEq = genericLiftEq
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
@ -136,7 +146,7 @@ instance Evaluatable PostIncrement
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
newtype PostDecrement a = PostDecrement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PostDecrement where liftEq = genericLiftEq
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
@ -151,7 +161,7 @@ instance Evaluatable PostDecrement
-- Returns
newtype Return a = Return a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Return where liftEq = genericLiftEq
instance Ord1 Return where liftCompare = genericLiftCompare
@ -160,10 +170,10 @@ instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Return
instance Evaluatable Return where
eval (Return x) = subtermValue x >>= earlyReturn
eval (Return x) = Rval <$> (subtermValue x >>= earlyReturn)
newtype Yield a = Yield a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Yield where liftEq = genericLiftEq
instance Ord1 Yield where liftCompare = genericLiftCompare
@ -176,7 +186,7 @@ instance Evaluatable Yield
newtype Break a = Break a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Break where liftEq = genericLiftEq
instance Ord1 Break where liftCompare = genericLiftCompare
@ -185,10 +195,10 @@ instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Break
instance Evaluatable Break where
eval (Break x) = subtermValue x >>= throwBreak
eval (Break x) = Rval <$> (subtermValue x >>= throwBreak)
newtype Continue a = Continue a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Continue where liftEq = genericLiftEq
instance Ord1 Continue where liftCompare = genericLiftCompare
@ -197,10 +207,10 @@ instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Continue
instance Evaluatable Continue where
eval (Continue a) = subtermValue a >>= throwContinue
eval (Continue a) = Rval <$> (subtermValue a >>= throwContinue)
newtype Retry a = Retry a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Retry where liftEq = genericLiftEq
instance Ord1 Retry where liftCompare = genericLiftCompare
@ -213,7 +223,7 @@ instance Evaluatable Retry
newtype NoOp a = NoOp a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NoOp where liftEq = genericLiftEq
instance Ord1 NoOp where liftCompare = genericLiftCompare
@ -222,12 +232,12 @@ instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 NoOp
instance Evaluatable NoOp where
eval _ = unit
eval _ = Rval <$> unit
-- Loops
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 For where liftEq = genericLiftEq
instance Ord1 For where liftCompare = genericLiftCompare
@ -236,11 +246,11 @@ instance Show1 For where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 For
instance Evaluatable For where
eval (fmap subtermValue -> For before cond step body) = forLoop before cond step body
eval (fmap subtermValue -> For before cond step body) = Rval <$> forLoop before cond step body
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ForEach where liftEq = genericLiftEq
instance Ord1 ForEach where liftCompare = genericLiftCompare
@ -253,7 +263,7 @@ instance Evaluatable ForEach
data While a = While { whileCondition :: !a, whileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 While where liftEq = genericLiftEq
instance Ord1 While where liftCompare = genericLiftCompare
@ -262,10 +272,10 @@ instance Show1 While where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 While
instance Evaluatable While where
eval While{..} = while (subtermValue whileCondition) (subtermValue whileBody)
eval While{..} = Rval <$> while (subtermValue whileCondition) (subtermValue whileBody)
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 DoWhile where liftEq = genericLiftEq
instance Ord1 DoWhile where liftCompare = genericLiftCompare
@ -274,12 +284,12 @@ instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 DoWhile
instance Evaluatable DoWhile where
eval DoWhile{..} = doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
eval DoWhile{..} = Rval <$> doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
-- Exception handling
newtype Throw a = Throw a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Throw where liftEq = genericLiftEq
instance Ord1 Throw where liftCompare = genericLiftCompare
@ -292,7 +302,7 @@ instance Evaluatable Throw
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Try where liftEq = genericLiftEq
instance Ord1 Try where liftCompare = genericLiftCompare
@ -305,7 +315,7 @@ instance Evaluatable Try
data Catch a = Catch { catchException :: !a, catchBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Catch where liftEq = genericLiftEq
instance Ord1 Catch where liftCompare = genericLiftCompare
@ -318,7 +328,7 @@ instance Evaluatable Catch
newtype Finally a = Finally a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Finally where liftEq = genericLiftEq
instance Ord1 Finally where liftCompare = genericLiftCompare
@ -334,7 +344,7 @@ instance Evaluatable Finally
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
newtype ScopeEntry a = ScopeEntry [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeEntry where liftEq = genericLiftEq
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
@ -348,7 +358,7 @@ instance Evaluatable ScopeEntry
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
newtype ScopeExit a = ScopeExit [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeExit where liftEq = genericLiftEq
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
@ -361,7 +371,7 @@ instance Evaluatable ScopeExit
-- | HashBang line (e.g. `#!/usr/bin/env node`)
newtype HashBang a = HashBang ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 HashBang where liftEq = genericLiftEq
instance Ord1 HashBang where liftCompare = genericLiftCompare

View File

@ -7,7 +7,7 @@ import Diffing.Algorithm
import Prologue hiding (Map)
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -21,7 +21,7 @@ instance Evaluatable Array
-- TODO: What about type variables? re: FreeVariables1
data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare
@ -35,7 +35,7 @@ instance Evaluatable Annotation where
data Function a = Function { functionParameters :: [a], functionReturn :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Function where liftEq = genericLiftEq
instance Ord1 Function where liftCompare = genericLiftCompare
@ -48,7 +48,7 @@ instance Evaluatable Function
newtype Interface a = Interface [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Interface where liftEq = genericLiftEq
instance Ord1 Interface where liftCompare = genericLiftCompare
@ -61,7 +61,7 @@ instance Evaluatable Interface
data Map a = Map { mapKeyType :: a, mapElementType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Map where liftEq = genericLiftEq
instance Ord1 Map where liftCompare = genericLiftCompare
@ -74,7 +74,7 @@ instance Evaluatable Map
newtype Parenthesized a = Parenthesized a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Parenthesized where liftEq = genericLiftEq
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
@ -87,7 +87,7 @@ instance Evaluatable Parenthesized
newtype Pointer a = Pointer a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -100,7 +100,7 @@ instance Evaluatable Pointer
newtype Product a = Product [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Product where liftEq = genericLiftEq
instance Ord1 Product where liftCompare = genericLiftCompare
@ -113,7 +113,7 @@ instance Evaluatable Product
data Readonly a = Readonly
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Readonly where liftEq = genericLiftEq
instance Ord1 Readonly where liftCompare = genericLiftCompare
@ -126,7 +126,7 @@ instance Evaluatable Readonly
newtype Slice a = Slice a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -139,7 +139,7 @@ instance Evaluatable Slice
newtype TypeParameters a = TypeParameters [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeParameters where liftEq = genericLiftEq
instance Ord1 TypeParameters where liftCompare = genericLiftCompare

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-}
{-# LANGUAGE GADTs, DataKinds, DeriveAnyClass, RankNTypes, TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
module Diffing.Algorithm.RWS
( rws
@ -25,8 +25,6 @@ import Data.Term as Term
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
type Label f fields label = forall b. TermF f (Record fields) b -> label
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
--
-- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
@ -104,45 +102,41 @@ toKdMap = KdMap.build unFV . fmap (rhead . termAnnotation . snd &&& id)
-- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
deriving (Eq, Show)
deriving (Eq, Generic, Hashable, Show)
-- | Annotates a term with a feature vector at each node, using the default values for the p, q, and d parameters.
defaultFeatureVectorDecorator
:: (Hashable label, Traversable f)
=> Label f fields label
-> Term f (Record fields)
-> Term f (Record (FeatureVector ': fields))
defaultFeatureVectorDecorator getLabel = featureVectorDecorator . pqGramDecorator getLabel defaultP defaultQ
defaultFeatureVectorDecorator :: (Hashable1 syntax, Traversable syntax)
=> Term syntax (Record fields)
-> Term syntax (Record (FeatureVector ': fields))
defaultFeatureVectorDecorator = featureVectorDecorator . pqGramDecorator defaultP defaultQ
-- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions.
featureVectorDecorator :: (Foldable f, Functor f, Hashable label) => Term f (Record (label ': fields)) -> Term f (Record (FeatureVector ': fields))
featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Record (label ': fields)) -> Term syntax (Record (FeatureVector ': fields))
featureVectorDecorator = cata (\ (In (label :. rest) functor) ->
termIn (foldl' addSubtermVector (unitVector (hash label)) functor :. rest) functor)
where addSubtermVector v term = addVectors v (rhead (termAnnotation term))
-- | Annotates a term with the corresponding p,q-gram at each node.
pqGramDecorator
:: Traversable f
=> Label f fields label -- ^ A function computing the label from an arbitrary unpacked term. This function can use the annotation and functors constructor, but not any recursive values inside the functor (since theyre held parametric in 'b').
-> Int -- ^ 'p'; the desired stem length for the grams.
-> Int -- ^ 'q'; the desired base length for the grams.
-> Term f (Record fields) -- ^ The term to decorate.
-> Term f (Record (Gram label ': fields)) -- ^ The decorated term.
pqGramDecorator getLabel p q = cata algebra
pqGramDecorator :: Traversable syntax
=> Int -- ^ 'p'; the desired stem length for the grams.
-> Int -- ^ 'q'; the desired base length for the grams.
-> Term syntax (Record fields) -- ^ The term to decorate.
-> Term syntax (Record (Gram (Label syntax) ': fields)) -- ^ The decorated term.
pqGramDecorator p q = cata algebra
where
algebra term = let label = getLabel term in
algebra term = let label = Label (termFOut term) in
termIn (gram label :. termFAnnotation term) (assignParentAndSiblingLabels (termFOut term) label)
gram label = Gram (padToSize p []) (padToSize q (pure (Just label)))
assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))
assignLabels :: label
-> Term f (Record (Gram label ': fields))
-> State [Maybe label] (Term f (Record (Gram label ': fields)))
-> Term syntax (Record (Gram label ': fields))
-> State [Maybe label] (Term syntax (Record (Gram label ': fields)))
assignLabels label (Term.Term (In (gram :. rest) functor)) = do
labels <- get
put (drop 1 labels)
pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor
siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label]
siblingLabels :: Traversable syntax => syntax (Term syntax (Record (Gram label ': fields))) -> [Maybe label]
siblingLabels = foldMap (base . rhead . termAnnotation)
padToSize n list = take n (list <> repeat empty)
@ -168,8 +162,13 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b)
approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (galignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
-- Instances
data Label syntax where
Label :: syntax a -> Label syntax
instance Hashable label => Hashable (Gram label) where
hashWithSalt _ = hash
hash gram = hash (stem gram <> base gram)
instance Hashable1 syntax => Hashable (Label syntax) where hashWithSalt salt (Label syntax) = liftHashWithSalt const salt syntax
instance Eq1 syntax => Eq (Label syntax) where Label a == Label b = liftEq (const (const True)) a b
instance Ord1 syntax => Ord (Label syntax) where Label a `compare` Label b = liftCompare (const (const EQ)) a b
instance Show1 syntax => Show (Label syntax) where showsPrec d (Label syntax) = liftShowsPrec (const (const id)) (const id) d syntax

View File

@ -4,7 +4,6 @@ module Diffing.Interpreter
, diffTermPair
) where
import Analysis.Decorator
import Control.Monad.Free.Freer
import Data.Align.Generic (galignWith)
import Data.Diff
@ -15,16 +14,16 @@ import Diffing.Algorithm.RWS
import Prologue
-- | Diff two à la carte terms recursively.
diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax)
diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax)
=> Term syntax (Record fields1)
-> Term syntax (Record fields2)
-> Diff syntax (Record fields1) (Record fields2)
diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2')))
where (t1', t2') = ( defaultFeatureVectorDecorator constructorNameAndConstantFields t1
, defaultFeatureVectorDecorator constructorNameAndConstantFields t2)
where (t1', t2') = ( defaultFeatureVectorDecorator t1
, defaultFeatureVectorDecorator t2)
-- | Diff a 'These' of terms.
diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2)
diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2)
diffTermPair = these deleting inserting diffTerms

View File

@ -14,10 +14,10 @@ import Prologue
import System.FilePath.Posix
data Relative = Relative | NonRelative
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative }
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
importPath :: ByteString -> ImportPath
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path)
@ -57,7 +57,7 @@ resolveGoImport (ImportPath path NonRelative) = do
--
-- If the list of symbols is empty copy everything to the calling environment.
data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
@ -72,14 +72,14 @@ instance Evaluatable Import where
traceResolve (unPath importPath) path
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
modifyEnv (mergeEnvs importedEnv)
unit
Rval <$> unit
-- | Qualified Import declarations (symbols are qualified in calling environment).
--
-- If the list of symbols is empty copy and qualify everything to the calling environment.
data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedImport where liftEq = genericLiftEq
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
@ -97,11 +97,11 @@ instance Evaluatable QualifiedImport where
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
modifyEnv (mergeEnvs importedEnv)
makeNamespace alias addr Nothing
unit
Rval <$> unit
-- | Side effect only imports (no symbols made available to the calling environment).
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 SideEffectImport where liftEq = genericLiftEq
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@ -114,11 +114,11 @@ instance Evaluatable SideEffectImport where
paths <- resolveGoImport importPath
traceResolve (unPath importPath) paths
for_ paths $ \path -> isolate (require path)
unit
Rval <$> unit
-- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Composite where liftEq = genericLiftEq
instance Ord1 Composite where liftCompare = genericLiftCompare
@ -131,7 +131,7 @@ instance Evaluatable Composite
-- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 DefaultPattern where liftEq = genericLiftEq
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
@ -144,7 +144,7 @@ instance Evaluatable DefaultPattern
-- | A defer statement in Go (e.g. `defer x()`).
newtype Defer a = Defer { deferBody :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Defer where liftEq = genericLiftEq
instance Ord1 Defer where liftCompare = genericLiftCompare
@ -157,7 +157,7 @@ instance Evaluatable Defer
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
newtype Go a = Go { goBody :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Go where liftEq = genericLiftEq
instance Ord1 Go where liftCompare = genericLiftCompare
@ -170,7 +170,7 @@ instance Evaluatable Go
-- | A label statement in Go (e.g. `label:continue`).
data Label a = Label { _labelName :: !a, labelStatement :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Label where liftEq = genericLiftEq
instance Ord1 Label where liftCompare = genericLiftCompare
@ -183,7 +183,7 @@ instance Evaluatable Label
-- | A rune literal in Go (e.g. `'⌘'`).
newtype Rune a = Rune { _runeLiteral :: ByteString }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Rune
@ -196,7 +196,7 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec
-- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
newtype Select a = Select { selectCases :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Select
@ -209,7 +209,7 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec
-- | A send statement in Go (e.g. `channel <- value`).
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -222,7 +222,7 @@ instance Evaluatable Send
-- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -235,7 +235,7 @@ instance Evaluatable Slice
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitch where liftEq = genericLiftEq
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
@ -248,7 +248,7 @@ instance Evaluatable TypeSwitch
-- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
@ -261,7 +261,7 @@ instance Evaluatable TypeSwitchGuard
-- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Receive where liftEq = genericLiftEq
instance Ord1 Receive where liftCompare = genericLiftCompare
@ -274,7 +274,7 @@ instance Evaluatable Receive
-- | A receive operator unary expression in Go (e.g. `<-channel` )
newtype ReceiveOperator a = ReceiveOperator a
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
@ -287,7 +287,7 @@ instance Evaluatable ReceiveOperator
-- | A field declaration in a Go struct type declaration.
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Field where liftEq = genericLiftEq
instance Ord1 Field where liftCompare = genericLiftCompare
@ -300,7 +300,7 @@ instance Evaluatable Field
data Package a = Package { packageName :: !a, packageContents :: ![a] }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Package where liftEq = genericLiftEq
instance Ord1 Package where liftCompare = genericLiftCompare
@ -314,7 +314,7 @@ instance Evaluatable Package where
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@ -327,7 +327,7 @@ instance Evaluatable TypeAssertion
-- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeConversion where liftEq = genericLiftEq
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
@ -340,7 +340,7 @@ instance Evaluatable TypeConversion
-- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Variadic where liftEq = genericLiftEq
instance Ord1 Variadic where liftCompare = genericLiftCompare

View File

@ -8,7 +8,7 @@ import Diffing.Algorithm
-- | A Bidirectional channel in Go (e.g. `chan`).
newtype BidirectionalChannel a = BidirectionalChannel a
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
@ -21,7 +21,7 @@ instance Evaluatable BidirectionalChannel
-- | A Receive channel in Go (e.g. `<-chan`).
newtype ReceiveChannel a = ReceiveChannel a
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
@ -34,7 +34,7 @@ instance Evaluatable ReceiveChannel
-- | A Send channel in Go (e.g. `chan<-`).
newtype SendChannel a = SendChannel a
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 SendChannel where liftEq = genericLiftEq
instance Ord1 SendChannel where liftCompare = genericLiftCompare

View File

@ -7,7 +7,7 @@ import Data.JSON.Fields
import Diffing.Algorithm
newtype Document a = Document [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Document
@ -19,7 +19,7 @@ instance Show1 Document where liftShowsPrec = genericLiftShowsPrec
-- Block elements
newtype Paragraph a = Paragraph [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Paragraph
@ -28,7 +28,7 @@ instance Ord1 Paragraph where liftCompare = genericLiftCompare
instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
data Heading a = Heading { headingLevel :: Int, headingContent :: [a], sectionContent :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Heading
@ -37,7 +37,7 @@ instance Ord1 Heading where liftCompare = genericLiftCompare
instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec
newtype UnorderedList a = UnorderedList [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 UnorderedList
@ -48,7 +48,7 @@ instance Show1 UnorderedList where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 OrderedList
newtype OrderedList a = OrderedList [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 OrderedList where liftEq = genericLiftEq
instance Ord1 OrderedList where liftCompare = genericLiftCompare
@ -57,7 +57,7 @@ instance Show1 OrderedList where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 BlockQuote
newtype BlockQuote a = BlockQuote [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 BlockQuote where liftEq = genericLiftEq
instance Ord1 BlockQuote where liftCompare = genericLiftCompare
@ -66,7 +66,7 @@ instance Show1 BlockQuote where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 ThematicBreak
data ThematicBreak a = ThematicBreak
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 ThematicBreak where liftEq = genericLiftEq
instance Ord1 ThematicBreak where liftCompare = genericLiftCompare
@ -76,14 +76,14 @@ instance ToJSONFields1 HTMLBlock where
toJSONFields1 (HTMLBlock b) = noChildren [ "asString" .= unpack b ]
newtype HTMLBlock a = HTMLBlock ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 HTMLBlock where liftEq = genericLiftEq
instance Ord1 HTMLBlock where liftCompare = genericLiftCompare
instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec
newtype Table a = Table [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Table
@ -92,7 +92,7 @@ instance Ord1 Table where liftCompare = genericLiftCompare
instance Show1 Table where liftShowsPrec = genericLiftShowsPrec
newtype TableRow a = TableRow [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TableRow
@ -101,7 +101,7 @@ instance Ord1 TableRow where liftCompare = genericLiftCompare
instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec
newtype TableCell a = TableCell [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TableCell
@ -113,7 +113,7 @@ instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec
-- Inline elements
newtype Strong a = Strong [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Strong
@ -122,7 +122,7 @@ instance Ord1 Strong where liftCompare = genericLiftCompare
instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec
newtype Emphasis a = Emphasis [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Emphasis
@ -131,7 +131,7 @@ instance Ord1 Emphasis where liftCompare = genericLiftCompare
instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec
newtype Text a = Text ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Text where
toJSONFields1 (Text s) = noChildren ["asString" .= unpack s ]
@ -141,7 +141,7 @@ instance Ord1 Text where liftCompare = genericLiftCompare
instance Show1 Text where liftShowsPrec = genericLiftShowsPrec
data Link a = Link { linkURL :: ByteString, linkTitle :: Maybe ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
-- TODO: Better ToJSONFields1 instance
instance ToJSONFields1 Link
@ -151,7 +151,7 @@ instance Ord1 Link where liftCompare = genericLiftCompare
instance Show1 Link where liftShowsPrec = genericLiftShowsPrec
data Image a = Image { imageURL :: ByteString, imageTitle :: Maybe ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
-- TODO: Better ToJSONFields1 instance
instance ToJSONFields1 Image
@ -161,7 +161,7 @@ instance Ord1 Image where liftCompare = genericLiftCompare
instance Show1 Image where liftShowsPrec = genericLiftShowsPrec
data Code a = Code { codeLanguage :: Maybe ByteString, codeContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
-- TODO: Better ToJSONFields1 instance
instance ToJSONFields1 Code
@ -171,7 +171,7 @@ instance Ord1 Code where liftCompare = genericLiftCompare
instance Show1 Code where liftShowsPrec = genericLiftShowsPrec
data LineBreak a = LineBreak
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 LineBreak
@ -182,7 +182,7 @@ instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Strikethrough
newtype Strikethrough a = Strikethrough [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Strikethrough where liftEq = genericLiftEq
instance Ord1 Strikethrough where liftCompare = genericLiftCompare

View File

@ -12,7 +12,7 @@ import Prelude hiding (fail)
import Prologue hiding (Text)
newtype Text a = Text ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Text where
toJSONFields1 (Text t) = noChildren ["asString" .= BC.unpack t]
@ -24,7 +24,7 @@ instance Evaluatable Text
newtype VariableName a = VariableName a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 VariableName
@ -52,27 +52,33 @@ resolvePHPName n = do
where name = toName n
toName = BC.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue location value effects
include :: ( Addressable location effects
, AbstractValue location value effects
, Members '[ Modules location value
, Reader (Environment location value)
, Resumable ResolutionError
, Resumable (AddressError location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Exports location value)
, State (Heap location (Cell location) value)
, Trace
] effects
)
=> Subterm term (Evaluator location value effects value)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)))
-> Evaluator location value effects value
-> Evaluator location value effects (ValueRef value)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
traceResolve name path
(importedEnv, v) <- isolate (f path) >>= maybeM ((,) emptyEnv <$> unit)
modifyEnv (mergeEnvs importedEnv)
pure v
pure (Rval v)
newtype Require a = Require a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
@ -85,7 +91,7 @@ instance Evaluatable Require where
newtype RequireOnce a = RequireOnce a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 RequireOnce where liftEq = genericLiftEq
instance Ord1 RequireOnce where liftCompare = genericLiftCompare
@ -98,7 +104,7 @@ instance Evaluatable RequireOnce where
newtype Include a = Include a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Include where liftEq = genericLiftEq
instance Ord1 Include where liftCompare = genericLiftCompare
@ -111,7 +117,7 @@ instance Evaluatable Include where
newtype IncludeOnce a = IncludeOnce a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 IncludeOnce where liftEq = genericLiftEq
instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
@ -124,7 +130,7 @@ instance Evaluatable IncludeOnce where
newtype ArrayElement a = ArrayElement a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ArrayElement
@ -134,7 +140,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayElement
newtype GlobalDeclaration a = GlobalDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 GlobalDeclaration
@ -144,7 +150,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GlobalDeclaration
newtype SimpleVariable a = SimpleVariable a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 SimpleVariable
@ -156,7 +162,7 @@ instance Evaluatable SimpleVariable
-- | TODO: Unify with TypeScript's PredefinedType
newtype CastType a = CastType { _castType :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 CastType
@ -166,7 +172,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable CastType
newtype ErrorControl a = ErrorControl a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ErrorControl
@ -176,7 +182,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ErrorControl
newtype Clone a = Clone a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Clone
@ -186,7 +192,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Clone
newtype ShellCommand a = ShellCommand ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ShellCommand
@ -197,7 +203,7 @@ instance Evaluatable ShellCommand
-- | TODO: Combine with TypeScript update expression.
newtype Update a = Update { _updateSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Update
@ -207,7 +213,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
newtype NewVariable a = NewVariable [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NewVariable
@ -217,7 +223,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NewVariable
newtype RelativeScope a = RelativeScope ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 RelativeScope
@ -227,7 +233,7 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RelativeScope
data QualifiedName a = QualifiedName !a !a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 QualifiedName
@ -236,22 +242,23 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedName where
eval (fmap subtermValue -> QualifiedName name iden) = evaluateInScopedEnv name iden
eval (fmap subtermValue -> QualifiedName name iden) = Rval <$> evaluateInScopedEnv name iden
newtype NamespaceName a = NamespaceName (NonEmpty a)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NamespaceName
instance Hashable1 NamespaceName where liftHashWithSalt = foldl
instance Eq1 NamespaceName where liftEq = genericLiftEq
instance Ord1 NamespaceName where liftCompare = genericLiftCompare
instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceName where
eval (NamespaceName xs) = foldl1 evaluateInScopedEnv $ fmap subtermValue xs
eval (NamespaceName xs) = Rval <$> foldl1 evaluateInScopedEnv (fmap subtermValue xs)
newtype ConstDeclaration a = ConstDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ConstDeclaration
@ -261,7 +268,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstDeclaration
data ClassConstDeclaration a = ClassConstDeclaration a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ClassConstDeclaration
@ -271,7 +278,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassConstDeclaration
newtype ClassInterfaceClause a = ClassInterfaceClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ClassInterfaceClause
@ -281,7 +288,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassInterfaceClause
newtype ClassBaseClause a = ClassBaseClause a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ClassBaseClause
@ -292,7 +299,7 @@ instance Evaluatable ClassBaseClause
newtype UseClause a = UseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 UseClause
@ -302,7 +309,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable UseClause
newtype ReturnType a = ReturnType a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ReturnType
@ -312,7 +319,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ReturnType
newtype TypeDeclaration a = TypeDeclaration a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TypeDeclaration
@ -322,7 +329,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeDeclaration
newtype BaseTypeDeclaration a = BaseTypeDeclaration a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 BaseTypeDeclaration
@ -332,7 +339,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BaseTypeDeclaration
newtype ScalarType a = ScalarType ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ScalarType
@ -342,7 +349,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ScalarType
newtype EmptyIntrinsic a = EmptyIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 EmptyIntrinsic
@ -352,7 +359,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EmptyIntrinsic
newtype ExitIntrinsic a = ExitIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ExitIntrinsic
@ -362,7 +369,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExitIntrinsic
newtype IssetIntrinsic a = IssetIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 IssetIntrinsic
@ -372,7 +379,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IssetIntrinsic
newtype EvalIntrinsic a = EvalIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 EvalIntrinsic
@ -382,7 +389,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EvalIntrinsic
newtype PrintIntrinsic a = PrintIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 PrintIntrinsic
@ -392,7 +399,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PrintIntrinsic
newtype NamespaceAliasingClause a = NamespaceAliasingClause a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NamespaceAliasingClause
@ -402,7 +409,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceAliasingClause
newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NamespaceUseDeclaration
@ -412,7 +419,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseDeclaration
newtype NamespaceUseClause a = NamespaceUseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NamespaceUseClause
@ -422,7 +429,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceUseClause
newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 NamespaceUseGroupClause
@ -432,7 +439,7 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseGroupClause
data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance Eq1 Namespace where liftEq = genericLiftEq
instance Ord1 Namespace where liftCompare = genericLiftCompare
@ -441,7 +448,7 @@ instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Namespace
instance Evaluatable Namespace where
eval Namespace{..} = go names
eval Namespace{..} = Rval <$> go names
where
names = freeVariables (subterm namespaceName)
go [] = raiseEff (fail "expected at least one free variable in namespaceName, found none")
@ -453,7 +460,7 @@ instance Evaluatable Namespace where
go xs <* makeNamespace name addr Nothing
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TraitDeclaration
@ -463,7 +470,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitDeclaration
data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 AliasAs
@ -473,7 +480,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AliasAs
data InsteadOf a = InsteadOf a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 InsteadOf
@ -483,7 +490,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InsteadOf
newtype TraitUseSpecification a = TraitUseSpecification [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TraitUseSpecification
@ -493,7 +500,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseSpecification
data TraitUseClause a = TraitUseClause [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 TraitUseClause
@ -503,7 +510,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseClause
data DestructorDeclaration a = DestructorDeclaration [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 DestructorDeclaration
@ -513,7 +520,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DestructorDeclaration
newtype Static a = Static ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Static
@ -523,7 +530,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Static
newtype ClassModifier a = ClassModifier ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ClassModifier
@ -533,7 +540,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassModifier
data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 ConstructorDeclaration
@ -543,7 +550,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructorDeclaration
data PropertyDeclaration a = PropertyDeclaration a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 PropertyDeclaration
@ -553,7 +560,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyDeclaration
data PropertyModifier a = PropertyModifier a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 PropertyModifier
@ -563,7 +570,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyModifier
data InterfaceDeclaration a = InterfaceDeclaration a a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 InterfaceDeclaration
@ -573,7 +580,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceDeclaration
newtype InterfaceBaseClause a = InterfaceBaseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 InterfaceBaseClause
@ -583,7 +590,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceBaseClause
newtype Echo a = Echo a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Echo
@ -593,7 +600,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Echo
newtype Unset a = Unset a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Unset
@ -603,7 +610,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Unset
data Declare a = Declare a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 Declare
@ -613,7 +620,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Declare
newtype DeclareDirective a = DeclareDirective a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 DeclareDirective
@ -623,7 +630,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DeclareDirective
newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
instance ToJSONFields1 LabeledStatement

View File

@ -21,7 +21,7 @@ import System.FilePath.Posix
data QualifiedName
= QualifiedName (NonEmpty FilePath)
| RelativeQualifiedName FilePath (Maybe QualifiedName)
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
qualifiedName :: NonEmpty ByteString -> QualifiedName
qualifiedName xs = QualifiedName (BC.unpack <$> xs)
@ -89,7 +89,7 @@ resolvePythonModules q = do
--
-- If the list of symbols is empty copy everything to the calling environment.
data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![(Name, Name)] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Import
@ -111,7 +111,7 @@ instance Evaluatable Import where
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
modifyEnv (mergeEnvs (select importedEnv))
unit
Rval <$> unit
where
select importedEnv
| Prologue.null xs = importedEnv
@ -119,7 +119,7 @@ instance Evaluatable Import where
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 QualifiedImport
@ -132,7 +132,7 @@ instance Evaluatable QualifiedImport where
eval (QualifiedImport (RelativeQualifiedName _ _)) = raiseEff (fail "technically this is not allowed in python")
eval (QualifiedImport name@(QualifiedName qualifiedName)) = do
modulePaths <- resolvePythonModules name
go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
Rval <$> go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
where
-- Evaluate and import the last module, updating the environment
go ((name, path) :| []) = letrec' name $ \addr -> do
@ -147,7 +147,7 @@ instance Evaluatable QualifiedImport where
makeNamespace name addr Nothing
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 QualifiedAliasedImport
@ -165,16 +165,16 @@ instance Evaluatable QualifiedAliasedImport where
-- Evaluate and import the last module, aliasing and updating the environment
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
letrec' alias $ \addr -> do
Rval <$> letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
modifyEnv (mergeEnvs importedEnv)
void $ makeNamespace alias addr Nothing
unit
unit)
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
data Ellipsis a = Ellipsis
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Ellipsis where liftEq = genericLiftEq
instance Ord1 Ellipsis where liftCompare = genericLiftCompare
@ -187,7 +187,7 @@ instance Evaluatable Ellipsis
data Redirect a = Redirect !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Redirect where liftEq = genericLiftEq
instance Ord1 Redirect where liftCompare = genericLiftCompare

View File

@ -43,7 +43,7 @@ cleanNameOrPath :: ByteString -> String
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -57,10 +57,10 @@ instance Evaluatable Send where
Just sel -> subtermValue sel
Nothing -> variable (name "call")
func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
call func (map subtermValue sendArgs) -- TODO pass through sendBlock
Rval <$> call func (map subtermValue sendArgs) -- TODO pass through sendBlock
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
@ -75,7 +75,7 @@ instance Evaluatable Require where
traceResolve name path
(importedEnv, v) <- isolate (doRequire path)
modifyEnv (`mergeNewer` importedEnv)
pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
doRequire :: ( AbstractValue location value effects
, Member (Modules location value) effects
@ -90,7 +90,7 @@ doRequire path = do
newtype Load a = Load { loadArgs :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Load where liftEq = genericLiftEq
instance Ord1 Load where liftCompare = genericLiftCompare
@ -101,11 +101,11 @@ instance ToJSONFields1 Load
instance Evaluatable Load where
eval (Load [x]) = do
path <- subtermValue x >>= asString
doLoad path False
Rval <$> doLoad path False
eval (Load [x, wrap]) = do
path <- subtermValue x >>= asString
shouldWrap <- subtermValue wrap >>= asBool
doLoad path shouldWrap
Rval <$> doLoad path shouldWrap
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
doLoad :: ( AbstractValue location value effects
@ -129,7 +129,7 @@ doLoad path shouldWrap = do
-- TODO: autoload
data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Class
@ -144,11 +144,11 @@ instance Evaluatable Class where
eval Class{..} = do
super <- traverse subtermValue classSuperClass
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
letrec' name $ \addr ->
subtermValue classBody <* makeNamespace name addr super
Rval <$> letrec' name (\addr ->
subtermValue classBody <* makeNamespace name addr super)
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -159,19 +159,19 @@ instance ToJSONFields1 Module
instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr Nothing
Rval <$> letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
data LowPrecedenceBoolean a
= LowAnd !a !a
| LowOr !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 LowPrecedenceBoolean
instance Evaluatable LowPrecedenceBoolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval = go . fmap subtermValue where
eval t = Rval <$> go (fmap subtermValue t) where
go (LowAnd a b) = do
cond <- a
ifthenelse cond b (pure cond)

View File

@ -17,10 +17,10 @@ import Prologue
import System.FilePath.Posix
data Relative = Relative | NonRelative
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative }
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
importPath :: ByteString -> ImportPath
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path)
@ -140,7 +140,7 @@ evalRequire modulePath alias = letrec' alias $ \addr -> do
unit
data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Import
@ -153,14 +153,14 @@ instance Evaluatable Import where
eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
modifyEnv (mergeEnvs (renamed importedEnv)) *> unit
modifyEnv (mergeEnvs (renamed importedEnv)) *> (Rval <$> unit)
where
renamed importedEnv
| Prologue.null symbols = importedEnv
| otherwise = Env.overwrite symbols importedEnv
data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JavaScriptRequire where liftEq = genericLiftEq
instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
@ -172,11 +172,11 @@ instance Evaluatable JavaScriptRequire where
eval (JavaScriptRequire aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
evalRequire modulePath alias
Rval <$> evalRequire modulePath alias
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
@ -188,10 +188,10 @@ instance Evaluatable QualifiedAliasedImport where
eval (QualifiedAliasedImport aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
evalRequire modulePath alias
Rval <$> evalRequire modulePath alias
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 SideEffectImport where liftEq = genericLiftEq
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@ -203,12 +203,12 @@ instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
void $ isolate (require modulePath)
unit
Rval <$> unit
-- | Qualified Export declarations
newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedExport where liftEq = genericLiftEq
instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
@ -221,12 +221,12 @@ instance Evaluatable QualifiedExport where
-- Insert the aliases with no addresses.
for_ exportSymbols $ \(name, alias) ->
addExport name alias Nothing
unit
Rval <$> unit
-- | Qualified Export declarations that export from another module.
data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![(Name, Name)]}
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
@ -242,10 +242,10 @@ instance Evaluatable QualifiedExportFrom where
for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
unit
Rval <$> unit
newtype DefaultExport a = DefaultExport { defaultExport :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 DefaultExport
@ -263,12 +263,12 @@ instance Evaluatable DefaultExport where
addExport name name Nothing
void $ modifyEnv (Env.insert name addr)
Nothing -> throwEvalError DefaultExportError
unit
Rval <$> unit
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 LookupType
@ -279,7 +279,7 @@ instance Evaluatable LookupType
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ShorthandPropertyIdentifier
@ -289,7 +289,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow
instance Evaluatable ShorthandPropertyIdentifier
data Union a = Union { _unionLeft :: !a, _unionRight :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Language.TypeScript.Syntax.Union
@ -299,7 +299,7 @@ instance Show1 Language.TypeScript.Syntax.Union where liftShowsPrec = genericLif
instance Evaluatable Language.TypeScript.Syntax.Union
data Intersection a = Intersection { _intersectionLeft :: !a, _intersectionRight :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Intersection
@ -309,7 +309,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Intersection
data FunctionType a = FunctionType { _functionTypeParameters :: !a, _functionFormalParameters :: ![a], _functionType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 FunctionType
@ -319,7 +319,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FunctionType
data AmbientFunction a = AmbientFunction { _ambientFunctionContext :: ![a], _ambientFunctionIdentifier :: !a, _ambientFunctionParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 AmbientFunction
@ -329,7 +329,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientFunction
data ImportRequireClause a = ImportRequireClause { _importRequireIdentifier :: !a, _importRequireSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ImportRequireClause
@ -339,7 +339,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportRequireClause
newtype ImportClause a = ImportClause { _importClauseElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ImportClause
@ -349,7 +349,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportClause
newtype Tuple a = Tuple { _tupleElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Tuple
@ -361,7 +361,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple
data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Language.TypeScript.Syntax.Constructor
@ -371,7 +371,7 @@ instance Show1 Language.TypeScript.Syntax.Constructor where liftShowsPrec = gene
instance Evaluatable Language.TypeScript.Syntax.Constructor
data TypeParameter a = TypeParameter { _typeParameter :: !a, _typeParameterConstraint :: !a, _typeParameterDefaultType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypeParameter
@ -381,7 +381,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeParameter
data TypeAssertion a = TypeAssertion { _typeAssertionParameters :: !a, _typeAssertionExpression :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypeAssertion
@ -391,7 +391,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeAssertion
newtype Annotation a = Annotation { _annotationType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Annotation
@ -401,7 +401,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Annotation
newtype Decorator a = Decorator { _decoratorTerm :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Decorator
@ -411,7 +411,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Decorator
newtype ComputedPropertyName a = ComputedPropertyName a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ComputedPropertyName
@ -421,7 +421,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ComputedPropertyName
newtype Constraint a = Constraint { _constraintType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Constraint
@ -431,7 +431,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Constraint
newtype DefaultType a = DefaultType { _defaultType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 DefaultType
@ -441,7 +441,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DefaultType
newtype ParenthesizedType a = ParenthesizedType { _parenthesizedType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ParenthesizedType
@ -451,7 +451,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ParenthesizedType
newtype PredefinedType a = PredefinedType { _predefinedType :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 PredefinedType
@ -461,7 +461,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PredefinedType
newtype TypeIdentifier a = TypeIdentifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypeIdentifier
@ -471,7 +471,7 @@ instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeIdentifier
data NestedIdentifier a = NestedIdentifier !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 NestedIdentifier
@ -481,7 +481,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedIdentifier
data NestedTypeIdentifier a = NestedTypeIdentifier !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 NestedTypeIdentifier
@ -491,7 +491,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedTypeIdentifier
data GenericType a = GenericType { _genericTypeIdentifier :: !a, _genericTypeArguments :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 GenericType
@ -501,7 +501,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GenericType
data TypePredicate a = TypePredicate { _typePredicateIdentifier :: !a, _typePredicateType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypePredicate
@ -511,7 +511,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypePredicate
newtype ObjectType a = ObjectType { _objectTypeElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ObjectType
@ -521,7 +521,7 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ObjectType
data With a = With { _withExpression :: !a, _withBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 With
@ -531,7 +531,7 @@ instance Show1 With where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable With
newtype AmbientDeclaration a = AmbientDeclaration { _ambientDeclarationBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 AmbientDeclaration
@ -540,10 +540,10 @@ instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientDeclaration where
eval (AmbientDeclaration body) = subtermValue body
eval (AmbientDeclaration body) = subtermRef body
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 EnumDeclaration
@ -556,7 +556,7 @@ instance Declarations a => Declarations (EnumDeclaration a) where
declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
newtype ExtendsClause a = ExtendsClause { _extendsClauses :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ExtendsClause
@ -566,7 +566,7 @@ instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExtendsClause
newtype ArrayType a = ArrayType { _arrayType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ArrayType
@ -576,7 +576,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayType
newtype FlowMaybeType a = FlowMaybeType { _flowMaybeType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 FlowMaybeType
@ -586,7 +586,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FlowMaybeType
newtype TypeQuery a = TypeQuery { _typeQuerySubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypeQuery
@ -596,7 +596,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeQuery
newtype IndexTypeQuery a = IndexTypeQuery { _indexTypeQuerySubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 IndexTypeQuery
@ -606,7 +606,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexTypeQuery
newtype TypeArguments a = TypeArguments { _typeArguments :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 TypeArguments
@ -616,7 +616,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeArguments
newtype ThisType a = ThisType ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ThisType
@ -626,7 +626,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ThisType
newtype ExistentialType a = ExistentialType ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ExistentialType
@ -636,7 +636,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExistentialType
newtype LiteralType a = LiteralType { _literalTypeSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 LiteralType
@ -646,7 +646,7 @@ instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LiteralType
data PropertySignature a = PropertySignature { _modifiers :: ![a], _propertySignaturePropertyName :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 PropertySignature
@ -656,7 +656,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertySignature
data CallSignature a = CallSignature { _callSignatureTypeParameters :: !a, _callSignatureParameters :: ![a], _callSignatureType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 CallSignature
@ -667,7 +667,7 @@ instance Evaluatable CallSignature
-- | Todo: Move type params and type to context
data ConstructSignature a = ConstructSignature { _constructSignatureTypeParameters :: !a, _constructSignatureParameters :: ![a], _constructSignatureType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ConstructSignature
@ -677,7 +677,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructSignature
data IndexSignature a = IndexSignature { _indexSignatureSubject :: a, _indexSignatureType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 IndexSignature
@ -687,7 +687,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexSignature
data AbstractMethodSignature a = AbstractMethodSignature { _abstractMethodSignatureContext :: ![a], _abstractMethodSignatureName :: !a, _abstractMethodSignatureParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 AbstractMethodSignature
@ -697,7 +697,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre
instance Evaluatable AbstractMethodSignature
data Debugger a = Debugger
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Debugger
@ -707,7 +707,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Debugger
data ForOf a = ForOf { _forOfBinding :: !a, _forOfSubject :: !a, _forOfBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ForOf
@ -717,7 +717,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ForOf
data This a = This
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 This
@ -727,7 +727,7 @@ instance Show1 This where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable This
data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: !a, _labeledStatementSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 LabeledStatement
@ -737,7 +737,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LabeledStatement
newtype Update a = Update { _updateSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Update
@ -747,7 +747,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -758,13 +758,13 @@ instance ToJSONFields1 Module
instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr Nothing
Rval <$> letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InternalModule where liftEq = genericLiftEq
instance Ord1 InternalModule where liftCompare = genericLiftCompare
@ -775,15 +775,15 @@ instance ToJSONFields1 InternalModule
instance Evaluatable InternalModule where
eval (InternalModule iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr Nothing
Rval <$> letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
instance Declarations a => Declarations (InternalModule a) where
declaredName InternalModule{..} = declaredName internalModuleIdentifier
data ImportAlias a = ImportAlias { _importAliasSubject :: !a, _importAlias :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ImportAlias
@ -793,7 +793,7 @@ instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportAlias
data Super a = Super
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Super
@ -803,7 +803,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Super
data Undefined a = Undefined
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 Undefined
@ -813,7 +813,7 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Undefined
data ClassHeritage a = ClassHeritage { _classHeritageExtendsClause :: !a, _implementsClause :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ClassHeritage
@ -823,7 +823,7 @@ instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassHeritage
data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, _abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AbstractClass where liftEq = genericLiftEq
instance Ord1 AbstractClass where liftCompare = genericLiftCompare
@ -841,11 +841,11 @@ instance Evaluatable AbstractClass where
void $ subtermValue classBody
classEnv <- Env.head <$> getEnv
klass name supers classEnv
v <$ modifyEnv (Env.insert name addr)
Rval <$> (v <$ modifyEnv (Env.insert name addr))
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxElement
@ -855,7 +855,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxElement
newtype JsxText a = JsxText ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxText
@ -865,7 +865,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxText
newtype JsxExpression a = JsxExpression { _jsxExpression :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxExpression
@ -875,7 +875,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxExpression
data JsxOpeningElement a = JsxOpeningElement { _jsxOpeningElementIdentifier :: !a, _jsxAttributes :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxOpeningElement
@ -885,7 +885,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxOpeningElement
newtype JsxClosingElement a = JsxClosingElement { _jsxClosingElementIdentifier :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxClosingElement
@ -895,7 +895,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxClosingElement
data JsxSelfClosingElement a = JsxSelfClosingElement { _jsxSelfClosingElementIdentifier :: !a, _jsxSelfClosingElementAttributes :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxSelfClosingElement
@ -905,7 +905,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxSelfClosingElement
data JsxAttribute a = JsxAttribute { _jsxAttributeTarget :: !a, _jsxAttributeValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxAttribute
@ -915,7 +915,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxAttribute
newtype ImplementsClause a = ImplementsClause { _implementsClauseTypes :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 ImplementsClause
@ -925,7 +925,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImplementsClause
data OptionalParameter a = OptionalParameter { _optionalParameterContext :: ![a], _optionalParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 OptionalParameter
@ -935,7 +935,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable OptionalParameter
data RequiredParameter a = RequiredParameter { _requiredParameterContext :: ![a], _requiredParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 RequiredParameter
@ -945,7 +945,7 @@ instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RequiredParameter
data RestParameter a = RestParameter { _restParameterContext :: ![a], _restParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 RestParameter
@ -955,7 +955,7 @@ instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RestParameter
newtype JsxFragment a = JsxFragment [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxFragment
@ -965,7 +965,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxFragment
data JsxNamespaceName a = JsxNamespaceName a a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance ToJSONFields1 JsxNamespaceName

View File

@ -46,6 +46,7 @@ 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.Mergeable as X (Mergeable)
import Data.Monoid as X (First (..), Last (..), Monoid (..))
import Data.Proxy as X (Proxy (..))

View File

@ -33,22 +33,22 @@ withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (
withSomeTermPair with (SomeTermPair terms) = with terms
withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output)
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
-> [BlobPair]
-> Eff effs output
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
where diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Members '[IO, Task, Telemetry] effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
where diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax, Members '[IO, Task, Telemetry] effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
diffTerms blobs terms = time "diff" languageTag $ do
diff <- diff (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs
withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> BlobPair
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] (Record fields))
withParsedBlobPair decorate blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
= SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
| otherwise = noLanguageForBlob (pathForBlobPair blobs)

View File

@ -120,7 +120,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects a
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
resumingAddressError :: (AbstractHole value, Lower (Cell location value), Member Trace effects, Show location) => Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects a
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of

View File

@ -104,7 +104,7 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields))
decorate algebra = send . Decorate algebra
-- | A task which diffs a pair of terms using the supplied 'Differ' function.
diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2))
diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2))
diff terms = send (Semantic.Task.Diff terms)
-- | A task which renders some input using the supplied 'Renderer' function.
@ -147,7 +147,7 @@ data Task output where
Parse :: Parser term -> Blob -> Task term
Analyze :: (Analysis.TermEvaluator term location value effects a -> result) -> Analysis.TermEvaluator term location value effects a -> Task result
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
Diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
Diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
Render :: Renderer input output -> input -> Task output
Serialize :: Format input -> input -> Task Builder

View File

@ -20,10 +20,10 @@ spec = parallel $ do
let positively = succ . abs
describe "pqGramDecorator" $ do
prop "produces grams with stems of the specified length" $
\ (term, p, q) -> pqGramDecorator constructorNameAndConstantFields (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
\ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
prop "produces grams with bases of the specified width" $
\ (term, p, q) -> pqGramDecorator constructorNameAndConstantFields (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
\ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
describe "rws" $ do
prop "produces correct diffs" $
@ -37,6 +37,6 @@ spec = parallel $ do
let (a, b) = (decorate (termIn Nil (injectSum [ termIn Nil (injectSum (Syntax.Identifier "a")) ])), decorate (termIn Nil (injectSum [ termIn Nil (injectSum (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 constructorNameAndConstantFields
where decorate = defaultFeatureVectorDecorator
diffThese = these deleting inserting replacing

View File

@ -8,6 +8,7 @@ import Data.Bifunctor
import Data.Bifunctor.Join
import Data.Diff
import Data.Functor.Classes
import Data.Hashable.Lifted
import Data.Patch
import Data.Range
import Data.Record
@ -241,6 +242,7 @@ diffWithParser :: ( HasField fields Data.Span.Span
, Diffable syntax
, GAlign syntax
, HasDeclaration syntax
, Hashable1 syntax
, Members '[Distribute WrappedTask, Task] effs
)
=> Parser (Term syntax (Record fields))

View File

@ -11,9 +11,9 @@
(Array
(Identifier))
(
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{-(Integer)-}
{-(Integer)-})))))

View File

@ -11,9 +11,9 @@
(Array
(Identifier))
(
{+(Integer)+}
{ (Integer)
->(Integer) }
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{-(Integer)-}
{-(Integer)-})))))

View File

@ -55,15 +55,11 @@
{+(BXOr
{+(Identifier)+}
{+(Integer)+})+})+}
(Assignment
{ (Identifier)
->(Identifier) }
{ (Times
{-(Identifier)-}
{-(Integer)-})
->(Modulo
{+(Assignment
{+(Identifier)+}
{+(Modulo
{+(Identifier)+}
{+(Integer)+}) })
{+(Integer)+})+})+}
{+(Assignment
{+(Identifier)+}
{+(Not
@ -82,6 +78,11 @@
{+(KeyValue
{+(Identifier)+}
{+(Integer)+})+})+})+})+})+})+}
{-(Assignment
{-(Identifier)-}
{-(Times
{-(Identifier)-}
{-(Integer)-})-})-}
{-(Assignment
{-(Identifier)-}
{-(Plus

View File

@ -33,20 +33,15 @@
->(Identifier) }
{ (Identifier)
->(Identifier) }))
(LessThan
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) })
{+(LessThan
{+(Identifier)+}
{+(Identifier)+})+}
{+(LessThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
{ (LessThanEqual
{-(Identifier)-}
{-(Identifier)-})
->(GreaterThan
{+(GreaterThan
{+(Identifier)+}
{+(Identifier)+}) }
{+(Identifier)+})+}
{+(GreaterThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
@ -83,6 +78,12 @@
{+(BAnd
{+(Identifier)+}
{+(Identifier)+})+}
{-(LessThan
{-(Identifier)-}
{-(Identifier)-})-}
{-(LessThanEqual
{-(Identifier)-}
{-(Identifier)-})-}
{-(GreaterThan
{-(Identifier)-}
{-(Identifier)-})-}

View File

@ -33,11 +33,9 @@
->(Identifier) }
{ (Identifier)
->(Identifier) }))
(LessThan
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) })
{+(LessThan
{+(Identifier)+}
{+(Identifier)+})+}
{+(LessThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
@ -80,6 +78,9 @@
{+(BAnd
{+(Identifier)+}
{+(Identifier)+})+}
{-(LessThan
{-(Identifier)-}
{-(Identifier)-})-}
{-(LessThanEqual
{-(Identifier)-}
{-(Identifier)-})-}

View File

@ -21,14 +21,20 @@
(Identifier)
(Identifier))
(Empty))
(Call
{ (Identifier)
->(Identifier) }
(
(Identifier)
(Variadic
(Identifier)))
(Empty))
{+(Call
{+(Identifier)+}
{+(
{+(Identifier)+}
{+(Variadic
{+(Identifier)+})+})+}
{+(Empty)+})+}
{-(Call
{-(Identifier)-}
{-(
{-(Identifier)-}
{-(Variadic
{-(Identifier)-})-})-}
{-(Empty)-})-}
{-(Call
{-(Identifier)-}
{-([])-}

View File

@ -21,15 +21,19 @@
(Identifier)
(Identifier))
(Empty))
{+(Call
{+(Identifier)+}
{+(
{+(Identifier)+}
{+(Variadic
{+(Identifier)+})+})+}
{+(Empty)+})+}
(Call
{ (Identifier)
->(Identifier) }
(
(Identifier)
(Variadic
(Identifier)))
(Empty))
{+(Call
{+(Identifier)+}
{+([])+}
{+(Empty)+})+})))
{-(
{-(Identifier)-}
{-(Variadic
{-(Identifier)-})-})-}
(Empty)))))

View File

@ -6,38 +6,58 @@
(Identifier)
([])
(
{+(Type
{+(Identifier)+}
{+(BidirectionalChannel
{+(ReceiveChannel
{+(Identifier)+})+})+})+}
{+(Type
{+(Identifier)+}
{+(SendChannel
{+(SendChannel
{+(Constructor
{+(Empty)+}
{+([])+})+})+})+})+}
(Type
{ (Identifier)
->(Identifier) }
(BidirectionalChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
{ (Identifier)
->(Identifier) }
(SendChannel
(SendChannel
(Constructor
(Empty)
([])))))
(Type
{ (Identifier)
->(Identifier) }
(SendChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
(Identifier)
(ReceiveChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
(Identifier)
(BidirectionalChannel
(Parenthesized
(ReceiveChannel
{ (Identifier)
->(Identifier) })))))))
{ (BidirectionalChannel
{-(ReceiveChannel
{-(Identifier)-})-})
->(SendChannel
{+(ReceiveChannel
{+(Identifier)+})+}) })
{+(Type
{+(Identifier)+}
{+(ReceiveChannel
{+(ReceiveChannel
{+(Identifier)+})+})+})+}
{+(Type
{+(Identifier)+}
{+(BidirectionalChannel
{+(Parenthesized
{+(ReceiveChannel
{+(Identifier)+})+})+})+})+}
{-(Type
{-(Identifier)-}
{-(SendChannel
{-(SendChannel
{-(Constructor
{-(Empty)-}
{-([])-})-})-})-})-}
{-(Type
{-(Identifier)-}
{-(SendChannel
{-(ReceiveChannel
{-(Identifier)-})-})-})-}
{-(Type
{-(Identifier)-}
{-(ReceiveChannel
{-(ReceiveChannel
{-(Identifier)-})-})-})-}
{-(Type
{-(Identifier)-}
{-(BidirectionalChannel
{-(Parenthesized
{-(ReceiveChannel
{-(Identifier)-})-})-})-})-})))

View File

@ -6,38 +6,59 @@
(Identifier)
([])
(
(Type
{ (Identifier)
->(Identifier) }
(BidirectionalChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
{ (Identifier)
->(Identifier) }
(SendChannel
(SendChannel
(Constructor
(Empty)
([])))))
(Type
{ (Identifier)
->(Identifier) }
(SendChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
(Identifier)
(ReceiveChannel
(ReceiveChannel
{ (Identifier)
->(Identifier) })))
(Type
(Identifier)
(BidirectionalChannel
(Parenthesized
(ReceiveChannel
{ (Identifier)
->(Identifier) })))))))
{+(Type
{+(Identifier)+}
{+(BidirectionalChannel
{+(ReceiveChannel
{+(Identifier)+})+})+})+}
{+(Type
{+(Identifier)+}
{+(SendChannel
{+(SendChannel
{+(Constructor
{+(Empty)+}
{+([])+})+})+})+})+}
{+(Type
{+(Identifier)+}
{+(SendChannel
{+(ReceiveChannel
{+(Identifier)+})+})+})+}
{+(Type
{+(Identifier)+}
{+(ReceiveChannel
{+(ReceiveChannel
{+(Identifier)+})+})+})+}
{+(Type
{+(Identifier)+}
{+(BidirectionalChannel
{+(Parenthesized
{+(ReceiveChannel
{+(Identifier)+})+})+})+})+}
{-(Type
{-(Identifier)-}
{-(BidirectionalChannel
{-(ReceiveChannel
{-(Identifier)-})-})-})-}
{-(Type
{-(Identifier)-}
{-(SendChannel
{-(SendChannel
{-(Constructor
{-(Empty)-}
{-([])-})-})-})-})-}
{-(Type
{-(Identifier)-}
{-(SendChannel
{-(ReceiveChannel
{-(Identifier)-})-})-})-}
{-(Type
{-(Identifier)-}
{-(ReceiveChannel
{-(ReceiveChannel
{-(Identifier)-})-})-})-}
{-(Type
{-(Identifier)-}
{-(BidirectionalChannel
{-(Parenthesized
{-(ReceiveChannel
{-(Identifier)-})-})-})-})-})))

View File

@ -14,10 +14,12 @@
->(Identifier) }
{ (Identifier)
->([]) })
(Assignment
{ (Identifier)
->(Identifier) }
([]))
{+(Assignment
{+(Identifier)+}
{+([])+})+}
{-(Assignment
{-(Identifier)-}
{-([])-})-}
{-(Assignment
{-(Identifier)-}
{-([])-})-})))

View File

@ -6,10 +6,10 @@
{+(Identifier)+})+}
{+(Import
{+(TextElement)+})+}
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
{+(QualifiedImport
{+(Identifier)+})+}
{-(QualifiedImport
{-(Identifier)-})-}
{-(Import
{-(TextElement)-})-}
{-(QualifiedImport

View File

@ -6,10 +6,10 @@
{+(Identifier)+})+}
{+(Import
{+(TextElement)+})+}
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
{+(QualifiedImport
{+(Identifier)+})+}
{-(QualifiedImport
{-(Identifier)-})-}
{-(Import
{-(TextElement)-})-}
{-(QualifiedImport

View File

@ -1,18 +1,18 @@
(Program
(Package
(Identifier))
{+(QualifiedImport
{+(Identifier)+})+}
{+(Import
{+(TextElement)+})+}
{+(QualifiedImport
{+(Identifier)+})+}
{-(QualifiedImport
{-(Identifier)-})-}
{-(Import
{-(TextElement)-})-}
{-(QualifiedImport
{-(Identifier)-})-}
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
{ (Import
{-(TextElement)-})
->(Import
{+(TextElement)+}) }
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
(Function
(Empty)
(Identifier)

View File

@ -1,18 +1,18 @@
(Program
(Package
(Identifier))
{+(QualifiedImport
{+(Identifier)+})+}
{+(Import
{+(TextElement)+})+}
{+(QualifiedImport
{+(Identifier)+})+}
{-(QualifiedImport
{-(Identifier)-})-}
{-(Import
{-(TextElement)-})-}
{-(QualifiedImport
{-(Identifier)-})-}
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
{ (Import
{-(TextElement)-})
->(Import
{+(TextElement)+}) }
{ (QualifiedImport
{-(Identifier)-})
->(QualifiedImport
{+(Identifier)+}) }
(Function
(Empty)
(Identifier)

View File

@ -6,50 +6,36 @@
(Identifier)
([])
(
{+(Slice
{+(Identifier)+}
{+(Integer)+}
{+(Empty)+}
{+(Empty)+})+}
(Slice
{ (Identifier)
->(Identifier) }
(Identifier)
{ (Integer)
->(Empty) }
->(Integer) }
(Empty)
(Empty))
(Slice
(Identifier)
(Empty)
{ (Integer)
->(Integer) }
(Empty))
(Slice
(Identifier)
{ (Empty)
->(Integer) }
{ (Empty)
->(Integer) }
(Empty))
{+(Slice
{+(Identifier)+}
{+(Integer)+}
{+(Integer)+}
{+(Empty)+})+}
(Slice
{ (Identifier)
->(Identifier) }
{ (Empty)
(Identifier)
{ (Integer)
->(Integer) }
{ (Integer)
->(Integer) }
{ (Empty)
{ (Integer)
->(Integer) })
{+(Slice
{+(Identifier)+}
{+(Integer)+}
{+(Integer)+}
{+(Empty)+})+}
{-(Slice
{-(Identifier)-}
{-(Empty)-}
{-(Empty)-}
{-(Empty)-})-}
{-(Slice
{-(Identifier)-}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-})-}
{-(Slice
{-(Identifier)-}
{-(Integer)-}
{-(Integer)-}
{-(Empty)-})-})))
(Slice
{ (Identifier)
->(Identifier) }
(Integer)
(Integer)
(Empty)))))

View File

@ -6,51 +6,36 @@
(Identifier)
([])
(
{+(Slice
{+(Identifier)+}
{+(Integer)+}
{+(Empty)+}
{+(Empty)+})+}
{+(Slice
{+(Identifier)+}
{+(Empty)+}
{+(Integer)+}
{+(Empty)+})+}
{+(Slice
{+(Identifier)+}
{+(Empty)+}
{+(Empty)+}
{+(Empty)+})+}
(Slice
(Identifier)
{ (Integer)
->(Integer) }
(Empty)
(Empty))
(Slice
(Identifier)
(Empty)
{ (Integer)
->(Integer) }
(Empty))
(Slice
(Identifier)
{ (Integer)
->(Empty) }
{ (Integer)
->(Empty) }
(Empty))
(Slice
(Identifier)
{ (Integer)
->(Integer) }
{ (Integer)
->(Integer) }
{ (Integer)
->(Integer) })
(Slice
{ (Identifier)
->(Identifier) }
(Integer)
{ (Empty)
->(Integer) }
{ (Empty)
->(Integer) })
{+(Slice
{+(Identifier)+}
{+(Integer)+}
{+(Integer)+}
{+(Empty)+})+}
{-(Slice
{-(Identifier)-}
{-(Empty)-}
{-(Integer)-}
{-(Empty)-})-}
{-(Slice
{-(Identifier)-}
{-(Integer)-}
{-(Integer)-}
{-(Empty)-})-}
{-(Slice
{-(Identifier)-}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-})-}
{-(Slice
{-(Identifier)-}
{-(Integer)-}
{-(Integer)-}
{-(Empty)-})-})))
(Integer)
(Empty)))))

View File

@ -18,27 +18,39 @@
(Identifier)
([])
(Empty)))
(Pattern
(LessThan
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) })
{+(Pattern
{+(LessThan
{+(Identifier)+}
{+(Identifier)+})+}
{+(Call
{+(Identifier)+}
{+([])+}
{+(Empty)+})+})+}
{+(Pattern
{+(Equal
{+(Identifier)+}
{+(Integer)+})+}
{+(Call
{+(Identifier)+}
{+([])+}
{+(Empty)+})+})+}
{-(Pattern
{-(LessThan
{-(Identifier)-}
{-(Identifier)-})-}
{-(Context
{-(Comment)-}
(Call
(Identifier)
([])
(Empty)))-})
{-(Call
{-(Identifier)-}
{-([])-}
{-(Empty)-})-})-})-}
{-(Context
{-(Comment)-}
(Pattern
(Equal
{ (Identifier)
->(Identifier) }
(Integer))
(Call
{ (Identifier)
->(Identifier) }
([])
(Empty))))-}))))
{-(Pattern
{-(Equal
{-(Identifier)-}
{-(Integer)-})-}
{-(Call
{-(Identifier)-}
{-([])-}
{-(Empty)-})-})-})-}))))

View File

@ -18,27 +18,35 @@
(Identifier)
([])
(Empty)))
(Pattern
(LessThan
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) })
{+(Pattern
{+(LessThan
{+(Identifier)+}
{+(Identifier)+})+}
{+(Context
{+(Comment)+}
(Call
(Identifier)
([])
(Empty)))+})
{+(Call
{+(Identifier)+}
{+([])+}
{+(Empty)+})+})+})+}
{+(Context
{+(Comment)+}
(Pattern
(Equal
{ (Identifier)
->(Identifier) }
(Integer))
{ (LessThan
{-(Identifier)-}
{-(Identifier)-})
->(Equal
{+(Identifier)+}
{+(Integer)+}) }
(Call
{ (Identifier)
->(Identifier) }
([])
(Empty))))+}))))
(Empty))))+}
{-(Pattern
{-(Equal
{-(Identifier)-}
{-(Integer)-})-}
{-(Call
{-(Identifier)-}
{-([])-}
{-(Empty)-})-})-}))))

View File

@ -35,15 +35,15 @@
(Identifier)
{ (Empty)
->(Identifier) })
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}
(Assignment
(Empty)
{ (Identifier)
->(Identifier) }
(Empty))
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}))
(Empty))))
(DefaultExport
{ (Identifier)
->(Identifier) })

View File

@ -35,11 +35,14 @@
(Identifier)
{ (Identifier)
->(Empty) })
(Assignment
(Empty)
{ (Identifier)
->(Identifier) }
(Empty))
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}
{-(Assignment
{-(Empty)-}
{-(Identifier)-}
{-(Empty)-})-}
{-(Assignment
{-(Empty)-}
{-(Identifier)-}

View File

@ -2,10 +2,10 @@
{+(Import)+}
{+(QualifiedAliasedImport
{+(Identifier)+})+}
{+(Import)+}
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(Import)+}
{+(
{+(Import)+}
{+(Import)+})+}

View File

@ -4,8 +4,7 @@
{+(Identifier)+})+}
{+(Import)+}
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(
{+(Import)+}
{+(Import)+})+}
@ -14,6 +13,7 @@
{+(QualifiedAliasedImport
{+(Identifier)+})+})+}
{+(SideEffectImport)+}
{-(Import)-}
{-(QualifiedAliasedImport
{-(Identifier)-})-}
{-(Import)-}

View File

@ -7,21 +7,21 @@
->(RShift
{+(Identifier)+}
{+(Integer)+}) })
(Assignment
{ (Identifier)
->(Identifier) }
{ (RShift
{-(Identifier)-}
{-(Integer)-})
->(DividedBy
{+(Assignment
{+(Identifier)+}
{+(DividedBy
{+(Identifier)+}
{+(Integer)+}) })
{+(Integer)+})+})+}
(Assignment
{ (Identifier)
->(Identifier) }
{ (DividedBy
(Identifier)
{ (RShift
{-(Identifier)-}
{-(Integer)-})
->(Plus
{+(Identifier)+}
{+(Integer)+}) }))
{+(Integer)+}) })
{-(Assignment
{-(Identifier)-}
{-(DividedBy
{-(Identifier)-}
{-(Integer)-})-})-})

View File

@ -7,21 +7,20 @@
->(Plus
{+(Identifier)+}
{+(Integer)+}) })
{+(Assignment
{+(Identifier)+}
{+(RShift
{+(Identifier)+}
{+(Integer)+})+})+}
(Assignment
{ (Identifier)
->(Identifier) }
{ (DividedBy
(DividedBy
{ (Identifier)
->(Identifier) }
(Integer)))
{-(Assignment
{-(Identifier)-}
{-(Plus
{-(Identifier)-}
{-(Integer)-})
->(RShift
{+(Identifier)+}
{+(Integer)+}) })
(Assignment
{ (Identifier)
->(Identifier) }
{ (Plus
{-(Identifier)-}
{-(Integer)-})
->(DividedBy
{+(Identifier)+}
{+(Integer)+}) }))
{-(Integer)-})-})-})

View File

@ -5,38 +5,40 @@
{+(LessThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
{+(Not
{+(Equal
{+(Identifier)+}
{+(Identifier)+})+})+}
{+(GreaterThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
{+(GreaterThan
{+(Identifier)+}
{+(Identifier)+})+}
(Not
(Equal
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) }))
{+(GreaterThanEqual
{+(Identifier)+}
{+(Identifier)+})+}
{+(GreaterThan
{+(Identifier)+}
{+(Identifier)+})+}
{+(Not
{+(Equal
{+(Identifier)+}
{+(Identifier)+})+})+}
{+(Member
{+(Identifier)+}
{+(Identifier)+})+}
{+(Equal
{+(Identifier)+}
{+(Identifier)+})+}
(Not
(Member
{ (Identifier)
->(Identifier) }
{ (Identifier)
->(Identifier) }))
{+(Not
{+(Member
{+(Identifier)+}
{+(Identifier)+})+})+}
{+(Not
{+(Equal
{+(Identifier)+}
{+(Identifier)+})+})+}
{-(Not
{-(Member
{-(Identifier)-}
{-(Identifier)-})-})-}
{-(Equal
{-(Identifier)-}
{-(Identifier)-})-}

View File

@ -1,21 +1,28 @@
(Program
{+(Call
{+(Identifier)+}
{+(TextElement)+}
{+(Identifier)+}
{+(Empty)+})+}
{+(Call
{+(Identifier)+}
{+(TextElement)+}
{+(Identifier)+}
{+(Identifier)+}
{+(Empty)+})+}
(Call
(Identifier)
{ (TextElement)
->(TextElement) }
{+(Identifier)+}
(Empty))
(Call
(Identifier)
(TextElement)
{+(Identifier)+}
{+(Identifier)+}
{-(Call
{-(Identifier)-}
{-(TextElement)-}
{-(Null)-}
(Empty))
(Call
(Identifier)
{ (TextElement)
->(TextElement) }
{-(Empty)-})-}
{-(Call
{-(Identifier)-}
{-(TextElement)-}
{-(Identifier)-}
{-(Identifier)-}
(Empty)))
{-(Empty)-})-})

View File

@ -1,21 +1,22 @@
(Program
(Call
(Identifier)
{ (TextElement)
->(TextElement) }
{-(Identifier)-}
(Empty))
{+(Call
{+(Identifier)+}
{+(TextElement)+}
{+(Empty)+})+}
(Call
(Identifier)
(TextElement)
{+(Null)+}
{-(Identifier)-}
{-(Identifier)-}
(Empty))
(Call
(Identifier)
{ (TextElement)
->(TextElement) }
(TextElement)
{+(Identifier)+}
{+(Identifier)+}
(Empty)))
(Identifier)
{-(Identifier)-}
(Empty))
{-(Call
{-(Identifier)-}
{-(TextElement)-}
{-(Empty)-})-})

View File

@ -6,14 +6,14 @@
->(Float) }
{+(Float)+}
{+(Float)+}
{+(Float)+}
{+(Float)+}
{ (Float)
->(Float) }
{+(Float)+}
{+(Float)+}
{ (Float)
->(Float) }
{+(Float)+}
{+(Float)+}
{+(Float)+}
{-(Float)-}
{-(Float)-}
{-(Float)-}
{-(Float)-}

View File

@ -9,10 +9,10 @@
{+(Float)+}
{+(Float)+}
{+(Float)+}
{ (Float)
->(Float) }
{+(Float)+}
{+(Float)+}
{+(Float)+}
{-(Float)-}
{-(Float)-}
{-(Float)-}
{-(Float)-}

View File

@ -1,12 +1,12 @@
(Program
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(Import)+}
{+(Import)+}
{+(Import)+}
{+(Import)+}
{-(Import)-}
{-(Import)-}
{ (Import)
->(Import) }
{-(Import)-}
{-(Import)-}
{-(Import)-})

View File

@ -1,10 +1,10 @@
(Program
{+(Import)+}
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(Import)+}
{+(Import)+}
{-(Import)-}
{-(Import)-}
{-(Import)-}

View File

@ -15,9 +15,9 @@
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{-(Integer)-}
{-(Negate
{-(Integer)-})-}
{-(Integer)-}

View File

@ -5,15 +5,15 @@
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{+(Negate
{+(Integer)+})+}
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}

View File

@ -2,12 +2,12 @@
{+(TextElement)+}
(TextElement)
{+(TextElement)+}
{+(TextElement)+}
{ (TextElement)
->(TextElement) }
{ (TextElement)
->(TextElement) }
{+(TextElement)+}
{ (TextElement)
->(TextElement) }
{+(TextElement)+}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}

View File

@ -2,13 +2,13 @@
{-(TextElement)-}
(TextElement)
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{ (TextElement)
->(TextElement) }
{+(TextElement)+}
{+(TextElement)+}
{ (TextElement)
->(TextElement) }
{-(TextElement)-}
{+(TextElement)+}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}

View File

@ -1,14 +1,11 @@
(Program
{+(Tuple
{+(Identifier)+}
{+(Identifier)+}
{+(Identifier)+})+}
(Tuple
{-(Identifier)-}
(Identifier)
{+(Identifier)+}
{+(Identifier)+})
{+(Identifier)+}
{-(Tuple
(Tuple
{-(Identifier)-}
{-(Identifier)-}
{-(Identifier)-})-})
(Identifier)
(Identifier))
{+(Identifier)+})

View File

@ -1,13 +1,11 @@
(Program
{+(Tuple
{+(Identifier)+}
{+(Identifier)+})+}
(Tuple
{-(Identifier)-}
{-(Identifier)-}
(Identifier)
{+(Identifier)+})
(Tuple
{+(Identifier)+}
(Identifier)
(Identifier)
{-(Identifier)-})
{-(Tuple
{-(Identifier)-}
{-(Identifier)-})-}
(Identifier))
{-(Identifier)-})

View File

@ -9,16 +9,16 @@
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+}) }
{ (RShift
{-(Send
{-(Identifier)-})-}
{-(Send
{-(Identifier)-})-})
->(LShift
{+(LShift
{+(Send
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+}) }
{+(Identifier)+})+})+}
{-(RShift
{-(Send
{-(Identifier)-})-}
{-(Send
{-(Identifier)-})-})-}
{-(BXOr
{-(Send
{-(Identifier)-})-}

View File

@ -9,18 +9,18 @@
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+}) }
{ (LShift
{-(Send
{-(Identifier)-})-}
{-(Send
{-(Identifier)-})-})
->(RShift
{+(RShift
{+(Send
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+}) }
{+(Identifier)+})+})+}
{+(BXOr
{+(Send
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+})+})
{+(Identifier)+})+})+}
{-(LShift
{-(Send
{-(Identifier)-})-}
{-(Send
{-(Identifier)-})-})-})

View File

@ -1,11 +1,11 @@
(Program
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{ (TextElement)
->(TextElement) }
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}

View File

@ -7,34 +7,33 @@
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+})+}
{+(ForEach
{+(
{+(Send
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+})+}
{+(Send
{+(Identifier)+})+}
{+(Send
{+(Identifier)+})+})+}
(ForEach
(
(Send
{ (Identifier)
->(Identifier) }))
->(Identifier) })
{+(Send
{+(Identifier)+})+})
{ (Array
{-(Integer)-}
{-(Integer)-}
{-(Integer)-})
->(Enumeration
{+(Integer)+}
{+(Integer)+}
{+(Empty)+}) }
{ (Send
{-(Identifier)-}
->(Send
{+(Identifier)+}) }
(Send
{ (Identifier)
->(Identifier) }
{-(Send
{-(Identifier)-})-})
->(Boolean) })
{-(Identifier)-})-}))
{+(ForEach
{+(
{+(Send
{+(Identifier)+})+})+}
{+(Enumeration
{+(Integer)+}
{+(Integer)+}
{+(Empty)+})+}
{+(Boolean)+})+}
{+(ForEach
{+(
{+(Send

View File

@ -1,20 +1,23 @@
(Program
(Hash
(KeyValue
{ (Symbol)
->(Symbol) }
{ (TextElement)
->(TextElement) })
(KeyValue
{ (Symbol)
->(Symbol) }
{ (Integer)
->(Integer) })
(KeyValue
{ (TextElement)
->(Symbol) }
{ (Boolean)
->(Boolean) })
{+(KeyValue
{+(Symbol)+}
{+(TextElement)+})+}
{+(KeyValue
{+(Symbol)+}
{+(Integer)+})+}
{+(KeyValue
{+(Symbol)+}
{+(Boolean)+})+}
{-(KeyValue
{-(Symbol)-}
{-(TextElement)-})-}
{-(KeyValue
{-(Symbol)-}
{-(Integer)-})-}
{-(KeyValue
{-(TextElement)-}
{-(Boolean)-})-}
{-(KeyValue
{-(Symbol)-}
{-(Integer)-})-})

View File

@ -1,23 +1,25 @@
(Program
(Hash
{+(KeyValue
{+(Symbol)+}
{+(TextElement)+})+}
{+(KeyValue
{+(Symbol)+}
{+(Integer)+})+}
{+(KeyValue
{+(TextElement)+}
{+(Boolean)+})+}
(KeyValue
{ (Symbol)
->(Symbol) }
{ (TextElement)
->(TextElement) })
(KeyValue
{ (Symbol)
->(Symbol) }
{ (Integer)
->(Integer) })
(KeyValue
{ (Symbol)
->(TextElement) }
{ (Boolean)
->(Boolean) })
{+(KeyValue
{+(Symbol)+}
{+(Integer)+})+})
{-(KeyValue
{-(Symbol)-}
{-(Integer)-})-}
{-(KeyValue
{-(Symbol)-}
{-(Boolean)-})-})
{+(Hash)+}
{+(Hash
{+(Context

View File

@ -1,12 +1,12 @@
(Program
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Float)+}
{-(Integer)-}
{-(Integer)-}

View File

@ -3,13 +3,13 @@
{+(Integer)+}
{+(Integer)+}
{+(Integer)+}
{ (Integer)
->(Integer) }
{ (Integer)
->(Integer) }
{+(Integer)+}
{+(Integer)+}
{+(Float)+}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-}
{-(Integer)-}
{-(Float)-})

View File

@ -1,7 +1,7 @@
(Program
{+(Symbol)+}
{ (Symbol)
->(Symbol) }
{+(Symbol)+}
{-(Symbol)-}
{-(Symbol)-})
{ (Symbol)
->(Symbol) }
{ (Symbol)
->(Symbol) })

View File

@ -1,7 +1,7 @@
(Program
{+(Symbol)+}
{ (Symbol)
->(Symbol) }
{ (Symbol)
->(Symbol) }
{-(Symbol)-})
{ (Symbol)
->(Symbol) })

View File

@ -35,15 +35,15 @@
(Identifier)
{ (Empty)
->(Identifier) })
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}
(Assignment
(Empty)
{ (Identifier)
->(Identifier) }
(Empty))
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}))
(Empty))))
(DefaultExport
{ (Identifier)
->(Identifier) })

View File

@ -35,11 +35,14 @@
(Identifier)
{ (Identifier)
->(Empty) })
(Assignment
(Empty)
{ (Identifier)
->(Identifier) }
(Empty))
{+(Assignment
{+(Empty)+}
{+(Identifier)+}
{+(Empty)+})+}
{-(Assignment
{-(Empty)-}
{-(Identifier)-}
{-(Empty)-})-}
{-(Assignment
{-(Empty)-}
{-(Identifier)-}

View File

@ -2,10 +2,10 @@
{+(Import)+}
{+(QualifiedAliasedImport
{+(Identifier)+})+}
{+(Import)+}
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(Import)+}
{+(
{+(Import)+}
{+(Import)+})+}

View File

@ -4,8 +4,7 @@
{+(Identifier)+})+}
{+(Import)+}
{+(Import)+}
{ (Import)
->(Import) }
{+(Import)+}
{+(
{+(Import)+}
{+(Import)+})+}
@ -14,10 +13,11 @@
{+(QualifiedAliasedImport
{+(Identifier)+})+})+}
{+(SideEffectImport)+}
{ (QualifiedAliasedImport
{-(Identifier)-})
->(QualifiedAliasedImport
{+(Identifier)+}) }
{+(QualifiedAliasedImport
{+(Identifier)+})+}
{-(Import)-}
{-(QualifiedAliasedImport
{-(Identifier)-})-}
{-(Import)-}
{-(Import)-}
{-(Import)-}

2
vendor/fastsum vendored

@ -1 +1 @@
Subproject commit 10c717b8e081fbb1fc843c5888fb0d0f86472bef
Subproject commit 4a8f1359233bbb2bea7a0eee478c28d0184ebe6d