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

Merge pull request #585 from github/distributive-algebras

Browse Source 
fused-effects 1.1
This commit is contained in:
Rob Rix 2020-07-16 09:34:15 -04:00 committed by GitHub
commit 289edf6600
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
52 changed files with 378 additions and 617 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
WORKSPACE
View File

@ -89,11 +89,11 @@ stack_snapshot(
"fused-effects",
"fused-effects-exceptions",
"fused-effects-readline",
"fused-effects-resumable",
"fused-syntax",
"gauge",
"generic-lens",
"generic-monoid",
"haskeline",
"hashable",
"haskeline",
"hedgehog",
@ -187,64 +187,64 @@ load(
tree_sitter_node_types_hackage(
name = "tree-sitter-go",
sha256 = "364a0ae4e683bda1e348fa85c6828cad72122af155560b680f6052852d98db6c",
version = "0.5.0.1",
sha256 = "72a1d3bdb2883ace3f2de3a0f754c680908489e984503f1a66243ad74dc2887e",
version = "0.5.0.2",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-python",
sha256 = "36aca4989a9f8b52d6af1586e6eecc8c3a8db2b5643f64ef13ab3d284c266522",
version = "0.9.0.2",
sha256 = "f028c88eabbda9b9bb67895922d753a12ddda83fb917748e0e407e50616b51ae",
version = "0.9.0.3",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-php",
sha256 = "d7a050948fcea3b740924520c5d0e00e9b239949eff831527a736c5421c912a3",
version = "0.5.0.0",
sha256 = "70fd9f5cc429fa2b59adaa86853fb111f733889f0b2996328efd885903d7ce16",
version = "0.5.0.1",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-java",
sha256 = "9978b56af40c0c66688c17a193761e9c21f7cbbb7e2e299cb7b99f42bd355dfc",
version = "0.7.0.1",
sha256 = "569fa1240cdb7db8436201962933c97dd2c502ed65bd4788880238201c67a1c6",
version = "0.7.0.2",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-json",
sha256 = "2b16e68afdc8c56bfac81b88dcd495fc8da6ba9df89347249f1785f1077965e5",
version = "0.7.0.1",
sha256 = "8fbc478268849c16bc7ff85dd6634bb849400bda98575fe26681224a640b9e0a",
version = "0.7.0.2",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-typescript",
node_types_path = ":vendor/tree-sitter-typescript/typescript/src/node-types.json",
sha256 = "19a036ed413c9da66de8fc3826a413c30278d8490603aeb9465caf3707553d19",
version = "0.5.0.1",
sha256 = "d1cd258e5c83d557ab3481e08c2e8c29ee689e2a9de89b6f72c12080f48c9c62",
version = "0.5.0.2",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-tsx",
node_types_path = ":vendor/tree-sitter-typescript/tsx/src/node-types.json",
sha256 = "56060c8d12acda0218cc3185c041b8bc7e0a13a0863ab4f1ca133a54078630de",
version = "0.5.0.1",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-ruby",
sha256 = "d7e9cb06d37b5ee3be500a7f19ce09b6e846958195eff465d2b03d3218807690",
sha256 = "20115194b7e87d53e8ad42a9d5ef212186040e543ccf295135b1342ec6b12447",
version = "0.5.0.2",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-ruby",
sha256 = "b6bb1fcb23e283f28af2d1ac9444ed63bb7b9f396034d13db62553d998cefc24",
version = "0.5.0.3",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-ql",
sha256 = "fdc3ad5351318fcfeebd7ecb0099a5e3eeac030ec5037f71c1634ab5da94ae6b",
version = "0.1.0.3",
sha256 = "d15eff87a292ec4559295676afbf0e5a763f5f7e7636411933109880c3fd5c5d",
version = "0.1.0.4",
)
tree_sitter_node_types_hackage(
name = "tree-sitter-rust",
sha256 = "522968fa22ad2e9720012b74487e77c91693572d81b157acdb0e116c535848ad",
version = "0.1.0.0",
sha256 = "00bc04a31b5c9b0f9b419074238996ee4aadba342e68071ec516077b495e0d41",
version = "0.1.0.1",
)
# Download lingo (which has its own Bazel build instructions).

2
cabal.project
View File

@ -31,4 +31,4 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/antitypical/fused-syntax.git
tag: d11e14581217590a5c67f79cbaeee35ac8acee6a
tag: 4a383d57c8fd7592f54a33f43eb9666314a6e80e

2
cabal.project.ci
View File

@ -31,7 +31,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/antitypical/fused-syntax.git
tag: d11e14581217590a5c67f79cbaeee35ac8acee6a
tag: 4a383d57c8fd7592f54a33f43eb9666314a6e80e
-- Treat warnings as errors for CI builds
package semantic

2
semantic-analysis/BUILD.bazel
View File

@ -23,7 +23,6 @@ haskell_library(
"//:base",
"//:containers",
"//:filepath",
"//:haskeline",
"//:text",
"//:transformers",
"//semantic-source",
@ -33,6 +32,7 @@ haskell_library(
"@stackage//:fused-effects-readline",
"@stackage//:fused-syntax",
"@stackage//:hashable",
"@stackage//:haskeline",
"@stackage//:pathtype",
"@stackage//:prettyprinter",
"@stackage//:prettyprinter-ansi-terminal",

4
semantic-analysis/semantic-analysis.cabal
View File

@ -64,8 +64,8 @@ library
, base >= 4.13 && < 5
, containers ^>= 0.6
, filepath
, fused-effects ^>= 1.0
, fused-effects-readline ^>= 0
, fused-effects ^>= 1.1
, fused-effects-readline ^>= 0.1
, fused-syntax
, hashable
, haskeline ^>= 0.7.5

22
semantic-analysis/src/Analysis/Carrier/Env/Monovariant.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.Carrier.Env.Monovariant
( -- * Env carrier
EnvC(..)
@ -6,9 +11,9 @@ module Analysis.Carrier.Env.Monovariant
, module Analysis.Effect.Env
) where
import Analysis.Effect.Env
import Analysis.Name
import Control.Algebra
import Analysis.Effect.Env
import Analysis.Name
import Control.Algebra
import qualified Control.Monad.Fail as Fail
newtype EnvC m a = EnvC { runEnv :: m a }
@ -16,7 +21,8 @@ newtype EnvC m a = EnvC { runEnv :: m a }
instance Algebra sig m
=> Algebra (Env Name :+: sig) (EnvC m) where
alg (L (Alloc name k)) = k name
alg (L (Bind _ _ m k)) = m >>= k
alg (L (Lookup name k)) = k (Just name)
alg (R other) = EnvC (alg (handleCoercible other))
alg hdl sig ctx = case sig of
L (Alloc name) -> pure (name <$ ctx)
L (Bind _ _ m) -> hdl (m <$ ctx)
L (Lookup name) -> pure (Just name <$ ctx)
R other -> EnvC (alg (runEnv . hdl) other ctx)

24
semantic-analysis/src/Analysis/Carrier/Env/Precise.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.Carrier.Env.Precise
( -- * Env carrier
EnvC(..)
@ -10,10 +15,10 @@ module Analysis.Carrier.Env.Precise
) where
import qualified Analysis.Effect.Env as A
import Analysis.Name
import Control.Algebra
import Control.Effect.Fresh
import Control.Effect.Reader
import Analysis.Name
import Control.Algebra
import Control.Effect.Fresh
import Control.Effect.Reader
import qualified Control.Monad.Fail as Fail
import qualified Data.Map as Map
@ -27,7 +32,8 @@ instance ( Has Fresh sig m
, Has (Reader Env) sig m
)
=> Algebra (A.Env Precise :+: sig) (EnvC m) where
alg (L (A.Alloc _ k)) = fresh >>= k
alg (L (A.Bind name addr m k)) = local (Map.insert name addr) m >>= k
alg (L (A.Lookup name k)) = asks (Map.lookup name) >>= k
alg (R other) = EnvC (alg (handleCoercible other))
alg hdl sig ctx = case sig of
L (A.Alloc _) -> (<$ ctx) <$> fresh
L (A.Bind name addr m) -> local (Map.insert name addr) (hdl (m <$ ctx))
L (A.Lookup name) -> (<$ ctx) <$> asks (Map.lookup name)
R other -> EnvC (alg (runEnv . hdl) other ctx)

28
semantic-analysis/src/Analysis/Carrier/Heap/Monovariant.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.Carrier.Heap.Monovariant
( -- * Heap carrier
HeapC(..)
@ -6,15 +11,15 @@ module Analysis.Carrier.Heap.Monovariant
, module Analysis.Effect.Heap
) where
import Analysis.Effect.Heap
import Control.Applicative (Alternative)
import Control.Algebra
import Control.Effect.State
import Control.Monad ((>=>))
import Analysis.Effect.Heap
import Control.Algebra
import Control.Applicative (Alternative)
import Control.Effect.State
import Control.Monad ((>=>))
import qualified Control.Monad.Fail as Fail
import Data.List.NonEmpty (nonEmpty)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as Map
import Data.Monoid (Alt(..))
import Data.Monoid (Alt (..))
import qualified Data.Set as Set
newtype HeapC addr value m a = HeapC { runHeap :: m a }
@ -26,6 +31,7 @@ instance ( Alternative m
, Ord value
)
=> Algebra (Heap addr value :+: sig) (HeapC addr value m) where
alg (L (Deref addr k)) = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (getAlt . foldMap (Alt . pure . Just)) >>= k
alg (L (Assign addr value k)) = modify (Map.insertWith (<>) addr (Set.singleton value)) >> k
alg (R other) = HeapC (alg (handleCoercible other))
alg hdl sig ctx = case sig of
L (Deref addr ) -> gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= fmap (<$ ctx) . maybe (pure Nothing) (getAlt . foldMap (Alt . pure . Just))
L (Assign addr value) -> ctx <$ modify (Map.insertWith (<>) addr (Set.singleton value))
R other -> HeapC (alg (runHeap . hdl) other ctx)

26
semantic-analysis/src/Analysis/Carrier/Heap/Precise.hs
View File

@ -1,15 +1,20 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.Carrier.Heap.Precise
( -- * Heap carrier
runHeap
, HeapC(..)
, HeapC(HeapC)
-- * Heap effect
, module Analysis.Effect.Heap
) where
import Analysis.Effect.Heap
import Control.Algebra
import Control.Carrier.State.Strict
import Analysis.Effect.Heap
import Control.Algebra
import Control.Carrier.State.Strict
import qualified Control.Monad.Fail as Fail
import qualified Data.IntMap as IntMap
@ -18,11 +23,12 @@ type Precise = Int
runHeap :: HeapC value m a -> m (IntMap.IntMap value, a)
runHeap (HeapC m) = runState mempty m
newtype HeapC value m a = HeapC (StateC (IntMap.IntMap value) m a)
newtype HeapC value m a = HeapC { runHeapC :: StateC (IntMap.IntMap value) m a }
deriving (Applicative, Functor, Monad, Fail.MonadFail)
instance (Algebra sig m, Effect sig)
instance Algebra sig m
=> Algebra (Heap Precise value :+: State (IntMap.IntMap value) :+: sig) (HeapC value m) where
alg (L (Deref addr k)) = HeapC (gets (IntMap.lookup addr)) >>= k
alg (L (Assign addr value k)) = HeapC (modify (IntMap.insert addr value)) >> k
alg (R other) = HeapC (alg (handleCoercible other))
alg hdl sig ctx = HeapC $ case sig of
L (Deref addr) -> (<$ ctx) <$> gets (IntMap.lookup addr)
L (Assign addr value) -> ctx <$ modify (IntMap.insert addr value)
R other -> alg (runHeapC . hdl) other ctx

41
semantic-analysis/src/Analysis/Concrete.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -8,7 +9,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
@ -85,7 +85,6 @@ concrete eval
runFile
:: forall term m sig
. ( Applicative term
, Effect sig
, Has Fresh sig m
, Has (A.Heap Addr (Concrete term)) sig m
)
@ -106,9 +105,9 @@ runFile eval file = traverse run file
runDomain :: (term Addr -> m (Concrete term)) -> DomainC term m a -> m a
runDomain eval (DomainC m) = runReader eval m
runDomain eval = runReader eval . runDomainC
newtype DomainC term m a = DomainC (ReaderC (term Addr -> m (Concrete term)) m a)
newtype DomainC term m a = DomainC { runDomainC :: ReaderC (term Addr -> m (Concrete term)) m a }
deriving (Applicative, Functor, Monad, MonadFail)
instance MonadTrans (DomainC term) where
@ -122,35 +121,35 @@ instance ( Applicative term
, MonadFail m
)
=> Algebra (A.Domain term Addr (Concrete term) :+: sig) (DomainC term m) where
alg = \case
L (L (A.Unit k)) -> k Unit
L (R (L (A.Bool b k))) -> k (Bool b)
L (R (L (A.AsBool c k))) -> case c of
Bool b -> k b
alg hdl sig ctx = case sig of
L (L A.Unit) -> pure (Unit <$ ctx)
L (R (L (A.Bool b))) -> pure (Bool b <$ ctx)
L (R (L (A.AsBool c))) -> case c of
Bool b -> pure (b <$ ctx)
_ -> fail "expected Bool"
L (R (R (L (A.String s k)))) -> k (String s)
L (R (R (L (A.AsString c k)))) -> case c of
String s -> k s
L (R (R (L (A.String s)))) -> pure (String s <$ ctx)
L (R (R (L (A.AsString c)))) -> case c of
String s -> pure (s <$ ctx)
_ -> fail "expected String"
L (R (R (R (L (A.Lam b k))))) -> do
L (R (R (R (L (A.Lam b))))) -> do
path <- ask
span <- ask
k (Closure path span b)
L (R (R (R (L (A.AsLam c k))))) -> case c of
Closure _ _ b -> k b
pure (Closure path span b <$ ctx)
L (R (R (R (L (A.AsLam c))))) -> case c of
Closure _ _ b -> pure (b <$ ctx)
_ -> fail "expected Closure"
L (R (R (R (R (A.Record fields k))))) -> do
L (R (R (R (R (A.Record fields))))) -> do
eval <- DomainC ask
fields' <- for fields $ \ (name, t) -> do
addr <- A.alloc name
v <- lift (eval t)
A.assign @Addr @(Concrete term) addr v
pure (name, addr)
k (Record (Map.fromList fields'))
L (R (R (R (R (A.AsRecord c k))))) -> case c of
Record fields -> k (map (fmap pure) (Map.toList fields))
pure (Record (Map.fromList fields') <$ ctx)
L (R (R (R (R (A.AsRecord c))))) -> case c of
Record fields -> pure (map (fmap pure) (Map.toList fields) <$ ctx)
_ -> fail "expected Record"
R other -> DomainC (send (handleCoercible other))
R other -> DomainC (alg (runDomainC . hdl) (R other) ctx)
-- | 'heapGraph', 'heapValueGraph', and 'heapAddressGraph' allow us to conveniently export SVGs of the heap:

72
semantic-analysis/src/Analysis/Effect/Domain.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
module Analysis.Effect.Domain
( -- * Domain effect
@ -26,81 +26,61 @@ module Analysis.Effect.Domain
import Analysis.Functor.Named
import Control.Algebra
import Data.Kind (Type)
import Data.Text (Text)
import GHC.Generics (Generic1)
import Syntax.Scope (Scope)
unit :: Has (UnitDomain value) sig m => m value
unit = send (Unit pure)
unit = send Unit
data UnitDomain value m k
= Unit (value -> m k)
deriving (Functor, Generic1)
instance HFunctor (UnitDomain value)
instance Effect (UnitDomain value)
data UnitDomain value (m :: Type -> Type) k where
Unit :: UnitDomain value m value
bool :: Has (BoolDomain value) sig m => Bool -> m value
bool b = send (Bool b pure)
bool b = send (Bool b)
asBool :: Has (BoolDomain value) sig m => value -> m Bool
asBool v = send (AsBool v pure)
asBool v = send (AsBool v)
data BoolDomain value m k
= Bool Bool (value -> m k)
| AsBool value (Bool -> m k)
deriving (Functor, Generic1)
instance HFunctor (BoolDomain value)
instance Effect (BoolDomain value)
data BoolDomain value (m :: Type -> Type) k where
Bool :: Bool -> BoolDomain value m value
AsBool :: value -> BoolDomain value m Bool
string :: Has (StringDomain value) sig m => Text -> m value
string s = send (String s pure)
string s = send (String s)
asString :: Has (StringDomain value) sig m => value -> m Text
asString v = send (AsString v pure)
asString v = send (AsString v)
data StringDomain value m k
= String Text (value -> m k)
| AsString value (Text -> m k)
deriving (Functor, Generic1)
instance HFunctor (StringDomain value)
instance Effect (StringDomain value)
data StringDomain value (m :: Type -> Type) k where
String :: Text -> StringDomain value m value
AsString :: value -> StringDomain value m Text
lam :: Has (FunctionDomain term addr value) sig m => Named (Scope () term addr) -> m value
lam b = send (Lam b pure)
lam b = send (Lam b)
-- FIXME: Support partial concretization of lambdas.
asLam :: Has (FunctionDomain term addr value) sig m => value -> m (Named (Scope () term addr))
asLam v = send (AsLam v pure)
asLam v = send (AsLam v)
data FunctionDomain term addr value m k
= Lam (Named (Scope () term addr)) (value -> m k)
| AsLam value (Named (Scope () term addr) -> m k)
deriving (Functor, Generic1)
instance HFunctor (FunctionDomain term addr value)
instance Effect (FunctionDomain term addr value)
data FunctionDomain term addr value (m :: Type -> Type) k where
Lam :: Named (Scope () term addr) -> FunctionDomain term addr value m value
AsLam :: value -> FunctionDomain term addr value m (Named (Scope () term addr))
record :: Has (RecordDomain term addr value) sig m => [(Name, term addr)] -> m value
record fs = send (Record fs pure)
record fs = send (Record fs)
-- FIXME: Support partial concretization of records.
asRecord :: Has (RecordDomain term addr value) sig m => value -> m [(Name, term addr)]
asRecord v = send (AsRecord v pure)
asRecord v = send (AsRecord v)
data RecordDomain term addr value m k
= Record [(Name, term addr)] (value -> m k)
| AsRecord value ([(Name, term addr)] -> m k)
deriving (Functor, Generic1)
instance HFunctor (RecordDomain term addr value)
instance Effect (RecordDomain term addr value)
data RecordDomain term addr value (m :: Type -> Type) k where
Record :: [(Name, term addr)] -> RecordDomain term addr value m value
AsRecord :: value -> RecordDomain term addr value m [(Name, term addr)]
type Domain term addr value

30
semantic-analysis/src/Analysis/Effect/Env.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, LambdaCase, StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
module Analysis.Effect.Env
( -- * Env effect
alloc
@ -15,30 +15,16 @@ import Analysis.Name
import Control.Algebra
alloc :: Has (Env addr) sig m => Name -> m addr
alloc name = send (Alloc name pure)
alloc name = send (Alloc name)
bind :: Has (Env addr) sig m => Name -> addr -> m a -> m a
bind name addr m = send (Bind name addr m pure)
bind name addr m = send (Bind name addr m)
lookupEnv :: Has (Env addr) sig m => Name -> m (Maybe addr)
lookupEnv name = send (Lookup name pure)
lookupEnv name = send (Lookup name)
data Env addr m k
= Alloc Name (addr -> m k)
| forall a . Bind Name addr (m a) (a -> m k)
| Lookup Name (Maybe addr -> m k)
deriving instance Functor m => Functor (Env addr m)
instance HFunctor (Env addr) where
hmap f = \case
Alloc name k -> Alloc name (f . k)
Bind name addr m k -> Bind name addr (f m) (f . k)
Lookup name k -> Lookup name (f . k)
instance Effect (Env addr) where
thread ctx hdl = \case
Alloc name k -> Alloc name (hdl . (<$ ctx) . k)
Bind name addr m k -> Bind name addr (hdl (m <$ ctx)) (hdl . fmap k)
Lookup name k -> Lookup name (hdl . (<$ ctx) . k)
data Env addr m k where
Alloc :: Name -> Env addr m addr
Bind :: Name -> addr -> m a -> Env addr m a
Lookup :: Name -> Env addr m (Maybe addr)

19
semantic-analysis/src/Analysis/Effect/Heap.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
module Analysis.Effect.Heap
( -- * Heap effect
deref
@ -11,19 +12,15 @@ module Analysis.Effect.Heap
) where
import Control.Algebra
import GHC.Generics (Generic1)
import Data.Kind (Type)
deref :: Has (Heap addr value) sig m => addr -> m (Maybe value)
deref addr = send (Deref addr pure)
deref addr = send (Deref addr)
assign :: Has (Heap addr value) sig m => addr -> value -> m ()
assign addr value = send (Assign addr value (pure ()))
assign addr value = send (Assign addr value)
data Heap addr value m k
= Deref addr (Maybe value -> m k)
| Assign addr value (m k)
deriving (Functor, Generic1)
instance HFunctor (Heap addr value)
instance Effect (Heap addr value)
data Heap addr value (m :: Type -> Type) k where
Deref :: addr -> Heap addr value m (Maybe value)
Assign :: addr -> value -> Heap addr value m ()

5
semantic-analysis/src/Analysis/FlowInsensitive.hs
View File

@ -24,8 +24,7 @@ type Heap value = Map.Map Name (Set.Set value)
convergeTerm :: forall term value m sig
. ( Effect sig
, Has Fresh sig m
. ( Has Fresh sig m
, Has (State (Heap value)) sig m
, Ord term
, Ord value
@ -61,7 +60,7 @@ cacheTerm eval term = do
result <$ modify (Cache . Map.insertWith (<>) term (Set.singleton (result :: value)) . unCache)
runHeap :: StateC (Heap value) m a -> m (Heap value, a)
runHeap m = runState Map.empty m
runHeap = runState Map.empty
-- | Iterate a monadic action starting from some initial seed until the results converge.
--

42
semantic-analysis/src/Analysis/ImportGraph.hs
View File

@ -1,11 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
@ -90,8 +89,7 @@ importGraph eval
runFile
:: forall term m sig
. ( Effect sig
, Has Fresh sig m
. ( Has Fresh sig m
, Has (State (Heap (Value (Semi term)))) sig m
, Monad term
, forall a . Eq a => Eq (term a)
@ -114,9 +112,9 @@ runFile eval file = traverse run file
runDomain :: (term Addr -> m (Value (Semi term))) -> DomainC term m a -> m a
runDomain eval (DomainC m) = runReader eval m
runDomain eval = runReader eval . runDomainC
newtype DomainC term m a = DomainC (ReaderC (term Addr -> m (Value (Semi term))) m a)
newtype DomainC term m a = DomainC { runDomainC :: ReaderC (term Addr -> m (Value (Semi term))) m a }
deriving (Alternative, Applicative, Functor, Monad, MonadFail)
instance MonadTrans (DomainC term) where
@ -124,26 +122,26 @@ instance MonadTrans (DomainC term) where
-- FIXME: decompose into a product domain and two atomic domains
instance (Alternative m, Has (Env Addr :+: A.Heap Addr (Value (Semi term)) :+: Reader Path.AbsRelFile :+: Reader Span) sig m, MonadFail m) => Algebra (A.Domain term Addr (Value (Semi term)) :+: sig) (DomainC term m) where
alg = \case
L (L (A.Unit k)) -> k mempty
L (R (L (A.Bool _ k))) -> k mempty
L (R (L (A.AsBool _ k))) -> k True <|> k False
L (R (R (L (A.String s k)))) -> k (Value (String s) mempty)
L (R (R (L (A.AsString _ k)))) -> k mempty
L (R (R (R (L (A.Lam b k))))) -> do
alg hdl sig ctx = case sig of
L (L A.Unit) -> pure (mempty <$ ctx)
L (R (L (A.Bool _ ))) -> pure (mempty <$ ctx)
L (R (L (A.AsBool _))) -> pure (True <$ ctx) <|> pure (False <$ ctx)
L (R (R (L (A.String s)))) -> pure (Value (String s) mempty <$ ctx)
L (R (R (L (A.AsString _)))) -> pure (mempty <$ ctx)
L (R (R (R (L (A.Lam b ))))) -> do
path <- ask
span <- ask
k (Value (Closure path span b) mempty)
L (R (R (R (L (A.AsLam (Value v _) k))))) -> case v of
Closure _ _ b -> k b
String _ -> fail $ "expected closure, got String"
Abstract -> fail $ "expected closure, got Abstract"
L (R (R (R (R (A.Record f k))))) -> do
pure (Value (Closure path span b) mempty <$ ctx)
L (R (R (R (L (A.AsLam (Value v _)))))) -> case v of
Closure _ _ b -> pure (b <$ ctx)
String _ -> fail "expected closure, got String"
Abstract -> fail "expected closure, got Abstract"
L (R (R (R (R (A.Record f))))) -> do
eval <- DomainC ask
fields <- for f $ \ (k, t) -> do
addr <- alloc @Addr k
v <- lift (eval t)
v <$ A.assign @Addr @(Value (Semi term)) addr v
k (fold fields)
L (R (R (R (R (A.AsRecord _ k))))) -> k []
R other -> DomainC (send (handleCoercible other))
pure (fold fields <$ ctx)
L (R (R (R (R (A.AsRecord _))))) -> pure ([] <$ ctx)
R other -> DomainC (alg (runDomainC . hdl) (R other) ctx)

1
semantic-analysis/src/Analysis/Intro.hs
View File

@ -16,6 +16,7 @@ import Control.Algebra
import Data.Text (Text)
import GHC.Generics (Generic1)
import Syntax.Foldable
import Syntax.Functor
import Syntax.Module
import Syntax.Scope
import Syntax.Traversable

58
semantic-analysis/src/Analysis/Typecheck.hs
View File

@ -3,12 +3,12 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
@ -50,8 +50,11 @@ import Data.Void
import GHC.Generics (Generic1)
import Prelude hiding (fail)
import Source.Span
import qualified Syntax.Algebra as Syntax
import Syntax.Functor
import Syntax.Module
import Syntax.Scope
import qualified Syntax.Sum as Syntax
import Syntax.Term
import Syntax.Var (closed)
import qualified System.Path as Path
@ -99,14 +102,14 @@ deriving instance (Ord a, forall a . Eq a => Eq (f a)
deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Polytype f a)
forAll :: (Eq a, Has Polytype sig m) => a -> m a -> m a
forAll n body = send (PForAll (abstract1 n body))
forAll :: (Eq a, Syntax.Has Polytype sig m) => a -> m a -> m a
forAll n body = Syntax.send (PForAll (abstract1 n body))
forAlls :: (Eq a, Has Polytype sig m, Foldable t) => t a -> m a -> m a
forAlls :: (Eq a, Syntax.Has Polytype sig m, Foldable t) => t a -> m a -> m a
forAlls ns body = foldr forAll body ns
generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Void
generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty)))
generalize :: Term Monotype Meta -> Term (Polytype Syntax.:+: Monotype) Void
generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm Syntax.R ty)))
typecheckingFlowInsensitive
@ -118,7 +121,7 @@ typecheckingFlowInsensitive
)
-> [File (term Addr)]
-> ( Heap Type
, [File (Either (Path.AbsRelFile, Span, String) (Term (Polytype :+: Monotype) Void))]
, [File (Either (Path.AbsRelFile, Span, String) (Term (Polytype Syntax.:+: Monotype) Void))]
)
typecheckingFlowInsensitive eval
= run
@ -128,8 +131,7 @@ typecheckingFlowInsensitive eval
. traverse (runFile eval)
runFile
:: ( Effect sig
, Has Fresh sig m
:: ( Has Fresh sig m
, Has (State (Heap Type)) sig m
, Has Intro.Intro syn term
, Ord (term Addr)
@ -211,9 +213,9 @@ substAll s a = a >>= \ i -> fromMaybe (pure i) (IntMap.lookup i s)
runDomain :: (term Addr -> m Type) -> DomainC term m a -> m a
runDomain eval (DomainC m) = runReader eval m
runDomain eval = runReader eval . runDomainC
newtype DomainC term m a = DomainC (ReaderC (term Addr -> m Type) m a)
newtype DomainC term m a = DomainC { runDomainC :: ReaderC (term Addr -> m Type) m a }
deriving (Alternative, Applicative, Functor, Monad, MonadFail)
instance MonadTrans (DomainC term) where
@ -229,29 +231,27 @@ instance ( Alternative m
, Has Intro.Intro syn term
)
=> Algebra (A.Domain term Addr Type :+: sig) (DomainC term m) where
alg = \case
L (L (A.Unit k)) -> k (Alg Unit)
L (R (L (A.Bool _ k))) -> k (Alg Bool)
L (R (L (A.AsBool t k))) -> do
alg hdl sig ctx = case sig of
L (L A.Unit) -> pure (Alg Unit <$ ctx)
L (R (L (A.Bool _))) -> pure (Alg Bool <$ ctx)
L (R (L (A.AsBool t))) -> do
unify t (Alg Bool)
k True <|> k False
L (R (R (L (A.String _ k)))) -> k (Alg String)
L (R (R (L (A.AsString t k)))) -> do
unify t (Alg String)
k mempty
L (R (R (R (L (A.Lam (Named n b) k))))) -> do
pure (True <$ ctx) <|> pure (False <$ ctx)
L (R (R (L (A.String _)))) -> pure (Alg String <$ ctx)
L (R (R (L (A.AsString t)))) -> (mempty <$ ctx) <$ unify t (Alg String)
L (R (R (R (L (A.Lam (Named n b)))))) -> do
eval <- DomainC ask
addr <- alloc @Name n
arg <- meta
A.assign addr arg
ty <- lift (eval (instantiate1 (pure n) b))
k (Alg (arg :-> ty))
L (R (R (R (L (A.AsLam t k))))) -> do
pure (Alg (arg :-> ty) <$ ctx)
L (R (R (R (L (A.AsLam t))))) -> do
arg <- meta
ret <- meta
unify t (Alg (arg :-> ret))
b <- concretize ret
k (Named (name mempty) (lift b)) where
pure (Named (name mempty) (lift b) <$ ctx) where
concretize = \case
Alg Unit -> pure Intro.unit
Alg Bool -> pure (Intro.bool True) <|> pure (Intro.bool False)
@ -259,16 +259,16 @@ instance ( Alternative m
Alg (_ :-> b) -> send . Intro.Lam . Named (name mempty) . lift <$> concretize b
Alg (Record t) -> Intro.record <$> traverse (traverse concretize) (Map.toList t)
t -> fail $ "can’t concretize " <> show t -- FIXME: concretize type variables by incrementally solving constraints
L (R (R (R (R (A.Record fields k))))) -> do
L (R (R (R (R (A.Record fields))))) -> do
eval <- DomainC ask
fields' <- for fields $ \ (k, t) -> do
addr <- alloc @Addr k
v <- lift (eval t)
(k, v) <$ A.assign addr v
-- FIXME: should records reference types by address instead?
k (Alg (Record (Map.fromList fields')))
L (R (R (R (R (A.AsRecord t k))))) -> do
pure (Alg (Record (Map.fromList fields')) <$ ctx)
L (R (R (R (R (A.AsRecord t))))) -> do
unify t (Alg (Record mempty))
k mempty -- FIXME: return whatever fields we have, when it’s actually a Record
pure (mempty <$ ctx) -- FIXME: return whatever fields we have, when it’s actually a Record
R other -> DomainC (send (handleCoercible other))
R other -> DomainC (alg (runDomainC . hdl) (R other) ctx)

36
semantic-analysis/src/Control/Carrier/Fail/WithLoc.hs
View File

@ -1,19 +1,23 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Carrier.Fail.WithLoc
( -- * Fail effect
module Control.Effect.Fail
-- * Fail carrier
, runFail
( -- * Fail carrier
runFail
, FailC(..)
-- * Fail effect
, module Control.Effect.Fail
) where
import Control.Applicative
import Control.Algebra
import Control.Carrier.Error.Either
import Control.Effect.Fail
import Control.Effect.Reader
import Prelude hiding (fail)
import Source.Span
import Control.Algebra
import Control.Applicative
import Control.Carrier.Error.Either
import Control.Effect.Fail
import Control.Effect.Reader
import Prelude hiding (fail)
import Source.Span
import qualified System.Path as Path
runFail :: FailC m a -> m (Either (Path.AbsRelFile, Span, String) a)
@ -22,12 +26,12 @@ runFail = runError . runFailC
newtype FailC m a = FailC { runFailC :: ErrorC (Path.AbsRelFile, Span, String) m a }
deriving (Alternative, Applicative, Functor, Monad)
instance (Effect sig, Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => MonadFail (FailC m) where
instance (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => MonadFail (FailC m) where
fail s = do
path <- ask
span <- ask
FailC (throwError (path :: Path.AbsRelFile, span :: Span, s))
instance (Effect sig, Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => Algebra (Fail :+: sig) (FailC m) where
alg (L (Fail s)) = fail s
alg (R other) = FailC (alg (R (handleCoercible other)))
instance (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => Algebra (Fail :+: sig) (FailC m) where
alg _ (L (Fail s)) _ = fail s
alg hdl (R other) ctx = FailC (alg (runFailC . hdl) (R other) ctx)

2
semantic-ast/semantic-ast.cabal
View File

@ -63,7 +63,7 @@ library
, containers >= 0.6.0.1
, directory ^>= 1.3.3.2
, filepath ^>= 1.4.1
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, tree-sitter ^>= 0.9.0.0
, semantic-source ^>= 0.1.0
, template-haskell ^>= 2.15

7
semantic-ast/src/AST/Unmarshal.hs
View File

@ -29,8 +29,7 @@ module AST.Unmarshal
import AST.Token as TS
import AST.Parse
import Control.Algebra (send)
import Control.Carrier.Reader hiding (asks)
import Control.Carrier.Reader
import Control.Exception
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
@ -60,10 +59,6 @@ import TreeSitter.Node as TS
import TreeSitter.Parser as TS
import TreeSitter.Tree as TS
asks :: Has (Reader r) sig m => (r -> r') -> m r'
asks f = send (Ask (pure . f))
{-# INLINE asks #-}
-- Parse source code and produce AST
parseByteString :: (Unmarshal t, UnmarshalAnn a) => Ptr TS.Language -> ByteString -> IO (Either String (t a))
parseByteString language bytestring = withParser language $ \ parser -> withParseTree parser bytestring $ \ treePtr ->

2
semantic-codeql/semantic-codeql.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-core/semantic-core.cabal
View File

@ -47,7 +47,7 @@ library
Core.Name
build-depends:
base >= 4.13 && < 5
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, hashable
, parsers ^>= 0.12.10

3
semantic-core/src/Core/Core.hs
View File

@ -47,7 +47,6 @@ module Core.Core
, stripAnnotations
) where
import Control.Algebra
import Control.Applicative (Alternative (..))
import Core.Name
import Data.Bifunctor (Bifunctor (..))
@ -58,7 +57,9 @@ import Data.Text (Text)
import GHC.Generics (Generic1)
import GHC.Stack
import Source.Span
import Syntax.Algebra
import Syntax.Foldable
import Syntax.Functor
import Syntax.Module
import Syntax.Scope
import Syntax.Stack

28
semantic-core/src/Core/Eval.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
@ -21,7 +20,6 @@ import qualified Analysis.Effect.Domain as A
import Analysis.Effect.Env as A
import Analysis.Effect.Heap as A
import Analysis.File
import Control.Algebra
import Control.Applicative (Alternative (..))
import Control.Effect.Fail
import Control.Effect.Reader
@ -33,11 +31,13 @@ import Data.Maybe (fromMaybe, isJust)
import GHC.Stack
import Prelude hiding (fail)
import Source.Span
import qualified Syntax.Algebra as Syntax
import Syntax.Scope
import qualified Syntax.Sum as Syntax
import qualified Syntax.Term as Term
import qualified System.Path as Path
type Term = Term.Term (Ann Span :+: Core)
type Term = Term.Term (Ann Span Syntax.:+: Core)
eval :: forall address value m sig
. ( Has (A.Domain Term address value) sig m
@ -52,7 +52,7 @@ eval :: forall address value m sig
-> (Term address -> m value)
eval eval = \case
Term.Var n -> deref' n n
Term.Alg (R c) -> case c of
Term.Alg (Syntax.R c) -> case c of
Rec (Named n b) -> do
addr <- A.alloc @address n
v <- A.bind n addr (eval (instantiate1 (pure addr) b))
@ -92,7 +92,7 @@ eval eval = \case
b' <- eval b
addr <- ref a
b' <$ A.assign addr b'
Term.Alg (L (Ann span c)) -> local (const span) (eval c)
Term.Alg (Syntax.L (Ann span c)) -> local (const span) (eval c)
where freeVariable s = fail ("free variable: " <> s)
uninitialized s = fail ("uninitialized variable: " <> s)
invalidRef s = fail ("invalid ref: " <> s)
@ -101,7 +101,7 @@ eval eval = \case
ref = \case
Term.Var n -> pure n
Term.Alg (R c) -> case c of
Term.Alg (Syntax.R c) -> case c of
If c t e -> do
c' <- eval c >>= A.asBool
if c' then ref t else ref e
@ -109,33 +109,33 @@ eval eval = \case
a' <- eval a >>= A.asRecord
maybe (freeVariable (show b)) ref (lookup b a')
c -> invalidRef (show c)
Term.Alg (L (Ann span c)) -> local (const span) (ref c)
Term.Alg (Syntax.L (Ann span c)) -> local (const span) (ref c)
prog1 :: Has Core sig t => File (t Name)
prog1 :: Syntax.Has Core sig t => File (t Name)
prog1 = fromBody $ Core.lam (named' "foo")
( named' "bar" :<- pure "foo"
>>>= Core.if' (pure "bar")
(Core.bool False)
(Core.bool True))
prog2 :: Has Core sig t => File (t Name)
prog2 :: Syntax.Has Core sig t => File (t Name)
prog2 = fromBody $ fileBody prog1 $$ Core.bool True
prog3 :: Has Core sig t => File (t Name)
prog3 :: Syntax.Has Core sig t => File (t Name)
prog3 = fromBody $ lams [named' "foo", named' "bar", named' "quux"]
(Core.if' (pure "quux")
(pure "bar")
(pure "foo"))
prog4 :: Has Core sig t => File (t Name)
prog4 :: Syntax.Has Core sig t => File (t Name)
prog4 = fromBody
( named' "foo" :<- Core.bool True
>>>= Core.if' (pure "foo")
(Core.bool True)
(Core.bool False))
prog5 :: (Has (Ann Span) sig t, Has Core sig t) => File (t Name)
prog5 :: (Syntax.Has (Ann Span) sig t, Syntax.Has Core sig t) => File (t Name)
prog5 = fromBody $ ann (do'
[ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record
[ ("x", ann (pure "_x"))
@ -146,7 +146,7 @@ prog5 = fromBody $ ann (do'
, Nothing :<- ann (ann (pure "point") Core.... "y") .= ann (ann (pure "point") Core.... "x")
])
prog6 :: Has Core sig t => [File (t Name)]
prog6 :: Syntax.Has Core sig t => [File (t Name)]
prog6 =
[ (fromBody (Core.record
[ ("dep", Core.record [ ("var", Core.bool True) ]) ]))
@ -158,7 +158,7 @@ prog6 =
{ filePath = Path.absRel "main" }
]
ruby :: (Has (Ann Span) sig t, Has Core sig t) => File (t Name)
ruby :: (Syntax.Has (Ann Span) sig t, Syntax.Has Core sig t) => File (t Name)
ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements))
where statements =
[ Just "Class" :<- record

4
semantic-core/src/Core/Parser.hs
View File

@ -11,7 +11,6 @@ module Core.Parser
-- Consult @doc/grammar.md@ for an EBNF grammar.
import Control.Algebra
import Control.Applicative
import Control.Monad
import Core.Core ((:<-) (..), Core)
@ -21,6 +20,7 @@ import qualified Data.Char as Char
import Data.Foldable (foldl')
import Data.Function
import Data.String
import Syntax.Algebra
import Text.Parser.LookAhead (LookAheadParsing)
import qualified Text.Parser.Token as Token
import qualified Text.Parser.Token.Highlight as Highlight
@ -70,7 +70,7 @@ assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment"
where rhs = flip (Core..=) <$> application
application :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
application = projection `chainl1` (pure (Core.$$))
application = projection `chainl1` pure (Core.$$)
projection :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
projection = foldl' (&) <$> atom <*> many (choice [ flip (Core..?) <$ symbol ".?" <*> identifier

2
semantic-core/test/Generators.hs
View File

@ -17,10 +17,10 @@ import Hedgehog hiding (Var)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Control.Algebra
import qualified Core.Core as Core
import Core.Name (Name, Named)
import qualified Core.Name as Name
import Syntax.Algebra
-- The 'prune' call here ensures that we don't spend all our time just generating
-- fresh names for variables, since the length of variable names is not an

2
semantic-go/semantic-go.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-java/semantic-java.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-json/semantic-json.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-php/semantic-php.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-python/semantic-python.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0.0.1
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-analysis ^>= 0

19
semantic-python/src/Language/Python/Failure.hs
View File

@ -1,6 +1,15 @@
{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, ExistentialQuantification,
FlexibleContexts, KindSignatures, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes,
StandaloneDeriving, TypeOperators #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
module Language.Python.Failure
( Failure (..)
@ -11,13 +20,15 @@ module Language.Python.Failure
import Prelude hiding (fail)
import Control.Algebra
import Control.Monad.Fail
import Data.Coerce
import Data.Kind
import GHC.Generics (Generic1)
import Syntax.Algebra
import Syntax.Foldable
import Syntax.Functor
import Syntax.Module
import Syntax.Sum
import Syntax.Term
import Syntax.Traversable

2
semantic-ruby/semantic-ruby.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-rust/semantic-rust.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-scope-graph/semantic-scope-graph.cabal
View File

@ -40,7 +40,7 @@ library
, aeson
, algebraic-graphs >= 0.3 && < 0.5
, containers
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, generic-monoid
, generic-lens
, hashable

2
semantic-tags/semantic-tags.cabal
View File

@ -44,7 +44,7 @@ library
build-depends:
base >= 4.13 && < 5
, bytestring ^>= 0.10.8.2
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, semantic-source ^>= 0.1.0
, semantic-proto ^>= 0
, text ^>= 1.2.3.1

2
semantic-tsx/semantic-tsx.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

2
semantic-typescript/semantic-typescript.cabal
View File

@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
build-depends: base ^>= 4.13
, fused-effects ^>= 1.0
, fused-effects ^>= 1.1
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast

3
semantic/BUILD.bazel
View File

@ -35,7 +35,6 @@ semantic_common_dependencies = [
"@stackage//:directory",
"@stackage//:fused-effects",
"@stackage//:fused-effects-exceptions",
"@stackage//:fused-effects-resumable",
"@stackage//:hashable",
"@stackage//:network",
"@stackage//:pathtype",
@ -56,7 +55,6 @@ haskell_library(
"//:base",
"//:deepseq",
"//:filepath",
"//:haskeline",
"//:template-haskell",
"//semantic-codeql",
"//semantic-go",
@ -78,6 +76,7 @@ haskell_library(
"@stackage//:fused-syntax",
"@stackage//:generic-lens",
"@stackage//:generic-monoid",
"@stackage//:haskeline",
"@stackage//:hostname",
"@stackage//:hscolour",
"@stackage//:lens",

12
semantic/semantic.cabal
View File

@ -42,6 +42,10 @@ common haskell
-DBAZEL_BUILD=0
if (impl(ghc >= 8.8))
ghc-options: -Wno-missing-deriving-strategies
if (impl(ghc >= 8.10))
ghc-options:
-Wno-missing-safe-haskell-mode
-Wno-prepositive-qualified-module
-- Except in case of vendored dependencies, these deps should be expressed
@ -56,9 +60,8 @@ common dependencies
, bytestring ^>= 0.10.8.2
, containers ^>= 0.6.0.1
, directory ^>= 1.3.3.0
, fused-effects ^>= 1
, fused-effects-exceptions ^>= 1
, fused-effects-resumable ^>= 0.1
, fused-effects ^>= 1.1
, fused-effects-exceptions ^>= 1.1
, hashable >= 1.2.7 && < 1.4
, tree-sitter ^>= 0.9.0.1
, network ^>= 2.8.0.0
@ -84,9 +87,7 @@ library
exposed-modules: Control.Carrier.Parse.Measured
, Control.Carrier.Parse.Simple
-- Effects
, Control.Effect.Interpose
, Control.Effect.Parse
, Control.Effect.REPL
, Control.Effect.Sum.Project
, Control.Effect.Timeout
-- General datatype definitions & generic algorithms
@ -114,7 +115,6 @@ library
, Semantic.Distribute
, Semantic.Env
, Semantic.IO
, Semantic.Resolution
, Semantic.Task
, Semantic.Task.Files
, Semantic.Telemetry

15
semantic/src/Control/Carrier/Parse/Measured.hs
View File

@ -44,8 +44,9 @@ instance ( Has (Error SomeException) sig m
, MonadIO m
)
=> Algebra (Parse :+: sig) (ParseC m) where
alg (L (Parse parser blob k)) = runParser blob parser >>= k
alg (R other) = ParseC (alg (handleCoercible other))
alg hdl sig ctx = case sig of
L (Parse parser blob) -> (<$ ctx) <$> runParser blob parser
R other -> ParseC (alg (runParse . hdl) other ctx)
-- | Parse a 'Blob' in 'IO'.
runParser ::
@ -60,14 +61,14 @@ runParser ::
-> m term
runParser blob@Blob{..} parser = case parser of
UnmarshalParser language -> do
(time "parse.tree_sitter_precise_ast_parse" languageTag $ do
UnmarshalParser language ->
time "parse.tree_sitter_precise_ast_parse" languageTag $ do
config <- asks config
executeParserAction (parseToPreciseAST (configTreeSitterParseTimeout config) (configTreeSitterUnmarshalTimeout config) language blob))
`catchError` (\(SomeException e) -> do
executeParserAction (parseToPreciseAST (configTreeSitterParseTimeout config) (configTreeSitterUnmarshalTimeout config) language blob)
`catchError` \(SomeException e) -> do
writeStat (increment "parse.precise_ast_parse_failures" languageTag)
writeLog Error "precise parsing failed" (("task", "parse") : ("exception", "\"" <> displayException e <> "\"") : languageTag)
throwError (SomeException e))
throwError (SomeException e)
where
languageTag = [("language" :: String, show (blobLanguage blob))]

11
semantic/src/Control/Carrier/Parse/Simple.hs
View File

@ -9,7 +9,7 @@
-- | A carrier for 'Parse' effects suitable for use in the repl, tests, etc.
module Control.Carrier.Parse.Simple
( -- * Parse carrier
ParseC(..)
ParseC(ParseC)
, runParse
-- * Exceptions
, ParseFailure(..)
@ -28,17 +28,18 @@ import Parsing.Parser
import Parsing.TreeSitter
runParse :: Duration -> ParseC m a -> m a
runParse timeout (ParseC m) = runReader timeout m
runParse timeout = runReader timeout . runParseC
newtype ParseC m a = ParseC (ReaderC Duration m a)
newtype ParseC m a = ParseC { runParseC :: ReaderC Duration m a }
deriving (Applicative, Functor, Monad, MonadFail, MonadIO)
instance ( Has (Error SomeException) sig m
, MonadIO m
)
=> Algebra (Parse :+: sig) (ParseC m) where
alg (L (Parse parser blob k)) = ParseC ask >>= \ timeout -> runParser timeout blob parser >>= k
alg (R other) = ParseC (send (handleCoercible other))
alg hdl sig ctx = case sig of
L (Parse parser blob) -> ParseC ask >>= \ timeout -> (<$ ctx) <$> runParser timeout blob parser
R other -> ParseC (alg (runParseC . hdl) (R other) ctx)
-- | Parse a 'Blob' in 'IO'.
runParser

57
semantic/src/Control/Effect/Interpose.hs
View File

@ -1,57 +0,0 @@
{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Interpose
( Interpose(..)
, interpose
, runInterpose
, InterposeC(..)
, Listener(..)
) where
import Control.Applicative
import Control.Algebra
import Control.Carrier.Reader
import Control.Effect.Sum.Project
data Interpose (eff :: (* -> *) -> * -> *) m k
= forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k)
deriving instance Functor m => Functor (Interpose eff m)
instance HFunctor (Interpose eff) where
hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k)
-- | Respond to requests for some specific effect with a handler.
--
-- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request.
--
-- 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 :: Has (Interpose eff) sig m
=> m a
-> (forall n x . eff n x -> m x)
-> m a
interpose m f = send (Interpose m f pure)
-- | Run an 'Interpose' effect.
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 Listener (eff :: (* -> *) -> * -> *) m = Listener (forall n x . eff n x -> m x)
-- 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 (Has eff sig m, Project eff sig) => Algebra (Interpose eff :+: sig) (InterposeC eff m) where
alg (L (Interpose m h k)) =
InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= k
alg (R other) = do
listener <- InterposeC ask
case (listener, prj other) of
(Just listener, Just eff) -> runListener listener eff
_ -> InterposeC (alg (R (handleCoercible other)))

19
semantic/src/Control/Effect/Parse.hs
View File

@ -1,10 +1,8 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Effect.Parse
( -- * Parse effect
Parse(..)
@ -25,20 +23,13 @@ import Control.Exception (SomeException)
import Data.Bitraversable
import Data.Blob
import Data.Edit
import Data.Kind (Type)
import qualified Data.Map as Map
import Parsing.Parser
import Source.Language (Language (..))
data Parse m k
= forall term . Parse (Parser term) Blob (term -> m k)
deriving instance Functor m => Functor (Parse m)
instance HFunctor Parse where
hmap f (Parse parser blob k) = Parse parser blob (f . k)
instance Effect Parse where
thread state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
data Parse (m :: Type -> Type) k where
Parse :: Parser term -> Blob -> Parse m term
-- | Parse a 'Blob' with the given 'Parser'.
@ -46,7 +37,7 @@ parse :: Has Parse sig m
=> Parser term
-> Blob
-> m term
parse parser blob = send (Parse parser blob pure)
parse parser blob = send (Parse parser blob)
-- | Select a parser for the given 'Language'.

61
semantic/src/Control/Effect/REPL.hs
View File

@ -1,61 +0,0 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Effect.REPL
( REPL (..)
, REPLC (..)
, prompt
, output
, runREPL
) where
import Control.Algebra
import Control.Carrier.Reader
import Control.Monad.IO.Class
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic1)
import System.Console.Haskeline
data REPL (m :: * -> *) k
= Prompt Text (Maybe Text -> m k)
| Output Text (m k)
deriving (Functor, Generic1)
instance HFunctor REPL
instance Effect REPL
prompt :: Has REPL sig m => Text -> m (Maybe Text)
prompt p = send (Prompt p pure)
output :: Has REPL sig m => Text -> m ()
output s = send (Output s (pure ()))
runREPL :: Prefs -> Settings IO -> REPLC m a -> m a
runREPL prefs settings = runReader (prefs, settings) . runREPLC
newtype REPLC m a = REPLC { runREPLC :: ReaderC (Prefs, Settings IO) m a }
deriving (Functor, Applicative, Monad, MonadIO)
instance (Algebra sig m, MonadIO m) => Algebra (REPL :+: sig) (REPLC m) where
alg (L op) = do
args <- REPLC ask
case op of
Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k
alg (R other) = REPLC (alg (R (handleCoercible other)))
cyan :: String
cyan = "\ESC[1;36m\STX"
plain :: String
plain = "\ESC[0m\STX"

3
semantic/src/Control/Effect/Timeout.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Control.Effect.Timeout
( timeout
) where
@ -15,7 +14,7 @@ import qualified System.Timeout as System
--
-- Any state changes in the action are discarded if the timeout fails.
timeout :: Has (Lift IO) sig m => Duration -> m a -> m (Maybe a)
timeout n m = liftWith $ \ ctx hdl
timeout n m = liftWith $ \ hdl ctx
-> maybe
-- Restore the old state if it timed out.
(Nothing <$ ctx)

24
semantic/src/Semantic/Distribute.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
@ -31,7 +32,7 @@ import Data.Foldable (fold)
--
-- This is a concurrent analogue of 'sequenceA'.
distribute :: (Has Distribute sig m, Traversable t) => t (m output) -> m (t output)
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute pure)
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute)
-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
--
@ -47,16 +48,8 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
-- | Distribute effects run tasks concurrently.
data Distribute m k
= forall a . Distribute (m a) (a -> m k)
deriving instance Functor m => Functor (Distribute m)
instance HFunctor Distribute where
hmap f (Distribute m k) = Distribute (f m) (f . k)
instance Effect Distribute where
thread state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k)
data Distribute m k where
Distribute :: m a -> Distribute m a
-- | Evaluate a 'Distribute' effect concurrently.
@ -81,7 +74,8 @@ instance (MonadIO m, Algebra sig m) => MonadUnliftIO (DistributeC m) where
askUnliftIO = DistributeC . ReaderC $ \ u -> pure (UnliftIO (runDistribute u))
instance (Algebra sig m, MonadIO m) => Algebra (Distribute :+: sig) (DistributeC m) where
alg (L (Distribute task k)) = do
handler <- DistributeC ask
liftIO (Async.runConcurrently (Async.Concurrently (runDistribute handler task))) >>= k
alg (R other) = DistributeC (alg (R (handleCoercible other)))
alg hdl sig ctx = case sig of
L (Distribute task) -> do
handler <- DistributeC ask
liftIO (Async.runConcurrently (Async.Concurrently (runDistribute handler (hdl (task <$ ctx)))))
R other -> DistributeC (alg (runDistributeC . hdl) (R other) ctx)

80
semantic/src/Semantic/Resolution.hs
View File

@ -1,80 +0,0 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Resolution
( Resolution (..)
, nodeJSResolutionMap
, resolutionMap
, runResolution
, ResolutionC(..)
) where
import Analysis.File as File
import Analysis.Project
import Control.Algebra
import Control.Monad.IO.Class
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Blob
import Data.Foldable
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe.Exts
import Data.Text (Text)
import GHC.Generics (Generic1)
import Semantic.Task.Files
import Source.Language
import qualified Source.Source as Source
import System.FilePath.Posix
import qualified System.Path as Path
nodeJSResolutionMap :: Has Files sig m => Path.AbsRelDir -> Text -> [Path.AbsRelDir] -> m (Map FilePath FilePath)
nodeJSResolutionMap rootDir prop excludeDirs = do
files <- findFiles rootDir [".json"] excludeDirs
let packageFiles = File.fromPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files
blobs <- readBlobs (FilesFromPaths packageFiles)
pure $ fold (mapMaybe (lookup prop) blobs)
where
lookup :: Text -> Blob -> Maybe (Map FilePath FilePath)
lookup k b@Blob{..} = decodeStrict (Source.bytes blobSource) >>= lookupProp (blobFilePath b) k
lookupProp :: FilePath -> Text -> Object -> Maybe (Map FilePath FilePath)
lookupProp path k res = flip parseMaybe res $ \obj -> Map.singleton relPkgDotJSONPath . relEntryPath <$> obj .: k
where relPkgDotJSONPath = makeRelative (Path.toString rootDir) path
relEntryPath x = takeDirectory relPkgDotJSONPath </> x
resolutionMap :: Has Resolution sig m => Project -> m (Map FilePath FilePath)
resolutionMap Project{..} = case projectLanguage of
TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure)
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs pure)
_ -> send (NoResolution pure)
data Resolution (m :: * -> *) k
= NodeJSResolution Path.AbsRelDir Text [Path.AbsRelDir] (Map FilePath FilePath -> m k)
| NoResolution (Map FilePath FilePath -> m k)
deriving (Functor, Generic1)
instance HFunctor Resolution
instance Effect Resolution
runResolution :: ResolutionC m a -> m a
runResolution = runResolutionC
newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
deriving (Applicative, Functor, Monad, MonadFail, MonadIO)
instance (Has Files sig m, MonadIO m) => Algebra (Resolution :+: sig) (ResolutionC m) where
alg (R other) = ResolutionC . alg . handleCoercible $ other
alg (L op) = case op of
NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k
NoResolution k -> k Map.empty

21
semantic/src/Semantic/Task.hs
View File

@ -19,9 +19,6 @@ module Semantic.Task
, Files.findFiles
, Files.write
, Files.FilesArg(..)
-- * Module Resolution
, resolutionMap
, Resolution
-- * Telemetry
, writeLog
, writeStat
@ -65,22 +62,20 @@ import Data.ByteString.Builder
import qualified Data.Flag as Flag
import Semantic.Config
import Semantic.Distribute
import Semantic.Resolution
import qualified Semantic.Task.Files as Files
import Semantic.Telemetry
import Serializing.Format
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskC
= ResolutionC
( Files.FilesC
= Files.FilesC
( ReaderC Config
( ReaderC TaskSession
( TraceInTelemetryC
( TelemetryC
( ErrorC SomeException
( DistributeC
( LiftC IO))))))))
( LiftC IO)))))))
serialize :: Has (Reader Config) sig m
=> Format input
@ -113,7 +108,6 @@ runTask taskSession@TaskSession{..} task = do
. runReader taskSession
. runReader config
. Files.runFiles
. runResolution
run task
queueStat statter stat
pure result
@ -129,13 +123,10 @@ withOptions options with = do
config <- defaultConfig options
withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
runTraceInTelemetry :: TraceInTelemetryC m a
-> m a
runTraceInTelemetry = runTraceInTelemetryC
newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a }
newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetry :: m a }
deriving (Applicative, Functor, Monad, MonadFail, MonadIO)
instance Has Telemetry sig m => Algebra (Trace :+: sig) (TraceInTelemetryC m) where
alg (R other) = TraceInTelemetryC . alg . handleCoercible $ other
alg (L (Trace str k)) = writeLog Debug str [] >> k
alg hdl sig ctx = case sig of
L (Trace str) -> ctx <$ writeLog Debug str []
R other -> TraceInTelemetryC (alg (runTraceInTelemetry . hdl) other ctx)

73
semantic/src/Semantic/Task/Files.hs
View File

@ -1,13 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
@ -15,7 +12,6 @@ module Semantic.Task.Files
( Files
, Destination (..)
, Source (..)
, runFiles
, readBlob
, readBlobs
, readBlobPairs
@ -53,47 +49,34 @@ data Source blob where
data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) k
= forall a . Read (Source a) (a -> m k)
| ReadProject (Maybe Path.AbsRelDir) Path.AbsRelFileDir Language [Path.AbsRelDir] (Project -> m k)
| FindFiles Path.AbsRelDir [String] [Path.AbsRelDir] ([Path.AbsRelFile] -> m k)
| Write Destination B.Builder (m k)
data Files (m :: * -> *) k where
Read :: Source a -> Files m a
ReadProject :: Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> Files m Project
FindFiles :: Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> Files m [Path.AbsRelFile]
Write :: Destination -> B.Builder -> Files m ()
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
thread state handler (Read s k) = Read s (handler . (<$ state) . k)
thread state handler (ReadProject mp p l ps k) = ReadProject mp p l ps (handler . (<$ state) . k)
thread state handler (FindFiles p s ps k) = FindFiles p s ps (handler . (<$ state) . k)
thread state handler (Write d b k) = Write d b (handler . (<$ state) $ k)
-- | Run a 'Files' effect in 'IO'
runFiles :: FilesC m a -> m a
runFiles = runFilesC
newtype FilesC m a = FilesC { runFilesC :: m a }
newtype FilesC m a = FilesC
{ -- | Run a 'Files' effect in 'IO'
runFiles :: m a
}
deriving (Functor, Applicative, Monad, MonadFail, MonadIO)
instance (Has (Error SomeException) sig m, MonadFail m, MonadIO m) => Algebra (Files :+: sig) (FilesC m) where
alg (R other) = FilesC (alg (handleCoercible other))
alg (L op) = case op of
Read (FromPath path) k -> readBlobFromFile' path >>= k
Read (FromHandle handle) k -> readBlobsFromHandle handle >>= k
Read (FromPathPair p1 p2) k -> readFilePair p1 p2 >>= k
Read (FromPairHandle handle) k -> readBlobPairsFromHandle handle >>= k
ReadProject rootDir dir language excludeDirs k -> readProjectFromPaths rootDir dir language excludeDirs >>= k
FindFiles dir exts excludeDirs k -> findFilesInDir dir exts excludeDirs >>= k
Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k
Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k
alg hdl sig ctx = case sig of
L op -> (<$ ctx) <$> case op of
Read (FromPath path) -> readBlobFromFile' path
Read (FromHandle handle) -> readBlobsFromHandle handle
Read (FromPathPair p1 p2) -> readFilePair p1 p2
Read (FromPairHandle handle) -> readBlobPairsFromHandle handle
ReadProject rootDir dir language excludeDirs -> readProjectFromPaths rootDir dir language excludeDirs
FindFiles dir exts excludeDirs -> findFilesInDir dir exts excludeDirs
Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
R other -> FilesC (alg (runFiles . hdl) other ctx)
readBlob :: Has Files sig m => File Language -> m Blob
readBlob file = send (Read (FromPath file) pure)
readBlob file = send (Read (FromPath file))
-- Various ways to read in files
data FilesArg
@ -102,20 +85,20 @@ data FilesArg
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: Has Files sig m => FilesArg -> m [Blob]
readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure)
readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle))
readBlobs (FilesFromPaths paths) = traverse (send . Read . FromPath) paths
-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File Language, File Language)] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . uncurry FromPathPair) paths
readProject :: Has Files sig m => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure)
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs)
findFiles :: Has Files sig m => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile]
findFiles dir exts paths = send (FindFiles dir exts paths pure)
findFiles dir exts paths = send (FindFiles dir exts paths)
-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
write :: Has Files sig m => Destination -> B.Builder -> m ()
write dest builder = send (Write dest builder (pure ()))
write dest builder = send (Write dest builder)

47
semantic/src/Semantic/Telemetry.hs
View File

@ -1,4 +1,14 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, RecordWildCards, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Telemetry
(
-- Async telemetry interface
@ -55,7 +65,6 @@ 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
@ -118,11 +127,11 @@ queueStat q = liftIO . writeAsyncQueue q
-- | A task which logs a message at a specific log level to stderr.
writeLog :: Has Telemetry sig m => Level -> String -> [(String, String)] -> m ()
writeLog level message pairs = send (WriteLog level message pairs (pure ()))
writeLog level message pairs = send (WriteLog level message pairs)
-- | A task which writes a stat.
writeStat :: Has Telemetry sig m => Stat -> m ()
writeStat stat = send (WriteStat stat (pure ()))
writeStat stat = send (WriteStat stat)
-- | A task which measures and stats the timing of another task.
time :: (Has Telemetry sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
@ -135,13 +144,9 @@ time' :: MonadIO m => m output -> m (output, Double)
time' = withTiming'
-- | Statting and logging effects.
data Telemetry (m :: * -> *) k
= WriteStat Stat (m k)
| WriteLog Level String [(String, String)] (m k)
deriving (Functor, Generic1)
instance HFunctor Telemetry
instance Effect Telemetry
data Telemetry (m :: * -> *) k where
WriteStat :: Stat -> Telemetry m ()
WriteLog :: Level -> String -> [(String, String)] -> Telemetry m ()
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
runTelemetry :: LogQueue -> StatQueue -> TelemetryC m a -> m a
@ -151,12 +156,13 @@ newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQu
deriving (Applicative, Functor, Monad, MonadFail, MonadIO)
instance (Algebra sig m, MonadIO m) => Algebra (Telemetry :+: sig) (TelemetryC m) where
alg (L op) = do
queues <- TelemetryC ask
case op of
WriteStat stat k -> queueStat (snd queues) stat *> k
WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> k
alg (R other) = TelemetryC (alg (R (handleCoercible other)))
alg hdl sig ctx = case sig of
L op -> do
queues <- TelemetryC (ask @(LogQueue, StatQueue))
case op of
WriteStat stat -> ctx <$ queueStat (snd queues) stat
WriteLog level message pairs -> ctx <$ queueLogMessage (fst queues) level message pairs
R other -> TelemetryC (alg (runTelemetryC . hdl) (R other) ctx)
-- | Run a 'Telemetry' effect by ignoring statting/logging.
ignoreTelemetry :: IgnoreTelemetryC m a -> m a
@ -166,6 +172,7 @@ newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
deriving (Applicative, Functor, Monad)
instance Algebra sig m => Algebra (Telemetry :+: sig) (IgnoreTelemetryC m) where
alg (R other) = IgnoreTelemetryC . alg . handleCoercible $ other
alg (L (WriteStat _ k)) = k
alg (L (WriteLog _ _ _ k)) = k
alg hdl sig ctx = case sig of
L WriteStat{} -> pure ctx
L WriteLog{} -> pure ctx
R other -> IgnoreTelemetryC (alg (runIgnoreTelemetryC . hdl) other ctx)

16
stack-snapshot.yaml
View File

@ -1,16 +1,14 @@
resolver: lts-15.13
packages:
- github: antitypical/fused-syntax
commit: "d11e14581217590a5c67f79cbaeee35ac8acee6a"
sha256: "e84d4812c4a6a4a6d76a684fa7adda7b8b42cded4e3b19c73212a848e1130f09"
commit: "4a383d57c8fd7592f54a33f43eb9666314a6e80e"
sha256: "aa345f8f04a12beaf8f07620467dee06370b72c763cf2d1c60556878b226fafc"
- github: tclem/proto-lens-jsonpb
commit: "5d40444be689bef1e12cbe38da0261283775ec64"
sha256: "39f783f07aeb64614aadb6ee618d000051c46cc9f511277d87feea6cba8fe955"
- github: fused-effects/fused-effects-readline
commit: "331545c7633955d8e930656f2093c16aa9f8d7a0"
sha256: "2b00acb099f179d961838c82155cde64a7da44b2f93ff4d1562e102380907959"
- fused-effects-1.1.0.0
- fused-effects-exceptions-1.1.0.0
- fused-effects-readline-0.1.0.0
- semilattices-0.0.0.4
- fused-effects-1.0.2.0
- fused-effects-exceptions-1.0.0.0
- fused-effects-resumable-0.1.0.0
- tree-sitter-0.9.0.1
- haskeline-0.8.0.0
- tree-sitter-0.9.0.2