mirror of
https://github.com/github/semantic.git
synced 2024-11-24 17:04:47 +03:00
Merge remote-tracking branch 'origin/upgrade-to-fused-effects-0.5' into scope-safety
This commit is contained in:
Rob Rix
commit
366a53bec4
@ -5,6 +5,11 @@ jobs: $ncpus
|
||||
package semantic
|
||||
ghc-options: +RTS -A128m -n2m -RTS
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/fused-effects/fused-effects-exceptions.git
|
||||
tag: 57b1dc8b5deadbe741ce22398d836a14dbba7577
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/joshvera/proto3-suite.git
|
||||
|
||||
@ -55,8 +55,8 @@ common dependencies
|
||||
, fastsum ^>= 0.1.1.0
|
||||
, filepath ^>= 1.4.2.1
|
||||
, free ^>= 5.1
|
||||
, fused-effects-exceptions ^>= 0.1.1.0
|
||||
, fused-effects ^>= 0.5
|
||||
, fused-effects ^>= 0.5.0.0
|
||||
, fused-effects-exceptions ^>= 0.2.0.0
|
||||
, hashable ^>= 1.2.7.0
|
||||
, tree-sitter ^>= 0.1.0.0
|
||||
, mtl ^>= 2.2.2
|
||||
|
||||
@ -150,14 +150,14 @@ graphingModuleInfo recur m = do
|
||||
_ -> pure ()
|
||||
|
||||
eavesdrop :: Evaluator term address value (EavesdropC address value m) a
|
||||
-> (forall x . Modules address value m (m x) -> Evaluator term address value m ())
|
||||
-> (forall x . Modules address value m x -> Evaluator term address value m ())
|
||||
-> Evaluator term address value m a
|
||||
eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f)) m
|
||||
|
||||
newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a)
|
||||
deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m (m x) -> m ()) m)
|
||||
newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m x -> m ()) -> m a)
|
||||
deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m x -> m ()) m)
|
||||
|
||||
runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a
|
||||
runEavesdropC :: (forall x . Modules address value m x -> m ()) -> EavesdropC address value m a -> m a
|
||||
runEavesdropC f (EavesdropC m) = m f
|
||||
|
||||
instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where
|
||||
|
||||
@ -418,9 +418,9 @@ reachable roots heap = go mempty roots
|
||||
-- Effects
|
||||
|
||||
data Deref value (m :: * -> *) k
|
||||
= DerefCell (Set value) (Maybe value -> k)
|
||||
| AssignCell value (Set value) (Set value -> k)
|
||||
deriving stock Functor
|
||||
= DerefCell (Set value) (Maybe value -> m k)
|
||||
| AssignCell value (Set value) (Set value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runDeref :: Evaluator term address value (DerefC address value m) a
|
||||
|
||||
@ -60,17 +60,17 @@ load path = sendModules (Load path pure)
|
||||
|
||||
|
||||
data Modules address value (m :: * -> *) k
|
||||
= Load ModulePath (ModuleResult address value -> k)
|
||||
| Lookup ModulePath (Maybe (ModuleResult address value) -> k)
|
||||
| Resolve [FilePath] (Maybe ModulePath -> k)
|
||||
| List FilePath ([ModulePath] -> k)
|
||||
deriving stock Functor
|
||||
= Load ModulePath (ModuleResult address value -> m k)
|
||||
| Lookup ModulePath (Maybe (ModuleResult address value) -> m k)
|
||||
| Resolve [FilePath] (Maybe ModulePath -> m k)
|
||||
| List FilePath ([ModulePath] -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
|
||||
sendModules :: ( Member (Modules address value) sig
|
||||
, Carrier sig m)
|
||||
=> Modules address value (Evaluator term address value m) (Evaluator term address value m return)
|
||||
=> Modules address value (Evaluator term address value m) return
|
||||
-> Evaluator term address value m return
|
||||
sendModules = send
|
||||
|
||||
|
||||
@ -379,8 +379,8 @@ alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator te
|
||||
alloc = send . flip Alloc pure
|
||||
|
||||
data Allocator address (m :: * -> *) k
|
||||
= Alloc Name (address -> k)
|
||||
deriving stock Functor
|
||||
= Alloc Name (address -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runAllocator :: Evaluator term address value (AllocatorC address m) a
|
||||
|
||||
@ -48,7 +48,11 @@ module Control.Abstract.Value
|
||||
, ObjectC(..)
|
||||
, runObject
|
||||
, runNumeric
|
||||
, runNumericFunction
|
||||
, runNumeric2Function
|
||||
, castToInteger
|
||||
, runBitwiseFunction
|
||||
, runBitwise2Function
|
||||
, liftBitwise
|
||||
, liftBitwise2
|
||||
, unsignedRShift
|
||||
@ -118,18 +122,18 @@ builtIn address = sendFunction . flip (BuiltIn address) pure
|
||||
call :: (Member (Function term address value) sig, Carrier sig m) => value -> [value] -> Evaluator term address value m value
|
||||
call fn args = sendFunction (Call fn args pure)
|
||||
|
||||
sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a
|
||||
sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) a -> Evaluator term address value m a
|
||||
sendFunction = send
|
||||
|
||||
bindThis :: (Member (Function term address value) sig, Carrier sig m) => value -> value -> Evaluator term address value m value
|
||||
bindThis this that = sendFunction (Bind this that pure)
|
||||
|
||||
data Function term address value (m :: * -> *) k
|
||||
= Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef.
|
||||
| BuiltIn address BuiltIn (value -> k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value.
|
||||
| Call value [value] (value -> k) -- ^ A Call takes a set of values as parameters and returns a ValueRef.
|
||||
| Bind value value (value -> k)
|
||||
deriving stock Functor
|
||||
= Function Name [Name] term address (value -> m k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef.
|
||||
| BuiltIn address BuiltIn (value -> m k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value.
|
||||
| Call value [value] (value -> m k) -- ^ A Call takes a set of values as parameters and returns a ValueRef.
|
||||
| Bind value value (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
|
||||
@ -154,9 +158,9 @@ ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a
|
||||
ifthenelse v t e = asBool v >>= \ c -> if c then t else e
|
||||
|
||||
data Boolean value (m :: * -> *) k
|
||||
= Boolean Bool (value -> k)
|
||||
| AsBool value (Bool -> k)
|
||||
deriving stock Functor
|
||||
= Boolean Bool (value -> m k)
|
||||
| AsBool value (Bool -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runBoolean :: Evaluator term address value (BooleanC value m) a
|
||||
@ -204,11 +208,11 @@ forLoop :: ( Carrier sig m
|
||||
forLoop initial cond step body = initial *> while cond (withLexicalScopeAndFrame body *> step)
|
||||
|
||||
data While value m k
|
||||
= While (m value) (m value) (value -> k)
|
||||
deriving (Functor)
|
||||
= While (m value) (m value) (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
|
||||
instance HFunctor (While value) where
|
||||
hmap f (While cond body k) = While (f cond) (f body) k
|
||||
hmap f (While cond body k) = While (f cond) (f body) (f . k)
|
||||
|
||||
runWhile :: Evaluator term address value (WhileC value m) a
|
||||
-> Evaluator term address value m a
|
||||
@ -223,15 +227,9 @@ unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value
|
||||
unit = send (Unit pure)
|
||||
|
||||
newtype Unit value (m :: * -> *) k
|
||||
= Unit (value -> k)
|
||||
deriving stock Functor
|
||||
|
||||
instance HFunctor (Unit value) where
|
||||
hmap _ = coerce
|
||||
{-# INLINE hmap #-}
|
||||
|
||||
instance Effect (Unit value) where
|
||||
handle state handler (Unit k) = Unit (handler . (<$ state) . k)
|
||||
= Unit (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runUnit :: Evaluator term address value (UnitC value m) a
|
||||
-> Evaluator term address value m a
|
||||
@ -250,9 +248,9 @@ asString :: (Member (String value) sig, Carrier sig m) => value -> m Text
|
||||
asString v = send (AsString v pure)
|
||||
|
||||
data String value (m :: * -> *) k
|
||||
= String Text (value -> k)
|
||||
| AsString value (Text -> k)
|
||||
deriving stock Functor
|
||||
= String Text (value -> m k)
|
||||
| AsString value (Text -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
newtype StringC value m a = StringC { runStringC :: m a }
|
||||
@ -281,7 +279,7 @@ liftNumeric :: (Member (Numeric value) sig, Carrier sig m)
|
||||
=> (forall a . Num a => a -> a)
|
||||
-> value
|
||||
-> m value
|
||||
liftNumeric t v = send (LiftNumeric t v pure)
|
||||
liftNumeric t v = send (LiftNumeric (NumericFunction t) v pure)
|
||||
|
||||
-- | Lift a pair of binary operators to a function on 'value's.
|
||||
-- You usually pass the same operator as both arguments, except in the cases where
|
||||
@ -292,15 +290,25 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m)
|
||||
-> value
|
||||
-> value
|
||||
-> m value
|
||||
liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 pure)
|
||||
liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure)
|
||||
|
||||
data NumericFunction = NumericFunction (forall a . Num a => a -> a)
|
||||
|
||||
runNumericFunction :: Num a => NumericFunction -> a -> a
|
||||
runNumericFunction (NumericFunction f) a = f a
|
||||
|
||||
data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber)
|
||||
|
||||
runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber
|
||||
runNumeric2Function (Numeric2Function f) a b = f a b
|
||||
|
||||
data Numeric value (m :: * -> *) k
|
||||
= Integer Integer (value -> k)
|
||||
| Float Scientific (value -> k)
|
||||
| Rational Rational (value -> k)
|
||||
| LiftNumeric (forall a . Num a => a -> a) value (value -> k)
|
||||
| LiftNumeric2 (forall a b. Number a -> Number b -> SomeNumber) value value (value -> k)
|
||||
deriving stock Functor
|
||||
= Integer Integer (value -> m k)
|
||||
| Float Scientific (value -> m k)
|
||||
| Rational Rational (value -> m k)
|
||||
| LiftNumeric NumericFunction value (value -> m k)
|
||||
| LiftNumeric2 Numeric2Function value value (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
newtype NumericC value m a = NumericC { runNumericC :: m a }
|
||||
@ -321,7 +329,7 @@ liftBitwise :: (Member (Bitwise value) sig, Carrier sig m)
|
||||
=> (forall a . Bits a => a -> a)
|
||||
-> value
|
||||
-> m value
|
||||
liftBitwise t v = send (LiftBitwise t v pure)
|
||||
liftBitwise t v = send (LiftBitwise (BitwiseFunction t) v pure)
|
||||
|
||||
-- | Lift a binary bitwise operator to values. The Integral constraint is
|
||||
-- necessary to satisfy implementation details of Haskell left/right shift,
|
||||
@ -331,7 +339,7 @@ liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m)
|
||||
-> value
|
||||
-> value
|
||||
-> m value
|
||||
liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 pure)
|
||||
liftBitwise2 t v1 v2 = send (LiftBitwise2 (Bitwise2Function t) v1 v2 pure)
|
||||
|
||||
unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m)
|
||||
=> value
|
||||
@ -339,12 +347,22 @@ unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m)
|
||||
-> m value
|
||||
unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure)
|
||||
|
||||
data BitwiseFunction = BitwiseFunction (forall a . Bits a => a -> a)
|
||||
|
||||
runBitwiseFunction :: Bits a => BitwiseFunction -> a -> a
|
||||
runBitwiseFunction (BitwiseFunction f) a = f a
|
||||
|
||||
data Bitwise2Function = Bitwise2Function (forall a . (Integral a, Bits a) => a -> a -> a)
|
||||
|
||||
runBitwise2Function :: (Integral a, Bits a) => Bitwise2Function -> a -> a -> a
|
||||
runBitwise2Function (Bitwise2Function f) a b = f a b
|
||||
|
||||
data Bitwise value (m :: * -> *) k
|
||||
= CastToInteger value (value -> k)
|
||||
| LiftBitwise (forall a . Bits a => a -> a) value (value -> k)
|
||||
| LiftBitwise2 (forall a . (Integral a, Bits a) => a -> a -> a) value value (value -> k)
|
||||
| UnsignedRShift value value (value -> k)
|
||||
deriving stock Functor
|
||||
= CastToInteger value (value -> m k)
|
||||
| LiftBitwise BitwiseFunction value (value -> m k)
|
||||
| LiftBitwise2 Bitwise2Function value value (value -> m k)
|
||||
| UnsignedRShift value value (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runBitwise :: Evaluator term address value (BitwiseC value m) a
|
||||
@ -368,11 +386,11 @@ scopedEnvironment value = send (ScopedEnvironment value pure)
|
||||
klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value
|
||||
klass d a = send (Klass d a pure)
|
||||
|
||||
data Object address value (m :: * -> *) k
|
||||
= Object address (value -> k)
|
||||
| ScopedEnvironment value (Maybe address -> k)
|
||||
| Klass Declaration address (value -> k)
|
||||
deriving stock Functor
|
||||
data Object address value m k
|
||||
= Object address (value -> m k)
|
||||
| ScopedEnvironment value (Maybe address -> m k)
|
||||
| Klass Declaration address (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
newtype ObjectC address value m a = ObjectC { runObjectC :: m a }
|
||||
@ -391,9 +409,9 @@ asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value]
|
||||
asArray v = send (AsArray v pure)
|
||||
|
||||
data Array value (m :: * -> *) k
|
||||
= Array [value] (value -> k)
|
||||
| AsArray value ([value] -> k)
|
||||
deriving stock Functor
|
||||
= Array [value] (value -> m k)
|
||||
| AsArray value ([value] -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
newtype ArrayC value m a = ArrayC { runArrayC :: m a }
|
||||
@ -413,9 +431,9 @@ kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value
|
||||
kvPair v1 v2 = send (KvPair v1 v2 pure)
|
||||
|
||||
data Hash value (m :: * -> *) k
|
||||
= Hash [(value, value)] (value -> k)
|
||||
| KvPair value value (value -> k)
|
||||
deriving stock Functor
|
||||
= Hash [(value, value)] (value -> m k)
|
||||
| KvPair value value (value -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
newtype HashC value m a = HashC { runHashC :: m a }
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Effect.Interpose
|
||||
( Interpose(..)
|
||||
, interpose
|
||||
@ -12,13 +12,13 @@ import Control.Effect.Carrier
|
||||
import Control.Effect.Reader
|
||||
import Control.Effect.Sum
|
||||
|
||||
data Interpose eff m k
|
||||
= forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
|
||||
data Interpose (eff :: (* -> *) -> * -> *) m k
|
||||
= forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k)
|
||||
|
||||
deriving instance Functor (Interpose eff m)
|
||||
deriving instance Functor m => Functor (Interpose eff m)
|
||||
|
||||
instance HFunctor (Interpose eff) where
|
||||
hmap f (Interpose m h k) = Interpose (f m) (f . h) k
|
||||
hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k)
|
||||
|
||||
-- | Respond to requests for some specific effect with a handler.
|
||||
--
|
||||
@ -27,7 +27,7 @@ instance HFunctor (Interpose eff) where
|
||||
-- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@.
|
||||
interpose :: (Member (Interpose eff) sig, Carrier sig m)
|
||||
=> m a
|
||||
-> (forall n x . eff n (n x) -> m x)
|
||||
-> (forall n x . eff n x -> m x)
|
||||
-> m a
|
||||
interpose m f = send (Interpose m f pure)
|
||||
|
||||
@ -36,14 +36,15 @@ interpose m f = send (Interpose m f pure)
|
||||
runInterpose :: InterposeC eff m a -> m a
|
||||
runInterpose = runReader Nothing . runInterposeC
|
||||
|
||||
newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a }
|
||||
deriving (Alternative, Applicative, Functor, Monad)
|
||||
newtype InterposeC (eff :: (* -> *) -> * -> *) m a = InterposeC
|
||||
{ runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a
|
||||
} deriving (Alternative, Applicative, Functor, Monad)
|
||||
|
||||
newtype Listener eff m = Listener (forall n x . eff n (n x) -> m x)
|
||||
newtype Listener (eff :: (* -> *) -> * -> *) m = Listener (forall n x . eff n x -> m x)
|
||||
|
||||
-- TODO: Document the implementation of this, as it is extremely subtle.
|
||||
|
||||
runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a
|
||||
-- Normally we can't just extract the existentials out of the Listener type. In this case,
|
||||
-- we can constrain the foralled 'n' variable to be 'Interpose', which lets it by the typechecker.
|
||||
runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) a -> InterposeC eff m a
|
||||
runListener (Listener listen) = listen
|
||||
|
||||
instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
|
||||
|
||||
@ -18,9 +18,9 @@ import System.Console.Haskeline
|
||||
import qualified Data.Text as T
|
||||
|
||||
data REPL (m :: * -> *) k
|
||||
= Prompt Text (Maybe Text -> k)
|
||||
| Output Text k
|
||||
deriving stock Functor
|
||||
= Prompt Text (Maybe Text -> m k)
|
||||
| Output Text (m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
|
||||
|
||||
@ -398,6 +398,7 @@ instance AccessControls1 PHP.IncludeOnce
|
||||
instance AccessControls1 PHP.ArrayElement
|
||||
instance AccessControls1 PHP.GlobalDeclaration
|
||||
instance AccessControls1 PHP.SimpleVariable
|
||||
instance AccessControls1 PHP.Concat
|
||||
instance AccessControls1 PHP.CastType
|
||||
instance AccessControls1 PHP.ErrorControl
|
||||
instance AccessControls1 PHP.Clone
|
||||
|
||||
@ -226,20 +226,20 @@ instance ( Member (Reader ModuleInfo) sig
|
||||
Abstract.Float t k -> k (Float (Number.Decimal t))
|
||||
Abstract.Rational t k -> k (Rational (Number.Ratio t))
|
||||
Abstract.LiftNumeric f arg k -> k =<< case arg of
|
||||
Integer (Number.Integer i) -> pure $ Integer (Number.Integer (f i))
|
||||
Float (Number.Decimal d) -> pure $ Float (Number.Decimal (f d))
|
||||
Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (f r))
|
||||
Integer (Number.Integer i) -> pure $ Integer (Number.Integer (runNumericFunction f i))
|
||||
Float (Number.Decimal d) -> pure $ Float (Number.Decimal (runNumericFunction f d))
|
||||
Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (runNumericFunction f r))
|
||||
other -> throwBaseError (NumericError other)
|
||||
Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of
|
||||
(Integer i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Integer i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Integer i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Rational i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Rational i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Rational i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Float i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Float i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Float i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize
|
||||
(Integer i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Integer i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Integer i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Rational i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Rational i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Rational i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Float i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Float i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
(Float i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
|
||||
_ -> throwBaseError (Numeric2Error left right)
|
||||
|
||||
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
|
||||
@ -268,9 +268,9 @@ instance ( Member (Reader ModuleInfo) sig
|
||||
CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i))
|
||||
CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i))))
|
||||
CastToInteger i k -> throwBaseError (NumericError i) >>= k
|
||||
LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . operator $ i
|
||||
LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . runBitwiseFunction operator $ i
|
||||
LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k
|
||||
LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ operator i j
|
||||
LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ runBitwise2Function operator i j
|
||||
LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= k
|
||||
UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j)
|
||||
UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= k
|
||||
|
||||
@ -111,5 +111,5 @@ instance (Ord vertex, ToJSON vertex, VertexTag vertex) => ToJSON (Graph vertex)
|
||||
newtype Edge vertex = Edge (vertex, vertex)
|
||||
|
||||
instance (ToJSON vertex, VertexTag vertex) => ToJSON (Edge vertex) where
|
||||
toJSON (Edge (a, b)) = object ["source" .= uniqueTag a, "target" .= uniqueTag b]
|
||||
toEncoding (Edge (a, b)) = pairs ("source" .= uniqueTag a <> "target" .= uniqueTag b)
|
||||
toJSON (Edge (a, b)) = object ["source" .= show (uniqueTag a), "target" .= show (uniqueTag b)]
|
||||
toEncoding (Edge (a, b)) = pairs ("source" .= show (uniqueTag a) <> "target" .= show (uniqueTag b))
|
||||
|
||||
@ -86,7 +86,14 @@ instance Lower ControlFlowVertex where lowerBound = Package ""
|
||||
instance VertexTag ControlFlowVertex where uniqueTag = hash . vertexIdentifier
|
||||
|
||||
instance ToJSON ControlFlowVertex where
|
||||
toJSON v = object [ "name" .= vertexIdentifier v, "type" .= vertexToType v ]
|
||||
toJSON v = object [ "name" .= vertexIdentifier v
|
||||
, "type" .= vertexToType v
|
||||
, "id" .= show (uniqueTag v)
|
||||
]
|
||||
toEncoding v = pairs $ mconcat [ "name" .= vertexIdentifier v
|
||||
, "type" .= vertexToType v
|
||||
, "id" .= show (uniqueTag v)
|
||||
]
|
||||
|
||||
-- TODO: This is potentially valuable just to get name's out of declarable things.
|
||||
-- Typeclasses to create 'ControlFlowVertex's from 'Term's. Also extracts
|
||||
|
||||
@ -25,20 +25,21 @@ import Prologue
|
||||
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
|
||||
data Diff term1 term2 diff (m :: * -> *) k
|
||||
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
|
||||
= Diff term1 term2 (diff -> k)
|
||||
= Diff term1 term2 (diff -> m k)
|
||||
-- | Diff two terms recursively in O(n) time, resulting in a single diff node.
|
||||
| Linear term1 term2 (diff -> k)
|
||||
| Linear term1 term2 (diff -> m k)
|
||||
-- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
|
||||
| RWS [term1] [term2] ([diff] -> k)
|
||||
| RWS [term1] [term2] ([diff] -> m k)
|
||||
-- | Delete a term.
|
||||
| Delete term1 (diff -> k)
|
||||
| Delete term1 (diff -> m k)
|
||||
-- | Insert a term.
|
||||
| Insert term2 (diff -> k)
|
||||
| Insert term2 (diff -> m k)
|
||||
-- | Replace one term with another.
|
||||
| Replace term1 term2 (diff -> k)
|
||||
deriving stock Functor
|
||||
| Replace term1 term2 (diff -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
|
||||
newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a }
|
||||
deriving newtype (Applicative, Alternative, Functor, Monad)
|
||||
|
||||
@ -83,7 +84,7 @@ byInserting a2 = sendDiff (Insert a2 pure)
|
||||
byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff
|
||||
byReplacing a1 a2 = send (Replace a1 a2 pure)
|
||||
|
||||
sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m (m a) -> Algorithm term1 term2 diff m a
|
||||
sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m a -> Algorithm term1 term2 diff m a
|
||||
sendDiff = Algorithm . send
|
||||
|
||||
|
||||
|
||||
@ -146,6 +146,7 @@ type Syntax = '[
|
||||
, Syntax.ReturnType
|
||||
, Syntax.ScalarType
|
||||
, Syntax.ShellCommand
|
||||
, Syntax.Concat
|
||||
, Syntax.SimpleVariable
|
||||
, Syntax.Static
|
||||
, Syntax.Text
|
||||
@ -233,7 +234,7 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
|
||||
, assign Expression.DividedBy <$ symbol AnonSlashEqual
|
||||
, assign Expression.Plus <$ symbol AnonPlusEqual
|
||||
, assign Expression.Minus <$ symbol AnonMinusEqual
|
||||
, assign Expression.Times <$ symbol AnonDotEqual
|
||||
, assign Syntax.Concat <$ symbol AnonDotEqual
|
||||
, assign Expression.LShift <$ symbol AnonLAngleLAngleEqual
|
||||
, assign Expression.RShift <$ symbol AnonRAngleRAngleEqual
|
||||
, assign Expression.BAnd <$ symbol AnonAmpersandEqual
|
||||
@ -255,7 +256,7 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm
|
||||
, (inject .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right.
|
||||
, (inject .) . Expression.Equal <$ symbol AnonEqualEqual
|
||||
, (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual
|
||||
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle <|> symbol AnonBangEqualEqual)
|
||||
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle)
|
||||
, (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual
|
||||
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
|
||||
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
|
||||
@ -266,7 +267,8 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm
|
||||
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
|
||||
, (inject .) . Expression.Plus <$ symbol AnonPlus
|
||||
, (inject .) . Expression.Minus <$ symbol AnonMinus
|
||||
, (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonDot)
|
||||
, (inject .) . Expression.Times <$ symbol AnonStar
|
||||
, (inject .) . Syntax.Concat <$ symbol AnonDot
|
||||
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
|
||||
, (inject .) . Expression.Modulo <$ symbol AnonPercent
|
||||
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
|
||||
|
||||
@ -128,6 +128,12 @@ newtype SimpleVariable a = SimpleVariable { value :: a }
|
||||
|
||||
instance Evaluatable SimpleVariable
|
||||
|
||||
data Concat a = Concat { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, NFData1)
|
||||
deriving (Eq1, Show1, Ord1) via Generically Concat
|
||||
|
||||
instance Evaluatable Concat
|
||||
|
||||
-- | TODO: Unify with TypeScript's PredefinedType
|
||||
newtype CastType a = CastType { _castType :: T.Text }
|
||||
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, NFData1)
|
||||
|
||||
@ -4,7 +4,6 @@ module Language.Ruby.PrettyPrint ( printingRuby ) where
|
||||
|
||||
import Control.Effect
|
||||
import Control.Effect.Error
|
||||
import Control.Monad.Trans (lift)
|
||||
import Streaming
|
||||
import qualified Streaming.Prelude as Streaming
|
||||
|
||||
|
||||
@ -39,12 +39,12 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
|
||||
|
||||
-- | Distribute effects run tasks concurrently.
|
||||
data Distribute m k
|
||||
= forall a . Distribute (m a) (a -> k)
|
||||
= forall a . Distribute (m a) (a -> m k)
|
||||
|
||||
deriving instance Functor (Distribute m)
|
||||
deriving instance Functor m => Functor (Distribute m)
|
||||
|
||||
instance HFunctor Distribute where
|
||||
hmap f (Distribute m k) = Distribute (f m) k
|
||||
hmap f (Distribute m k) = Distribute (f m) (f . k)
|
||||
|
||||
instance Effect Distribute where
|
||||
handle state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k)
|
||||
|
||||
@ -61,7 +61,7 @@ repl proxy parser paths =
|
||||
runM
|
||||
. withDistribute
|
||||
. withCatch
|
||||
. withResource
|
||||
. runResource
|
||||
. withTimeout
|
||||
. runError @SomeException
|
||||
. runTelemetryIgnoringStat (logOptionsFromConfig config)
|
||||
|
||||
@ -18,6 +18,7 @@ import qualified Data.Map as Map
|
||||
import Data.Source
|
||||
import Data.Language
|
||||
import Prologue
|
||||
import GHC.Generics (Generic1)
|
||||
import Semantic.Task.Files
|
||||
import System.FilePath.Posix
|
||||
|
||||
@ -44,9 +45,9 @@ resolutionMap Project{..} = case projectLanguage of
|
||||
_ -> send (NoResolution pure)
|
||||
|
||||
data Resolution (m :: * -> *) k
|
||||
= NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
|
||||
| NoResolution (Map FilePath FilePath -> k)
|
||||
deriving stock Functor
|
||||
= NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> m k)
|
||||
| NoResolution (Map FilePath FilePath -> m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
runResolution :: ResolutionC m a -> m a
|
||||
|
||||
@ -22,7 +22,6 @@ module Semantic.Task
|
||||
, time'
|
||||
-- * High-level flow
|
||||
, parse
|
||||
, analyze
|
||||
, decorate
|
||||
, diff
|
||||
, render
|
||||
@ -119,13 +118,6 @@ parse :: (Member Task sig, Carrier sig m)
|
||||
-> m term
|
||||
parse parser blob = send (Parse parser blob pure)
|
||||
|
||||
-- | A task running some 'Analysis.Evaluator' to completion.
|
||||
analyze :: (Member Task sig, Carrier sig m)
|
||||
=> (Analysis.Evaluator term address value m a -> result)
|
||||
-> Analysis.Evaluator term address value m a
|
||||
-> m result
|
||||
analyze interpret analysis = send (Analyze interpret analysis pure)
|
||||
|
||||
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
|
||||
decorate :: (Functor f, Member Task sig, Carrier sig m)
|
||||
=> RAlgebra (TermF f Location) (Term f Location) field
|
||||
@ -170,7 +162,7 @@ runTask taskSession@TaskSession{..} task = do
|
||||
= runM
|
||||
. withDistribute
|
||||
. withCatch
|
||||
. withResource
|
||||
. runResource
|
||||
. withTimeout
|
||||
. runError
|
||||
. runTelemetry logger statter
|
||||
@ -208,21 +200,23 @@ instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (Trace
|
||||
|
||||
-- | An effect describing high-level tasks to be performed.
|
||||
data Task (m :: * -> *) k
|
||||
= forall term . Parse (Parser term) Blob (term -> k)
|
||||
| forall term address value m a result . Analyze (Analysis.Evaluator term address value m a -> result) (Analysis.Evaluator term address value m a) (result -> k)
|
||||
| forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k)
|
||||
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k)
|
||||
| forall input output . Render (Renderer input output) input (output -> k)
|
||||
| forall input . Serialize (Format input) input (Builder -> k)
|
||||
= forall term . Parse (Parser term) Blob (term -> m k)
|
||||
| forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> m k)
|
||||
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k)
|
||||
| forall input output . Render (Renderer input output) input (output -> m k)
|
||||
| forall input . Serialize (Format input) input (Builder -> m k)
|
||||
|
||||
deriving instance Functor (Task m)
|
||||
deriving instance Functor m => Functor (Task m)
|
||||
|
||||
instance HFunctor Task where
|
||||
hmap _ = coerce
|
||||
hmap f (Parse parser blob k) = Parse parser blob (f . k)
|
||||
hmap f (Decorate decorator term k) = Decorate decorator term (f . k)
|
||||
hmap f (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (f . k)
|
||||
hmap f (Render renderer input k) = Render renderer input (f . k)
|
||||
hmap f (Serialize format input k) = Serialize format input (f . k)
|
||||
|
||||
instance Effect Task where
|
||||
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
|
||||
handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k)
|
||||
handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
|
||||
handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
|
||||
handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
|
||||
@ -239,7 +233,6 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader
|
||||
eff (R other) = TaskC . eff . handleCoercible $ other
|
||||
eff (L op) = case op of
|
||||
Parse parser blob k -> runParser blob parser >>= k
|
||||
Analyze interpret analysis k -> k . interpret $ analysis
|
||||
Decorate algebra term k -> k (decoratorWithAlgebra algebra term)
|
||||
Semantic.Task.Diff terms k -> k (diffTermPair terms)
|
||||
Render renderer input k -> k (renderer input)
|
||||
|
||||
@ -50,14 +50,24 @@ data Excludes
|
||||
|
||||
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
|
||||
data Files (m :: * -> *) k
|
||||
= forall a . Read (Source a) (a -> k)
|
||||
| ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k)
|
||||
| FindFiles FilePath [String] [FilePath] ([FilePath] -> k)
|
||||
| Write Destination B.Builder k
|
||||
= forall a . Read (Source a) (a -> m k)
|
||||
| ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> m k)
|
||||
| FindFiles FilePath [String] [FilePath] ([FilePath] -> m k)
|
||||
| Write Destination B.Builder (m k)
|
||||
|
||||
deriving instance Functor (Files m)
|
||||
instance HFunctor Files
|
||||
instance Effect Files
|
||||
deriving instance Functor m => Functor (Files m)
|
||||
|
||||
instance HFunctor Files where
|
||||
hmap f (Read s k) = Read s (f . k)
|
||||
hmap f (ReadProject mp p l ps k) = ReadProject mp p l ps (f . k)
|
||||
hmap f (FindFiles p s ps k) = FindFiles p s ps (f . k)
|
||||
hmap f (Write d b k) = Write d b (f k)
|
||||
|
||||
instance Effect Files where
|
||||
handle state handler (Read s k) = Read s (handler . (<$ state) . k)
|
||||
handle state handler (ReadProject mp p l ps k) = ReadProject mp p l ps (handler . (<$ state) . k)
|
||||
handle state handler (FindFiles p s ps k) = FindFiles p s ps (handler . (<$ state) . k)
|
||||
handle state handler (Write d b k) = Write d b (handler . (<$ state) $ k)
|
||||
|
||||
-- | Run a 'Files' effect in 'IO'
|
||||
runFiles :: FilesC m a -> m a
|
||||
|
||||
@ -57,6 +57,7 @@ import Control.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
|
||||
import qualified Data.Time.LocalTime as LocalTime
|
||||
import GHC.Generics (Generic1)
|
||||
import Semantic.Telemetry.AsyncQueue
|
||||
import Semantic.Telemetry.Error
|
||||
import Semantic.Telemetry.Log
|
||||
@ -137,9 +138,9 @@ time' = withTiming'
|
||||
|
||||
-- | Statting and logging effects.
|
||||
data Telemetry (m :: * -> *) k
|
||||
= WriteStat Stat k
|
||||
| WriteLog Level String [(String, String)] k
|
||||
deriving stock Functor
|
||||
= WriteStat Stat (m k)
|
||||
| WriteLog Level String [(String, String)] (m k)
|
||||
deriving stock (Functor, Generic1)
|
||||
deriving anyclass (HFunctor, Effect)
|
||||
|
||||
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
|
||||
|
||||
@ -26,12 +26,12 @@ timeout n = send . flip (Timeout n) pure
|
||||
-- | 'Timeout' effects run other effects, aborting them if they exceed the
|
||||
-- specified duration.
|
||||
data Timeout m k
|
||||
= forall a . Timeout Duration (m a) (Maybe a -> k)
|
||||
= forall a . Timeout Duration (m a) (Maybe a -> m k)
|
||||
|
||||
deriving instance Functor (Timeout m)
|
||||
deriving instance Functor m => Functor (Timeout m)
|
||||
|
||||
instance HFunctor Timeout where
|
||||
hmap f (Timeout n task k) = Timeout n (f task) k
|
||||
hmap f (Timeout n task k) = Timeout n (f task) (f . k)
|
||||
|
||||
instance Effect Timeout where
|
||||
handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
|
||||
|
||||
@ -551,6 +551,7 @@ instance Taggable PHP.IncludeOnce
|
||||
instance Taggable PHP.ArrayElement
|
||||
instance Taggable PHP.GlobalDeclaration
|
||||
instance Taggable PHP.SimpleVariable
|
||||
instance Taggable PHP.Concat
|
||||
instance Taggable PHP.CastType
|
||||
instance Taggable PHP.ErrorControl
|
||||
instance Taggable PHP.Clone
|
||||
|
||||
Loading…
Reference in New Issue
Block a user