Skip to content

Commit 7334462

Browse files
author
Patrick Thomson
authored
Merge branch 'master' into remove-shelly
2 parents d5f8248 + c33eed2 commit 7334462

File tree

11 files changed

+72
-103
lines changed

11 files changed

+72
-103
lines changed

‎semantic-core/semantic-core.cabal

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ library
2525
, Analysis.ImportGraph
2626
, Analysis.ScopeGraph
2727
, Analysis.Typecheck
28+
, Control.Carrier.Fail.WithLoc
2829
, Control.Effect.Readline
2930
, Control.Monad.Module
3031
, Data.Core
@@ -36,8 +37,6 @@ library
3637
, Data.Scope
3738
, Data.Stack
3839
, Data.Term
39-
-- other-modules:
40-
-- other-extensions:
4140
build-depends: algebraic-graphs ^>= 0.3
4241
, base >= 4.12 && < 5
4342
, containers ^>= 0.6
@@ -48,6 +47,7 @@ library
4847
, parsers ^>= 0.12.10
4948
, prettyprinter ^>= 1.2.1
5049
, prettyprinter-ansi-terminal ^>= 1.1.1
50+
, semantic-source ^>= 0
5151
, semigroupoids ^>= 5.3
5252
, text ^>= 1.2.3.1
5353
, transformers ^>= 0.5.6

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

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,8 @@ import qualified Algebra.Graph as G
1313
import qualified Algebra.Graph.Export.Dot as G
1414
import Analysis.Eval
1515
import Control.Applicative (Alternative (..))
16+
import Control.Carrier.Fail.WithLoc
1617
import Control.Effect
17-
import Control.Effect.Fail
1818
import Control.Effect.Fresh
1919
import Control.Effect.NonDet
2020
import Control.Effect.Reader hiding (Local)
@@ -32,6 +32,7 @@ import qualified Data.Set as Set
3232
import Data.Text (Text, pack)
3333
import Data.Traversable (for)
3434
import Prelude hiding (fail)
35+
import Source.Span
3536

3637
type Precise = Int
3738
type Env = Map.Map Name Precise
@@ -66,7 +67,7 @@ data Edge = Lexical | Import
6667

6768
-- | Concrete evaluation of a term to a value.
6869
--
69-
-- >>> map fileBody (snd (concrete eval [File (Loc "bool" emptySpan) (Core.bool True)]))
70+
-- >>> map fileBody (snd (concrete eval [File (Loc "bool" (Span (Pos 1 1) (Pos 1 5))) (Core.bool True)]))
7071
-- [Right (Bool True)]
7172
concrete
7273
:: (Foldable term, Show (term Name))
@@ -102,7 +103,7 @@ runFile
102103
-> m (File (Either (Loc, String) (Concrete (term Name))))
103104
runFile eval file = traverse run file
104105
where run = runReader (fileLoc file)
105-
. runFailWithLoc
106+
. runFail
106107
. runReader @Env mempty
107108
. fix (eval concreteAnalysis)
108109

