github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 22:31:36 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into add-java-to-supported-langs

Browse Source
This commit is contained in:
Patrick Thomson 2019-10-10 16:44:48 -04:00 committed by GitHub
commit a6a790cc17
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 150 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -84,6 +84,7 @@ test-suite spec
other-modules: Generators
build-depends: base
, semantic-core
, semantic-source ^>= 0
, fused-effects
, hedgehog ^>= 1
, tasty >= 1.2 && <2

31
semantic-core/src/Analysis/Concrete.hs
View File

@ -41,7 +41,7 @@ newtype FrameId = FrameId { unFrameId :: Precise }
deriving (Eq, Ord, Show)
data Concrete term
= Closure Loc Name term Env
= Closure Path Span Name term Env
| Unit
| Bool Bool
| String Text
@ -67,18 +67,18 @@ data Edge = Lexical | Import
-- | Concrete evaluation of a term to a value.
--
-- >>> map fileBody (snd (concrete eval [File (Loc "bool" (Span (Pos 1 1) (Pos 1 5))) (Core.bool True)]))
-- >>> map fileBody (snd (concrete eval [File (Path "bool") (Span (Pos 1 1) (Pos 1 5)) (Core.bool True)]))
-- [Right (Bool True)]
concrete
:: (Foldable term, Show (term Name))
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis (term Name) Precise (Concrete (term Name)) m
-> (term Name -> m (Concrete (term Name)))
-> (term Name -> m (Concrete (term Name)))
)
-> [File (term Name)]
-> (Heap (term Name), [File (Either (Loc, String) (Concrete (term Name)))])
-> (Heap (term Name), [File (Either (Path, Span, String) (Concrete (term Name)))])
concrete eval
= run
. runFresh
@ -94,15 +94,16 @@ runFile
, Show (term Name)
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis (term Name) Precise (Concrete (term Name)) m
-> (term Name -> m (Concrete (term Name)))
-> (term Name -> m (Concrete (term Name)))
)
-> File (term Name)
-> m (File (Either (Loc, String) (Concrete (term Name))))
-> m (File (Either (Path, Span, String) (Concrete (term Name))))
runFile eval file = traverse run file
where run = runReader (fileLoc file)
where run = runReader (filePath file)
. runReader (fileSpan file)
. runFail
. runReader @Env mempty
. fix (eval concreteAnalysis)
@ -111,7 +112,8 @@ concreteAnalysis :: ( Carrier sig m
, Foldable term
, Member Fresh sig
, Member (Reader Env) sig
, Member (Reader Loc) sig
, Member (Reader Path) sig
, Member (Reader Span) sig
, Member (State (Heap (term Name))) sig
, MonadFail m
, Show (term Name)
@ -124,11 +126,12 @@ concreteAnalysis = Analysis{..}
deref = gets . IntMap.lookup
assign addr value = modify (IntMap.insert addr value)
abstract _ name body = do
loc <- ask
path <- ask
span <- ask
env <- asks (flip Map.restrictKeys (Set.delete name (foldMap Set.singleton body)))
pure (Closure loc name body env)
apply eval (Closure loc name body env) a = do
local (const loc) $ do
pure (Closure path span name body env)
apply eval (Closure path span name body env) a = do
local (const path) . local (const span) $ do
addr <- alloc name
assign addr a
local (const (Map.insert name addr env)) (eval body)
@ -185,7 +188,7 @@ heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
Unit -> G.empty
Bool _ -> G.empty
String _ -> G.empty
Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
Closure _ _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
Record frame -> Map.foldrWithKey (\ k -> G.overlay . edge (Right k)) G.empty frame
heapValueGraph :: Heap term -> G.Graph (Concrete term)
@ -206,7 +209,7 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
Unit -> "()"
Bool b -> pack $ show b
String s -> pack $ show s
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> unName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
Closure p (Span s e) n _ _ -> "\\\\ " <> unName n <> " [" <> getPath p <> ":" <> showPos s <> "-" <> showPos e <> "]"
Record _ -> "{}"
showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)

21
semantic-core/src/Analysis/Eval.hs
View File

