diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index 257373af2..d92b0bed7 100644 --- a/semantic-core/semantic-core.cabal +++ b/semantic-core/semantic-core.cabal @@ -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 diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index a58fde244..33ddc84ae 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -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) diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index d645d355b..21064d82a 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -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 diff --git a/semantic-core/src/Analysis/ImportGraph.hs b/semantic-core/src/Analysis/ImportGraph.hs index 7775479c4..acf2f49aa 100644 --- a/semantic-core/src/Analysis/ImportGraph.hs +++ b/semantic-core/src/Analysis/ImportGraph.hs @@ -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) diff --git a/semantic-core/src/Analysis/ScopeGraph.hs b/semantic-core/src/Analysis/ScopeGraph.hs index bd102ac55..fafe49f3d 100644 --- a/semantic-core/src/Analysis/ScopeGraph.hs +++ b/semantic-core/src/Analysis/ScopeGraph.hs @@ -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) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index 62171a765..3188c65fd 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -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 diff --git a/semantic-core/src/Control/Carrier/Fail/WithLoc.hs b/semantic-core/src/Control/Carrier/Fail/WithLoc.hs index e582505ee..33790a5c3 100644 --- a/semantic-core/src/Control/Carrier/Fail/WithLoc.hs +++ b/semantic-core/src/Control/Carrier/Fail/WithLoc.hs @@ -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))) diff --git a/semantic-core/src/Data/Core.hs b/semantic-core/src/Data/Core.hs index 6691516ae..bb7e46b56 100644 --- a/semantic-core/src/Data/Core.hs +++ b/semantic-core/src/Data/Core.hs @@ -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) diff --git a/semantic-core/src/Data/Core/Parser.hs b/semantic-core/src/Data/Core/Parser.hs index fc4b88c52..c62ffc75d 100644 --- a/semantic-core/src/Data/Core/Parser.hs +++ b/semantic-core/src/Data/Core/Parser.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts, TypeOperators #-} module Data.Core.Parser - ( module Text.Trifecta - , core + ( core , lit , expr , record diff --git a/semantic-core/src/Data/File.hs b/semantic-core/src/Data/File.hs index 84f39781e..65b2623a1 100644 --- a/semantic-core/src/Data/File.hs +++ b/semantic-core/src/Data/File.hs @@ -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) diff --git a/semantic-core/src/Data/Loc.hs b/semantic-core/src/Data/Loc.hs index 250db1742..0d5f2193e 100644 --- a/semantic-core/src/Data/Loc.hs +++ b/semantic-core/src/Data/Loc.hs @@ -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 "" (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)) diff --git a/semantic-core/test/Spec.hs b/semantic-core/test/Spec.hs index 23d264b65..4001a4f51 100644 --- a/semantic-core/test/Spec.hs +++ b/semantic-core/test/Spec.hs @@ -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 diff --git a/semantic-python/src/Language/Python/Core.hs b/semantic-python/src/Language/Python/Core.hs index dddd64673..30f28df83 100644 --- a/semantic-python/src/Language/Python/Core.hs +++ b/semantic-python/src/Language/Python/Core.hs @@ -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) diff --git a/semantic-python/test/Instances.hs b/semantic-python/test/Instances.hs index 9ec455f26..1f52ab4f9 100644 --- a/semantic-python/test/Instances.hs +++ b/semantic-python/test/Instances.hs @@ -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 diff --git a/semantic-python/test/Test.hs b/semantic-python/test/Test.hs index 41f58d20b..8a230ca19 100644 --- a/semantic-python/test/Test.hs +++ b/semantic-python/test/Test.hs @@ -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 "") (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