@@ -197,15 +198,15 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,)
197198
addressStyle :: Heap term -> G.Style (EdgeType term, Precise) Text
198199
addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
199200
where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
200-
edgeAttributes _ (Slot name, _) = ["label" G.:= name]
201+
edgeAttributes _ (Slot name, _) = ["label" G.:= unName name]
201202
edgeAttributes _ (Edge Import, _) = ["color" G.:= "blue"]
202203
edgeAttributes _ (Edge Lexical, _) = ["color" G.:= "green"]
203204
edgeAttributes _ _ = []
204205
fromConcrete = \case
205206
Unit -> "()"
206207
Bool b -> pack $ show b
207208
String s -> pack $ show s
208-
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
209+
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> unName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
209210
Record _ -> "{}"
210211
showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
211212

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,8 @@ module Analysis.ImportGraph
88
import Analysis.Eval
99
import Analysis.FlowInsensitive
1010
import Control.Applicative (Alternative(..))
11+
import Control.Carrier.Fail.WithLoc
1112
import Control.Effect
12-
import Control.Effect.Fail
1313
import Control.Effect.Fresh
1414
import Control.Effect.Reader
1515
import Control.Effect.State
@@ -84,7 +84,7 @@ runFile
8484
-> m (File (Either (Loc, String) (Value term)))
8585
runFile eval file = traverse run file
8686
where run = runReader (fileLoc file)
87-
. runFailWithLoc
87+
. runFail
8888
. fmap fold
8989
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval importGraphAnalysis))
9090

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

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,8 @@ module Analysis.ScopeGraph
1010
import Analysis.Eval
1111
import Analysis.FlowInsensitive
1212
import Control.Applicative (Alternative (..))
13+
import Control.Carrier.Fail.WithLoc
1314
import Control.Effect.Carrier
14-
import Control.Effect.Fail
1515
import Control.Effect.Fresh
1616
import Control.Effect.Reader
1717
import Control.Effect.State
@@ -25,12 +25,11 @@ import qualified Data.Map as Map
2525
import Data.Name
2626
import Data.Proxy
2727
import qualified Data.Set as Set
28-
import Data.Text (Text)
2928
import Data.Traversable (for)
3029
import Prelude hiding (fail)
3130

3231
data Decl = Decl
33-
{ declSymbol :: Text
32+
{ declSymbol :: Name
3433
, declLoc :: Loc
3534
}
3635
deriving (Eq, Ord, Show)
@@ -81,7 +80,7 @@ runFile
8180
runFile eval file = traverse run file
8281
where run = runReader (fileLoc file)
8382
. runReader (Map.empty @Name @Loc)
84-
. runFailWithLoc
83+
. runFail
8584
. fmap fold
8685
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval scopeGraphAnalysis))
8786

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,8 @@ module Analysis.Typecheck
1010
import Analysis.Eval
1111
import Analysis.FlowInsensitive
1212
import Control.Applicative (Alternative (..))
13+
import Control.Carrier.Fail.WithLoc
1314
import Control.Effect.Carrier
14-
import Control.Effect.Fail
1515
import Control.Effect.Fresh as Fresh
1616
import Control.Effect.Reader hiding (Local)
1717
import Control.Effect.State
@@ -133,7 +133,7 @@ runFile eval file = traverse run file
133133
pure (substAll subst <$> t))
134134
. runState (mempty :: Substitution)
135135
. runReader (fileLoc file)
136-
. runFailWithLoc
136+
. runFail
137137
. (\ m -> do
138138
(cs, t) <- m
139139
t <$ solve cs)

‎semantic-core/src/Control/Carrier/Fail/WithLoc.hs

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
2+
module Control.Carrier.Fail.WithLoc
3+
( -- * Fail effect
4+
module Control.Effect.Fail
5+
-- * Fail carrier
6+
, runFail
7+
, FailC(..)
8+
) where
9+
10+
import Control.Applicative
11+
import Control.Effect.Carrier
12+
import Control.Effect.Error
13+
import Control.Effect.Fail (Fail(..), MonadFail(..))
14+
import Control.Effect.Reader
15+
import Data.Loc
16+
import Prelude hiding (fail)
17+
18+
runFail :: FailC m a -> m (Either (Loc, String) a)
19+
runFail = runError . runFailC
20+
21+
newtype FailC m a = FailC { runFailC :: ErrorC (Loc, String) m a }
22+
deriving (Alternative, Applicative, Functor, Monad)
23+
24+
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailC m) where
25+
fail s = do
26+
loc <- ask
27+
FailC (throwError (loc :: Loc, s))
28+
29+
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailC m) where
30+
eff (L (Fail s)) = fail s
31+
eff (R other) = FailC (eff (R (handleCoercible other)))

‎semantic-core/src/Data/Loc.hs

Lines changed: 3 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,14 @@
1-
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
1+
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
22
module Data.Loc
33
( Loc(..)
44
, interactive
5-
, Span(..)
6-
, emptySpan
7-
, Pos(..)
85
, here
96
, stackLoc
10-
, FailWithLocC(..)
11-
, runFailWithLoc
127
) where
138