@ -27,15 +27,16 @@ import Data.Term
import Data.Text (Text)
import GHC.Stack
import Prelude hiding (fail)
import Source.Span
eval :: ( Carrier sig m
, Member (Reader Loc) sig
, Member (Reader Span) sig
, MonadFail m
, Semigroup value
)
=> Analysis (Term (Ann :+: Core) Name) address value m
-> (Term (Ann :+: Core) Name -> m value)
-> (Term (Ann :+: Core) Name -> m value)
=> Analysis (Term (Ann Span :+: Core) Name) address value m
-> (Term (Ann Span :+: Core) Name -> m value)
-> (Term (Ann Span :+: Core) Name -> m value)
eval Analysis{..} eval = \case
Var n -> lookupEnv' n >>= deref' n
Term (R c) -> case c of
@ -72,7 +73,7 @@ eval Analysis{..} eval = \case
b' <- eval b
addr <- ref a
b' <$ assign addr b'
Term (L (Ann loc c)) -> local (const loc) (eval c)
Term (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)
@ -90,7 +91,7 @@ eval Analysis{..} eval = \case
a' <- ref a
a' ... b >>= maybe (freeVariable (show b)) pure
c -> invalidRef (show c)
Term (L (Ann loc c)) -> local (const loc) (ref c)
Term (L (Ann span c)) -> local (const span) (ref c)
prog1 :: (Carrier sig t, Member Core sig) => File (t Name)
@ -116,7 +117,7 @@ prog4 = fromBody
(Core.bool True)
(Core.bool False))
prog5 :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
prog5 :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name)
prog5 = fromBody $ ann (do'
[ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record
[ ("x", ann (pure "_x"))
@ -129,15 +130,15 @@ prog5 = fromBody $ ann (do'
prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)]
prog6 =
[ File (Loc "dep" (locSpan (fromJust here))) $ Core.record
[ File (Path "dep") (snd (fromJust here)) $ Core.record
[ ("dep", Core.record [ ("var", Core.bool True) ]) ]
, File (Loc "main" (locSpan (fromJust here))) $ do' (map (Nothing :<-)
, File (Path "main") (snd (fromJust here)) $ do' (map (Nothing :<-)
[ load (Core.string "dep")
, Core.record [ ("thing", pure "dep" Core.... "var") ]
])
]
ruby :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
ruby :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name)
ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements))
where statements =
[ Just "Class" :<- record

24
semantic-core/src/Analysis/ImportGraph.hs
View File

@ -25,6 +25,7 @@ import Data.Proxy
import qualified Data.Set as Set
import Data.Text (Text)
import Prelude hiding (fail)
import Source.Span
type ImportGraph = Map.Map Text (Set.Set Text)
@ -41,7 +42,7 @@ instance Monoid (Value term) where
mempty = Value Abstract mempty
data Semi term
= Closure Loc Name term
= Closure Path Span Name term
-- FIXME: Bound String values.
| String Text
| Abstract
@ -51,14 +52,14 @@ data Semi term
importGraph
:: (Ord term, Show term)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name (Value term) m
-> (term -> m (Value term))
-> (term -> m (Value term))
)
-> [File term]
-> ( Heap Name (Value term)
, [File (Either (Loc, String) (Value term))]
, [File (Either (Path, Span, String) (Value term))]
)
importGraph eval
= run
@ -75,15 +76,16 @@ runFile
, Show term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name (Value term) m
-> (term -> m (Value term))
-> (term -> m (Value term))
)
-> File term
-> m (File (Either (Loc, String) (Value term)))
-> m (File (Either (Path, Span, String) (Value term)))
runFile eval file = traverse run file
where run = runReader (fileLoc file)
where run = runReader (filePath file)
. runReader (fileSpan file)
. runFail
. fmap fold
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval importGraphAnalysis))
@ -91,7 +93,8 @@ runFile eval file = traverse run file
-- FIXME: decompose into a product domain and two atomic domains
importGraphAnalysis :: ( Alternative m
, Carrier sig m
, Member (Reader Loc) sig
, Member (Reader Path) sig
, Member (Reader Span) sig
, Member (State (Heap Name (Value term))) sig
, MonadFail m
, Ord term
@ -105,9 +108,10 @@ importGraphAnalysis = Analysis{..}
deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
assign addr v = modify (Map.insertWith (<>) addr (Set.singleton v))
abstract _ name body = do
loc <- ask
pure (Value (Closure loc name body) mempty)
apply eval (Value (Closure loc name body) _) a = local (const loc) $ do
path <- ask
span <- ask
pure (Value (Closure path span name body) mempty)
apply eval (Value (Closure path span name body) _) a = local (const path) . local (const span) $ do
addr <- alloc name
assign addr a
bind name addr (eval body)

52
semantic-core/src/Analysis/ScopeGraph.hs
View File

@ -27,14 +27,19 @@ import Data.Proxy
import qualified Data.Set as Set
import Data.Traversable (for)
import Prelude hiding (fail)
import Source.Span
data Decl = Decl
{ declSymbol :: Name
, declLoc :: Loc
, declPath :: Path
, declSpan :: Span
}
deriving (Eq, Ord, Show)
newtype Ref = Ref Loc
data Ref = Ref
{ refPath :: Path
, refSpan :: Span
}
deriving (Eq, Ord, Show)
newtype ScopeGraph = ScopeGraph { unScopeGraph :: Map.Map Decl (Set.Set Ref) }
@ -49,13 +54,13 @@ instance Monoid ScopeGraph where
scopeGraph
:: Ord term
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name ScopeGraph m
-> (term -> m ScopeGraph)
-> (term -> m ScopeGraph)
)
-> [File term]
-> (Heap Name ScopeGraph, [File (Either (Loc, String) ScopeGraph)])
-> (Heap Name ScopeGraph, [File (Either (Path, Span, String) ScopeGraph)])
scopeGraph eval
= run
. runFresh
@ -70,16 +75,17 @@ runFile
, Ord term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name ScopeGraph m
-> (term -> m ScopeGraph)
-> (term -> m ScopeGraph)
)
-> File term
-> m (File (Either (Loc, String) ScopeGraph))
-> m (File (Either (Path, Span, String) ScopeGraph))
runFile eval file = traverse run file
where run = runReader (fileLoc file)
. runReader (Map.empty @Name @Loc)
where run = runReader (filePath file)
. runReader (fileSpan file)
. runReader (Map.empty @Name @Ref)
. runFail
. fmap fold
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval scopeGraphAnalysis))
@ -87,27 +93,28 @@ runFile eval file = traverse run file
scopeGraphAnalysis
:: ( Alternative m
, Carrier sig m
, Member (Reader Loc) sig
, Member (Reader (Map.Map Name Loc)) sig
, Member (Reader Path) sig
, Member (Reader Span) sig
, Member (Reader (Map.Map Name Ref)) sig
, Member (State (Heap Name ScopeGraph)) sig
)
=> Analysis term Name ScopeGraph m
scopeGraphAnalysis = Analysis{..}
where alloc = pure
bind name _ m = do
loc <- ask @Loc
local (Map.insert name loc) m
ref <- askRef
local (Map.insert name ref) m
lookupEnv = pure . Just
deref addr = do
ref <- asks Ref
bindLoc <- asks (Map.lookup addr)
ref <- askRef
bindRef <- asks (Map.lookup addr)
cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
let extending = mappend (extendBinding addr ref bindLoc)
let extending = mappend (extendBinding addr ref bindRef)
maybe (pure Nothing) (foldMapA (pure . Just . extending)) cell
assign addr v = do
ref <- asks Ref
bindLoc <- asks (Map.lookup addr)
modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindLoc <> v)))
ref <- askRef
bindRef <- asks (Map.lookup addr)
modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindRef <> v)))
abstract eval name body = do
addr <- alloc name
assign name (mempty @ScopeGraph)
@ -121,10 +128,13 @@ scopeGraphAnalysis = Analysis{..}
record fields = do
fields' <- for fields $ \ (k, v) -> do
addr <- alloc k
loc <- ask @Loc
let v' = ScopeGraph (Map.singleton (Decl k loc) mempty) <> v
path <- ask
span <- ask
let v' = ScopeGraph (Map.singleton (Decl k path span) mempty) <> v
(k, v') <$ assign addr v'
pure (foldMap snd fields')
_ ... m = pure (Just m)
extendBinding addr ref bindLoc = ScopeGraph (maybe Map.empty (\ bindLoc -> Map.singleton (Decl addr bindLoc) (Set.singleton ref)) bindLoc)
askRef = Ref <$> ask <*> ask
extendBinding addr ref bindRef = ScopeGraph (maybe Map.empty (\ (Ref path span) -> Map.singleton (Decl addr path span) (Set.singleton ref)) bindRef)

12
semantic-core/src/Analysis/Typecheck.hs
View File

@ -37,6 +37,7 @@ import Data.Traversable (for)
import Data.Void
import GHC.Generics (Generic1)
import Prelude hiding (fail)
import Source.Span
data Monotype f a
= Bool
@ -94,14 +95,14 @@ generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R
typecheckingFlowInsensitive
:: Ord term
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name Type m
-> (term -> m Type)
-> (term -> m Type)
)
-> [File term]
-> ( Heap Name Type
, [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))]
, [File (Either (Path, Span, String) (Term (Polytype :+: Monotype) Void))]
)
typecheckingFlowInsensitive eval
= run
@ -118,13 +119,13 @@ runFile
, Ord term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
. (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
=> Analysis term Name Type m
-> (term -> m Type)
-> (term -> m Type)
)
-> File term
-> m (File (Either (Loc, String) Type))
-> m (File (Either (Path, Span, String) Type))
runFile eval file = traverse run file
where run
= (\ m -> do
@ -132,7 +133,8 @@ runFile eval file = traverse run file
modify @(Heap Name Type) (fmap (Set.map (substAll subst)))
pure (substAll subst <$> t))
. runState (mempty :: Substitution)
. runReader (fileLoc file)
. runReader (filePath file)
. runReader (fileSpan file)
. runFail
. (\ m -> do
(cs, t) <- m

14
semantic-core/src/Control/Carrier/Fail/WithLoc.hs
View File

@ -14,18 +14,20 @@ import Control.Effect.Fail (Fail(..), MonadFail(..))
import Control.Effect.Reader
import Data.Loc
import Prelude hiding (fail)
import Source.Span
runFail :: FailC m a -> m (Either (Loc, String) a)
runFail :: FailC m a -> m (Either (Path, Span, String) a)
runFail = runError . runFailC
newtype FailC m a = FailC { runFailC :: ErrorC (Loc, String) m a }
newtype FailC m a = FailC { runFailC :: ErrorC (Path, Span, String) m a }
deriving (Alternative, Applicative, Functor, Monad)
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailC m) where
instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => MonadFail (FailC m) where
fail s = do
loc <- ask
FailC (throwError (loc :: Loc, s))
path <- ask
span <- ask
FailC (throwError (path :: Path, span :: Span, s))
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailC m) where
instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => Carrier (Fail :+: sig) (FailC m) where
eff (L (Fail s)) = fail s
eff (R other) = FailC (eff (R (handleCoercible other)))

