Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 23ba75b

Browse files
robrixrobrix
committed
Copy in the semantic-core sources.
1 parent 31fc1c0 commit 23ba75b

File tree

17 files changed

+1466
-0
lines changed

17 files changed

+1466
-0
lines changed

‎semantic-core/LICENSE‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
MIT License
2+
3+
Copyright (c) 2019 GitHub
4+
5+
Permission is hereby granted, free of charge, to any person obtaining a copy
6+
of this software and associated documentation files (the "Software"), to deal
7+
in the Software without restriction, including without limitation the rights
8+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+
copies of the Software, and to permit persons to whom the Software is
10+
furnished to do so, subject to the following conditions:
11+
12+
The above copyright notice and this permission notice shall be included in all
13+
copies or substantial portions of the Software.
14+
15+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+
SOFTWARE.

‎semantic-core/README.md‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
# semantic-core
2+
3+
Semantic core intermediate language (experimental)
4+
5+
6+
## Development
7+
8+
This project consists of a Haskell package named `semantic-core`. The library’s sources are in [`src`][].
9+
10+
Development of `semantic-core` is typically done using `cabal new-build`:
11+
12+
```shell
13+
cabal new-build # build the library
14+
cabal new-repl # load the package into ghci
15+
cabal new-test # build and run the doctests
16+
```
17+
18+
[`src`]: https://github.com/github/semantic/tree/master/semantic-core/src

‎semantic-core/Setup.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎semantic-core/semantic-core.cabal‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
cabal-version: 2.2
2+
3+
name: semantic-core
4+
version: 0.0.0.0
5+
synopsis: Semantic core intermediate language
6+
-- description:
7+
homepage: https://github.com/github/semantic-core
8+
-- bug-reports:
9+
license: MIT
10+
license-file: LICENSE
11+
author: Rob Rix
12+
maintainer: [email protected]
13+
-- copyright:
14+
category: Language
15+
build-type: Simple
16+
extra-source-files: README.md
17+
18+
tested-with: GHC == 8.6.4
19+
20+
library
21+
exposed-modules: Analysis.FlowInsensitive
22+
, Analysis.ImportGraph
23+
, Analysis.ScopeGraph
24+
, Control.Effect.Readline
25+
, Data.File
26+
, Data.Loc
27+
, Semantic.Core
28+
, Semantic.Data.Stack
29+
, Semantic.Eval
30+
, Semantic.Eval.Concrete
31+
, Semantic.Eval.Typecheck
32+
, Semantic.Name
33+
-- other-modules:
34+
-- other-extensions:
35+
build-depends: algebraic-graphs ^>= 0.3
36+
, base >= 4.11 && < 5
37+
, containers ^>= 0.6
38+
, directory ^>= 1.3
39+
, filepath ^>= 1.4
40+
, fused-effects ^>= 0.4
41+
, haskeline ^>= 0.7.5
42+
, prettyprinter ^>= 1.2.1
43+
, semigroupoids ^>= 5.3
44+
, transformers ^>= 0.5.6
45+
hs-source-dirs: src
46+
default-language: Haskell2010
47+
ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations
48+
if (impl(ghc >= 8.6))
49+
ghc-options: -Wno-star-is-type
50+
51+
test-suite doctest
52+
type: exitcode-stdio-1.0
53+
main-is: Doctest.hs
54+
build-depends: base >=4.9 && <4.13
55+
, doctest >=0.7 && <1.0
56+
, QuickCheck
57+
, semantic-core
58+
hs-source-dirs: test
59+
default-language: Haskell2010