14-
import Control.Applicative
15-
import Control.Effect.Carrier
16-
import Control.Effect.Error
17-
import Control.Effect.Fail
18-
import Control.Effect.Reader
199
import Data.Text (Text, pack)
20-
import Data.Text.Prettyprint.Doc (Pretty (..))
2110
import GHC.Stack
22-
import Prelude hiding (fail)
11+
import Source.Span
2312

2413
data Loc = Loc
2514
{ locPath :: !Text
@@ -28,28 +17,7 @@ data Loc = Loc
2817
deriving (Eq, Ord, Show)
2918

3019
interactive :: Loc
31-
interactive = Loc "<interactive>" emptySpan
32-
33-
data Span = Span
34-
{ spanStart :: {-# UNPACK #-} !Pos
35-
, spanEnd :: {-# UNPACK #-} !Pos
36-
}
37-
deriving (Eq, Ord, Show)
38-
39-
instance Pretty Span where
40-
pretty (Span s e) = pretty s <> "-" <> pretty e
41-
42-
emptySpan :: Span
43-
emptySpan = Span (Pos 1 1) (Pos 1 1)
44-
45-
data Pos = Pos
46-
{ posLine :: {-# UNPACK #-} !Int
47-
, posCol :: {-# UNPACK #-} !Int
48-
}
49-
deriving (Eq, Ord, Show)
50-
51-
instance Pretty Pos where
52-
pretty (Pos l c) = pretty l <> ":" <> pretty c
20+
interactive = Loc "<interactive>" (Span (Pos 1 1) (Pos 1 1))
5321

5422

5523
here :: HasCallStack => Maybe Loc
@@ -62,19 +30,3 @@ stackLoc cs = case getCallStack cs of
6230

6331
fromGHCSrcLoc :: SrcLoc -> Loc
6432
fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
65-
66-
67-
runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)
68-
runFailWithLoc = runError . runFailWithLocC
69-
70-
newtype FailWithLocC m a = FailWithLocC { runFailWithLocC :: ErrorC (Loc, String) m a }
71-
deriving (Alternative, Applicative, Functor, Monad)
72-
73-
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailWithLocC m) where
74-
fail s = do
75-
loc <- ask
76-
FailWithLocC (throwError (loc :: Loc, s))
77-
78-
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailWithLocC m) where
79-
eff (L (Fail s)) = fail s
80-
eff (R other) = FailWithLocC (eff (R (handleCoercible other)))

‎semantic-core/src/Data/Name.hs

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
1-
{-# LANGUAGE DeriveTraversable, LambdaCase, OverloadedLists #-}
1+
{-# LANGUAGE DeriveGeneric, DeriveTraversable, GeneralizedNewtypeDeriving, LambdaCase, OverloadedLists #-}
22
module Data.Name
3-
( Name
3+
( Name (..)
44
, Named(..)
55
, named
66
, named'
@@ -15,10 +15,14 @@ module Data.Name
1515
import qualified Data.Char as Char
1616
import Data.HashSet (HashSet)
1717
import qualified Data.HashSet as HashSet
18+
import Data.String (IsString)
1819
import Data.Text as Text (Text, any, unpack)
20+
import Data.Text.Prettyprint.Doc (Pretty)
21+
import GHC.Generics (Generic)
1922

2023
-- | User-specified and -relevant names.
21-
type Name = Text
24+
newtype Name = Name { unName :: Text }
25+
deriving (Eq, Generic, IsString, Ord, Pretty, Show)
2226

2327
-- | Annotates an @a@ with a 'Name'-provided name, which is ignored for '==' and 'compare'.
2428
data Named a = Named (Ignored Name) a
@@ -50,7 +54,7 @@ reservedNames = [ "#true", "#false", "if", "then", "else"
5054
-- | Returns true if any character would require quotation or if the
5155
-- name conflicts with a Core primitive.
5256
needsQuotation :: Name -> Bool
53-
needsQuotation u = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
57+
needsQuotation (Name u) = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
5458

5559
-- | A ‘simple’ character is, loosely defined, a character that is compatible
5660
-- with identifiers in most ASCII-oriented programming languages. This is defined

‎semantic-core/test/Generators.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Data.Term
2626
-- interesting property as they parse regardless.
2727
name :: MonadGen m => m (Named Name)
2828
name = Gen.prune (named' <$> names) where
29-
names = Gen.text (Range.linear 1 10) Gen.lower
29+
names = Name <$> Gen.text (Range.linear 1 10) Gen.lower
3030

3131
boolean :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
3232
boolean = Core.bool <$> Gen.bool

‎semantic-python/src/Language/Python/Core.hs

Lines changed: 9 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
11
{-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, DeriveAnyClass, DeriveGeneric, DerivingStrategies,
22
DerivingVia, DisambiguateRecordFields, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
33
KindSignatures, LambdaCase, NamedFieldPuns, OverloadedLists, OverloadedStrings, PatternSynonyms,
4-
ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
4+
ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances,
5+
ViewPatterns #-}
56

67
module Language.Python.Core
78
( compile
@@ -27,7 +28,6 @@ import Data.Text (Text)
2728
import GHC.Generics
2829
import GHC.Records
2930
import Source.Span (Span)
30-
import qualified Source.Span as Source
3131
import qualified TreeSitter.Python.AST as Py
3232

3333
-- | Access to the current filename as Text to stick into location annotations.
@@ -52,7 +52,7 @@ def n = coerce (Stack.:> n)
5252
pattern SingleIdentifier :: Name -> Py.ExpressionList a
5353
pattern SingleIdentifier name <- Py.ExpressionList
5454
{ Py.extraChildren =
55-
[ Py.PrimaryExpressionExpression (Py.IdentifierPrimaryExpression (Py.Identifier { bytes = name }))
55+
[ Py.PrimaryExpressionExpression (Py.IdentifierPrimaryExpression (Py.Identifier { bytes = Name -> name }))
5656
]
5757
}
5858

@@ -97,9 +97,8 @@ compile :: ( Compile py
9797
-> m (t Name)
9898
compile t = compileCC t (pure none)
9999

100-
locFromTSSpan :: SourcePath -> Source.Span -> Loc
101-
locFromTSSpan fp (Source.Span (Source.Pos a b) (Source.Pos c d))
102-
= Data.Loc.Loc (rawPath fp) (Data.Loc.Span (Data.Loc.Pos a b) (Data.Loc.Pos c d))
100+
locFromTSSpan :: SourcePath -> Span -> Loc
101+
locFromTSSpan fp = Data.Loc.Loc (rawPath fp)
103102

104103
locate :: ( HasField "ann" syntax Span
105104
, CoreSyntax syn t
@@ -254,18 +253,18 @@ instance Compile Py.FunctionDefinition where
254253
-- Give it a name (below), then augment the current continuation
255254
-- with the new name (with 'def'), so that calling contexts know
256255
-- that we have built an exportable definition.
257-
assigning located <$> local (def name) cc
258-
where param (Py.IdentifierParameter (Py.Identifier _pann pname)) = pure (named' pname)
256+
assigning located <$> local (def (Name name)) cc
257+
where param (Py.IdentifierParameter (Py.Identifier _pann pname)) = pure . named' . Name $ pname
259258
param x = unimplemented x
260259
unimplemented x = fail $ "unimplemented: " <> show x
261-
assigning item f = (Name.named' name :<- item) >>>= f
260+
assigning item f = (Name.named' (Name name) :<- item) >>>= f
262261

263262
instance Compile Py.FutureImportStatement
264263
instance Compile Py.GeneratorExpression
265264
instance Compile Py.GlobalStatement
266265

267266
instance Compile Py.Identifier where
268-
compileCC Py.Identifier { bytes } _ = pure (pure bytes)
267+
compileCC Py.Identifier { bytes } _ = pure . pure . Name $ bytes
269268

270269
instance Compile Py.IfStatement where
271270
compileCC it@Py.IfStatement{ condition, consequence, alternative} cc =

0 commit comments

Comments
 (0)