21
semantic-core/src/Data/Core.hs
View File

@ -50,6 +50,7 @@ import Data.Term
import Data.Text (Text)
import GHC.Generics (Generic1)
import GHC.Stack
import Source.Span
data Core f a
-- | Recursive local binding of a name in a scope; strict evaluation of the name in the body will diverge.
@ -215,27 +216,27 @@ a .= b = send (a := b)
infix 3 .=
data Ann f a
= Ann Loc (f a)
data Ann ann f a
= Ann ann (f a)
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance HFunctor Ann
instance HFunctor (Ann ann)
instance RightModule Ann where
instance RightModule (Ann ann) where
Ann l b >>=* f = Ann l (b >>= f)
ann :: (Carrier sig m, Member Ann sig) => HasCallStack => m a -> m a
ann :: (Carrier sig m, Member (Ann Span) sig) => HasCallStack => m a -> m a
ann = annWith callStack
annAt :: (Carrier sig m, Member Ann sig) => Loc -> m a -> m a
annAt loc = send . Ann loc
annAt :: (Carrier sig m, Member (Ann ann) sig) => ann -> m a -> m a
annAt ann = send . Ann ann
annWith :: (Carrier sig m, Member Ann sig) => CallStack -> m a -> m a
annWith callStack = maybe id annAt (stackLoc callStack)
annWith :: (Carrier sig m, Member (Ann Span) sig) => CallStack -> m a -> m a
annWith callStack = maybe id (annAt . snd) (stackLoc callStack)
stripAnnotations :: (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann :+: sig) a -> Term sig a
stripAnnotations :: forall ann a sig . (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann ann :+: sig) a -> Term sig a
stripAnnotations (Var v) = Var v
stripAnnotations (Term (L (Ann _ b))) = stripAnnotations b
stripAnnotations (Term (R b)) = Term (hmap stripAnnotations b)

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