‎semantic-core/src/Analysis/FlowInsensitive.hs‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
2+
module Analysis.FlowInsensitive
3+
( Heap
4+
, FrameId(..)
5+
, convergeTerm
6+
, cacheTerm
7+
, runHeap
8+
, foldMapA
9+
) where
10+
11+
import Control.Effect
12+
import Control.Effect.Fresh
13+
import Control.Effect.NonDet
14+
import Control.Effect.Reader
15+
import Control.Effect.State
16+
import qualified Data.Map as Map
17+
import Data.Maybe (fromMaybe)
18+
import Data.Monoid (Alt(..))
19+
import qualified Data.Set as Set
20+
import qualified Semantic.Core as Core
21+
import Semantic.Name
22+
23+
type Cache a = Map.Map Core.Core (Set.Set a)
24+
type Heap a = Map.Map Name (Set.Set a)
25+
26+
newtype FrameId = FrameId { unFrameId :: Name }
27+
deriving (Eq, Ord, Show)
28+
29+
30+
convergeTerm :: forall m sig a
31+
. ( Carrier sig m
32+
, Effect sig
33+
, Member Fresh sig
34+
, Member (State (Heap a)) sig
35+
, Ord a
36+
)
37+
=> (Core.Core -> NonDetC (ReaderC (Cache a) (StateC (Cache a) m)) a)
38+
-> Core.Core
39+
-> m (Set.Set a)
40+
convergeTerm eval body = do
41+
heap <- get
42+
(cache, _) <- converge (Map.empty :: Cache a, heap :: Heap a) $ \ (prevCache, _) -> runState Map.empty . runReader prevCache $ do
43+
_ <- resetFresh . runNonDetM Set.singleton $ eval body
44+
get
45+
pure (fromMaybe mempty (Map.lookup body cache))
46+
47+
cacheTerm :: forall m sig a
48+
. ( Alternative m
49+
, Carrier sig m
50+
, Member (Reader (Cache a)) sig
51+
, Member (State (Cache a)) sig
52+
, Ord a
53+
)
54+
=> (Core.Core -> m a)
55+
-> (Core.Core -> m a)
56+
cacheTerm eval term = do
57+
cached <- gets (Map.lookup term)
58+
case cached :: Maybe (Set.Set a) of
59+
Just results -> foldMapA pure results
60+
Nothing -> do
61+
results <- asks (fromMaybe mempty . Map.lookup term)
62+
modify (Map.insert term (results :: Set.Set a))
63+
result <- eval term
64+
result <$ modify (Map.insertWith (<>) term (Set.singleton (result :: a)))
65+
66+
runHeap :: (Carrier sig m, Member Naming sig) => ReaderC FrameId (StateC (Heap a) m) b -> m (Heap a, b)
67+
runHeap m = do
68+
addr <- Gen <$> gensym "root"
69+
runState (Map.singleton addr Set.empty) (runReader (FrameId addr) m)
70+
71+
-- | Fold a collection by mapping each element onto an 'Alternative' action.
72+
foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a
73+
foldMapA f = getAlt . foldMap (Alt . f)
74+
75+
runNonDetM :: (Monoid b, Applicative m) => (a -> b) -> NonDetC m a -> m b
76+
runNonDetM f (NonDetC m) = m (fmap . (<>) . f) (pure mempty)
77+
78+
-- | Iterate a monadic action starting from some initial seed until the results converge.
79+
--
80+
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
81+
converge :: (Eq a, Monad m)
82+
=> a -- ^ An initial seed value to iterate from.
83+
-> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
84+
-> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge).
85+
converge seed f = loop seed
86+
where loop x = do
87+
x' <- f x
88+
if x' == x then
89+
pure x
90+
else
91+
loop x'

‎semantic-core/src/Analysis/ImportGraph.hs‎