@ -1,7 +1,6 @@
{-# LANGUAGE FlexibleContexts, TypeOperators #-}
module Data.Core.Parser
( module Text.Trifecta
, core
( core
, lit
, expr
, record

7
semantic-core/src/Data/File.hs
View File

@ -7,12 +7,15 @@ module Data.File
import Data.Loc
import Data.Maybe (fromJust)
import GHC.Stack
import Source.Span
data File a = File
{ fileLoc :: !Loc
{ filePath :: !Path
, fileSpan :: {-# UNPACK #-} !Span
, fileBody :: !a
}
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
fromBody :: HasCallStack => a -> File a
fromBody body = File (fromJust (stackLoc callStack)) body
fromBody body = File path span body where
(path, span) = fromJust (stackLoc callStack)

21
semantic-core/src/Data/Loc.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Loc
( Loc(..)
, interactive
( Path(..)
, here
, stackLoc
) where
@ -10,23 +9,17 @@ import Data.Text (Text, pack)
import GHC.Stack
import Source.Span
data Loc = Loc
{ locPath :: !Text
, locSpan :: {-# UNPACK #-} !Span
}
newtype Path = Path { getPath :: Text }
deriving (Eq, Ord, Show)
interactive :: Loc
interactive = Loc "<interactive>" (Span (Pos 1 1) (Pos 1 1))
here :: HasCallStack => Maybe Loc
here :: HasCallStack => Maybe (Path, Span)
here = stackLoc callStack
stackLoc :: CallStack -> Maybe Loc
stackLoc :: CallStack -> Maybe (Path, Span)
stackLoc cs = case getCallStack cs of
(_, srcLoc):_ -> Just (fromGHCSrcLoc srcLoc)
_ -> Nothing
fromGHCSrcLoc :: SrcLoc -> Loc
fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
fromGHCSrcLoc :: SrcLoc -> (Path, Span)
fromGHCSrcLoc SrcLoc{..} = (Path (pack srcLocFile), Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))

24
semantic-core/test/Spec.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, TypeOperators #-}
{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-}
module Main (main) where
import Data.String
@ -11,6 +11,7 @@ import Test.Tasty.HUnit
import Control.Effect.Sum
import Data.File
import Data.Loc (Path)
import qualified Generators as Gen
import qualified Analysis.Eval as Eval
import Data.Core
@ -18,10 +19,11 @@ import Data.Core.Pretty
import Data.Core.Parser as Parse
import Data.Name
import Data.Term
import Source.Span
-- * Helpers
true, false :: Term (Ann :+: Core) Name
true, false :: Term Core Name
true = bool True
false = bool False
@ -31,10 +33,10 @@ parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Tri
-- * Parser roundtripping properties. Note that parsing and prettyprinting is generally
-- not a roundtrip, because the parser inserts 'Ann' nodes itself.
prop_roundtrips :: Gen (Term (Ann :+: Core) Name) -> Property
prop_roundtrips :: Gen (Term Core Name) -> Property
prop_roundtrips gen = property $ do
input <- forAll gen
tripping input (showCore . stripAnnotations) (parseEither (Parse.core <* Trifecta.eof))
tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
parserProps :: TestTree
parserProps = testGroup "Parsing: roundtripping"
@ -47,7 +49,7 @@ parserProps = testGroup "Parsing: roundtripping"
-- * Parser specs
parsesInto :: String -> Term (Ann :+: Core) Name -> Assertion
parsesInto :: String -> Term Core Name -> Assertion
parsesInto str res = case parseEither Parse.core str of
Right x -> x @?= res
Left m -> assertFailure m
@ -57,7 +59,7 @@ assert_booleans_parse = do
parseEither Parse.core "#true" @?= Right true
parseEither Parse.core "#false" @?= Right false
a, f, g, h :: Term (Ann :+: Core) Name
a, f, g, h :: Term Core Name
(a, f, g, h) = (pure "a", pure "f", pure "g", pure "h")
assert_ifthen_parse :: Assertion
@ -93,10 +95,10 @@ parserSpecs = testGroup "Parsing: simple specs"
, testCase "quoted names" assert_quoted_name_parse
]
assert_roundtrips :: File (Term (Ann :+: Core) Name) -> Assertion
assert_roundtrips (File _ core) = case parseEither Parse.core (showCore (stripAnnotations core)) of
Right v -> stripAnnotations v @?= stripAnnotations core
Left e -> assertFailure e
assert_roundtrips :: File (Term Core Name) -> Assertion
assert_roundtrips (File _ _ core) = case parseEither Parse.core (showCore core) of
Right v -> v @?= core
Left e -> assertFailure e
parserExamples :: TestTree
parserExamples = testGroup "Parsing: Eval.hs examples"
@ -106,7 +108,7 @@ parserExamples = testGroup "Parsing: Eval.hs examples"
, testCase "prog4" (assert_roundtrips Eval.prog4)
, testCase "prog6.1" (assert_roundtrips (head Eval.prog6))
, testCase "prog6.2" (assert_roundtrips (last Eval.prog6))
, testCase "ruby" (assert_roundtrips Eval.ruby)
, testCase "ruby" (assert_roundtrips (stripAnnotations @Span <$> Eval.ruby))
]
tests :: TestTree

36
semantic-python/src/Language/Python/Core.hs
View File

@ -5,7 +5,6 @@
module Language.Python.Core
( toplevelCompile
, Bindings
, SourcePath
) where
import Prelude hiding (fail)
@ -18,21 +17,13 @@ import Control.Monad ((>=>))
import Data.Coerce
import Data.Core as Core
import Data.Foldable
import Data.Loc (Loc)
import qualified Data.Loc
import Data.Name as Name
import Data.Stack (Stack)
import qualified Data.Stack as Stack
import Data.String (IsString)
import Data.Text (Text)
import GHC.Records
import Source.Span (Span)
import qualified TreeSitter.Python.AST as Py
-- | Access to the current filename as Text to stick into location annotations.
newtype SourcePath = SourcePath { rawPath :: Text }
deriving (Eq, IsString, Show)
-- | Keeps track of the current scope's bindings (so that we can, when
-- compiling a class or module, return the list of bound variables as
-- a Core record so that all immediate definitions are exposed)
@ -57,7 +48,7 @@ pattern SingleIdentifier name <- Py.ExpressionList
-- possible for us to 'cheat' by pattern-matching on or eliminating a
-- compiled term.
type CoreSyntax sig t = ( Member Core sig
, Member Ann sig
, Member (Ann Span) sig
, Carrier sig t
, Foldable t
)
@ -66,7 +57,6 @@ class Compile (py :: * -> *) where
-- FIXME: rather than failing the compilation process entirely
-- with MonadFail, we should emit core that represents failure
compile :: ( CoreSyntax syn t
, Member (Reader SourcePath) sig
, Member (Reader Bindings) sig
, Carrier sig m
, MonadFail m
@ -79,7 +69,6 @@ class Compile (py :: * -> *) where
compile a _ _ = defaultCompile a
toplevelCompile :: ( CoreSyntax syn t
, Member (Reader SourcePath) sig
, Member (Reader Bindings) sig
, Carrier sig m
, MonadFail m
@ -93,20 +82,14 @@ toplevelCompile py = compile py pure none
none :: (Member Core sig, Carrier sig t) => t Name
none = unit
locFromTSSpan :: SourcePath -> Span -> Loc
locFromTSSpan fp = Data.Loc.Loc (rawPath fp)
locate :: ( HasField "ann" syntax Span
, CoreSyntax syn t
, Member (Reader SourcePath) sig
, Carrier sig m
, Applicative m
)
=> syntax
-> t a
-> m (t a)
locate syn item = do
fp <- ask @SourcePath
pure (Core.annAt (locFromTSSpan fp (getField @"ann" syn)) item)
locate syn item = pure (Core.annAt (getField @"ann" syn) item)
defaultCompile :: (MonadFail m, Show py) => py -> m (t Name)
defaultCompile t = fail $ "compilation unimplemented for " <> show t
@ -140,20 +123,18 @@ type Desugared = Py.ExpressionList :+: Py.Yield
-- We have to pair locations and names, and tuple syntax is harder to
-- read in this case than a happy little constructor.
data Located a = Located Loc a
data Located a = Located Span a
-- Desugaring an RHS involves walking as deeply as possible into an
-- assignment, storing the names we encounter as we go and eventually
-- returning a terminal expression. We have to keep track of which
desugar :: (Member (Reader SourcePath) sig, Carrier sig m, MonadFail m)
desugar :: MonadFail m
=> [Located Name]
-> RHS Span
-> m ([Located Name], Desugared Span)
desugar acc = \case
Prj Py.Assignment { left = SingleIdentifier name, right = Just rhs, ann} -> do
loc <- locFromTSSpan <$> ask <*> pure ann
let cons = (Located loc name :)
desugar (cons acc) rhs
Prj Py.Assignment { left = SingleIdentifier name, right = Just rhs, ann} ->
desugar (Located ann name : acc) rhs
R1 any -> pure (acc, any)
other -> fail ("desugar: couldn't desugar RHS " <> show other)
@ -179,8 +160,7 @@ instance Compile Py.Assignment where
, right = Just rhs
, ann
} cc next = do
p <- ask @SourcePath
(names, val) <- desugar [Located (locFromTSSpan p ann) name] rhs
(names, val) <- desugar [Located ann name] rhs
compile val pure next >>= foldr collapseDesugared cc names >>= locate it
compile other _ _ = fail ("Unhandled assignment case: " <> show other)

24
semantic-python/test/Instances.hs
View File

@ -19,27 +19,27 @@ deriving newtype instance ToJSON Name
deriving newtype instance ToJSONKey Name
instance ToJSON a => ToJSON (File a) where
toJSON File{fileLoc, fileBody} = object
[ "location" .= fileLoc
toJSON File{filePath, fileSpan, fileBody} = object
[ "path" .= filePath
, "span" .= fileSpan
, "body" .= fileBody
]
instance ToJSON Loc where
toJSON Loc{locPath, locSpan} = object
[ "kind" .= ("loc" :: Text)
, "path" .= locPath
, "span" .= locSpan
]
deriving newtype instance ToJSON Path
instance ToJSON Ref where
toJSON (Ref loc) = object [ "kind" .= ("ref" :: Text)
, "location" .= loc]
toJSON (Ref path span) = object
[ "kind" .= ("ref" :: Text)
, "path" .= path
, "span" .= span
]
instance ToJSON Decl where
toJSON Decl{declSymbol, declLoc} = object
toJSON Decl{declSymbol, declPath, declSpan} = object
[ "kind" .= ("decl" :: Text)
, "symbol" .= declSymbol
, "location" .= declLoc
, "path" .= declPath
, "span" .= declSpan
]
instance ToJSON ScopeGraph where

9
semantic-python/test/Test.hs
View File

@ -25,10 +25,10 @@ import Data.Loc
import Data.Maybe
import Data.Name
import Data.Term
import Data.String (fromString)
import GHC.Stack
import qualified Language.Python.Core as Py
import Prelude hiding (fail)
import Source.Span
import Streaming
import qualified Streaming.Prelude as Stream
import qualified Streaming.Process
@ -49,10 +49,10 @@ import qualified Directive
import Instances ()
assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann :+: Core) Name -> HUnit.Assertion
assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann Span :+: Core) Name -> HUnit.Assertion
assertJQExpressionSucceeds directive tree core = do
bod <- case scopeGraph Eval.eval [File interactive core] of
(heap, [File _ (Right result)]) -> pure $ Aeson.object
bod <- case scopeGraph Eval.eval [File (Path "<interactive>") (Span (Pos 1 1) (Pos 1 1)) core] of
(heap, [File _ _ (Right result)]) -> pure $ Aeson.object
[ "scope" Aeson..= heap
, "heap" Aeson..= result
]
@ -95,7 +95,6 @@ fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> wi
result <- ByteString.readFile (Path.toString fullPath) >>= TS.parseByteString TSP.tree_sitter_python
let coreResult = Control.Effect.run
. runFail
. runReader (fromString @Py.SourcePath . Path.toString $ fp)
. runReader @Py.Bindings mempty
. Py.toplevelCompile
<$> result