Lines changed: 107 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,107 @@
1+
{-# LANGUAGE FlexibleContexts, RecordWildCards #-}
2+
module Analysis.ImportGraph
3+
( ImportGraph
4+
, importGraph
5+
, importGraphAnalysis
6+
) where
7+
8+
import Analysis.FlowInsensitive
9+
import Control.Applicative (Alternative(..))
10+
import Control.Effect
11+
import Control.Effect.Fail
12+
import Control.Effect.Fresh
13+
import Control.Effect.Reader
14+
import Control.Effect.State
15+
import Data.File
16+
import Data.Foldable (fold)
17+
import Data.Function (fix)
18+
import Data.List.NonEmpty (nonEmpty)
19+
import Data.Loc
20+
import qualified Data.Map as Map
21+
import qualified Data.Set as Set
22+
import Prelude hiding (fail)
23+
import qualified Semantic.Core as Core
24+
import Semantic.Eval
25+
import Semantic.Name
26+
27+
type ImportGraph = Map.Map FilePath (Set.Set FilePath)
28+
29+
data Value = Value
30+
{ valueSemi :: Semi
31+
, valueGraph :: ImportGraph
32+
}
33+
deriving (Eq, Ord, Show)
34+
35+
instance Semigroup Value where
36+
Value _ g1 <> Value _ g2 = Value Abstract (Map.unionWith (<>) g1 g2)
37+
38+
instance Monoid Value where
39+
mempty = Value Abstract mempty
40+
41+
data Semi
42+
= Closure Loc Name Core.Core Name
43+
-- FIXME: Bound String values.
44+
| String String
45+
| Abstract
46+
deriving (Eq, Ord, Show)
47+
48+
49+
importGraph :: [File Core.Core] -> (Heap Value, [File (Either (Loc, String) Value)])
50+
importGraph
51+
= run
52+
. runFresh
53+
. runNaming (Root "import-graph")
54+
. runHeap
55+
. traverse runFile
56+
57+
runFile :: ( Carrier sig m
58+
, Effect sig
59+
, Member Fresh sig
60+
, Member (Reader FrameId) sig
61+
, Member (State (Heap Value)) sig
62+
)
63+
=> File Core.Core
64+
-> m (File (Either (Loc, String) Value))
65+
runFile file = traverse run file
66+
where run = runReader (fileLoc file)
67+
. runFailWithLoc
68+
. fmap fold
69+
. convergeTerm (fix (cacheTerm . eval importGraphAnalysis))
70+
71+
-- FIXME: decompose into a product domain and two atomic domains
72+
importGraphAnalysis :: ( Alternative m
73+
, Carrier sig m
74+
, Member (Reader FrameId) sig
75+
, Member (Reader Loc) sig
76+
, Member (State (Heap Value)) sig
77+
, MonadFail m
78+
)
79+
=> Analysis Name Value m
80+
importGraphAnalysis = Analysis{..}
81+
where alloc = pure
82+
bind _ _ = pure ()
83+
lookupEnv = pure . Just
84+
deref addr = gets (Map.lookup addr) >>= maybe (pure Nothing) (foldMapA (pure . Just)) . nonEmpty . maybe [] Set.toList
85+
assign addr ty = modify (Map.insertWith (<>) addr (Set.singleton ty))
86+
abstract _ name body = do
87+
loc <- ask
88+
FrameId parentAddr <- ask
89+
pure (Value (Closure loc name body parentAddr) mempty)
90+
apply eval (Value (Closure loc name body _) _) a = local (const loc) $ do
91+
addr <- alloc name
92+
assign addr a
93+
bind name addr
94+
eval body
95+
apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
96+
unit = pure mempty
97+
bool _ = pure mempty
98+
asBool _ = pure True <|> pure False
99+
string s = pure (Value (String s) mempty)
100+
asString (Value (String s) _) = pure s
101+
asString _ = pure ""
102+
frame = pure mempty
103+
edge Core.Import (Path to) = do
104+
Loc{locPath=from} <- ask
105+
() <$ pure (Value Abstract (Map.singleton from (Set.singleton to)))
106+
edge _ _ = pure ()
107+
_ ... m = m

‎semantic-core/src/Analysis/ScopeGraph.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
module Analysis.ScopeGraph
2+
( ScopeGraph
3+
, Entry(..)
4+
) where
5+
6+
import Data.Loc
7+
import qualified Data.Map as Map
8+
import qualified Data.Set as Set
9+
10+
data Entry = Entry
11+
{ entrySymbol :: String -- FIXME: Text
12+
, entryLoc :: Loc
13+
}
14+
15+
type ScopeGraph = Map.Map Entry (Set.Set Entry)

0 commit comments

Comments
 (0)