diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index 7fcd779d2..6b1021e7e 100644 --- a/semantic-core/semantic-core.cabal +++ b/semantic-core/semantic-core.cabal @@ -54,7 +54,6 @@ library Core.Core.Parser Core.Core.Pretty Core.File - Core.Loc Core.Name build-depends: algebraic-graphs ^>= 0.3 @@ -66,6 +65,7 @@ library , fused-syntax , haskeline ^>= 0.7.5 , parsers ^>= 0.12.10 + , pathtype ^>= 0.8.1 , prettyprinter ^>= 1.2.1 , prettyprinter-ansi-terminal ^>= 1.1.1 , semantic-source ^>= 0 diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index 24ae13817..1cdf51827 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -21,7 +21,6 @@ import Control.Effect.Reader hiding (Local) import Control.Effect.State import Control.Monad ((<=<), guard) import Core.File -import Core.Loc import Core.Name import Data.Function (fix) import qualified Data.IntMap as IntMap @@ -33,6 +32,7 @@ import Data.Text (Text, pack) import Data.Traversable (for) import Prelude hiding (fail) import Source.Span +import qualified System.Path as Path type Precise = Int type Env = Map.Map Name Precise @@ -41,7 +41,7 @@ newtype FrameId = FrameId { unFrameId :: Precise } deriving (Eq, Ord, Show) data Concrete term - = Closure Path Span Name term Env + = Closure Path.AbsRelFile 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 (Path "bool") (Span (Pos 1 1) (Pos 1 5)) (Core.bool True)])) +-- >>> map fileBody (snd (concrete eval [File (Path.absRel "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 Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) (Concrete (term Name)))]) + -> (Heap (term Name), [File (Either (Path.AbsRelFile, Span, String) (Concrete (term Name)))]) concrete eval = run . runFresh @@ -94,13 +94,13 @@ runFile , Show (term Name) ) => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) (Concrete (term Name)))) + -> m (File (Either (Path.AbsRelFile, Span, String) (Concrete (term Name)))) runFile eval file = traverse run file where run = runReader (filePath file) . runReader (fileSpan file) @@ -112,7 +112,7 @@ concreteAnalysis :: ( Carrier sig m , Foldable term , Member Fresh sig , Member (Reader Env) sig - , Member (Reader Path) sig + , Member (Reader Path.AbsRelFile) sig , Member (Reader Span) sig , Member (State (Heap (term Name))) sig , MonadFail m @@ -209,7 +209,7 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes } Unit -> "()" Bool b -> pack $ show b String s -> pack $ show s - Closure p (Span s e) n _ _ -> "\\\\ " <> unName n <> " [" <> getPath p <> ":" <> showPos s <> "-" <> showPos e <> "]" + Closure p (Span s e) n _ _ -> "\\\\ " <> unName n <> " [" <> pack (Path.toString 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 ae95cf281..b8634a251 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -18,15 +18,15 @@ import Control.Effect.Reader import Control.Monad ((>=>)) import Core.Core as Core import Core.File -import Core.Loc import Core.Name import Data.Functor -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromMaybe) import GHC.Stack import Prelude hiding (fail) import Source.Span import Syntax.Scope import Syntax.Term +import qualified System.Path as Path eval :: ( Carrier sig m , Member (Reader Span) sig @@ -129,12 +129,14 @@ prog5 = fromBody $ ann (do' prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)] prog6 = - [ File (Path "dep") (snd (fromJust here)) $ Core.record - [ ("dep", Core.record [ ("var", Core.bool True) ]) ] - , File (Path "main") (snd (fromJust here)) $ do' (map (Nothing :<-) + [ (fromBody (Core.record + [ ("dep", Core.record [ ("var", Core.bool True) ]) ])) + { filePath = Path.absRel "dep"} + , (fromBody (do' (map (Nothing :<-) [ load (Core.string "dep") , Core.record [ ("thing", pure "dep" Core.... "var") ] - ]) + ]))) + { filePath = Path.absRel "main" } ] ruby :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name) diff --git a/semantic-core/src/Analysis/ImportGraph.hs b/semantic-core/src/Analysis/ImportGraph.hs index a1a436593..2b2fbafc9 100644 --- a/semantic-core/src/Analysis/ImportGraph.hs +++ b/semantic-core/src/Analysis/ImportGraph.hs @@ -15,7 +15,6 @@ import Control.Effect.Reader import Control.Effect.State import Control.Monad ((>=>)) import Core.File -import Core.Loc import Core.Name import Data.Foldable (fold, for_) import Data.Function (fix) @@ -26,6 +25,7 @@ import qualified Data.Set as Set import Data.Text (Text) import Prelude hiding (fail) import Source.Span +import qualified System.Path as Path type ImportGraph = Map.Map Text (Set.Set Text) @@ -42,7 +42,7 @@ instance Monoid (Value term) where mempty = Value Abstract mempty data Semi term - = Closure Path Span Name term + = Closure Path.AbsRelFile Span Name term -- FIXME: Bound String values. | String Text | Abstract @@ -52,14 +52,14 @@ data Semi term importGraph :: (Ord term, Show term) => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) (Value term))] + , [File (Either (Path.AbsRelFile, Span, String) (Value term))] ) importGraph eval = run @@ -76,13 +76,13 @@ runFile , Show term ) => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) (Value term))) + -> m (File (Either (Path.AbsRelFile, Span, String) (Value term))) runFile eval file = traverse run file where run = runReader (filePath file) . runReader (fileSpan file) @@ -93,7 +93,7 @@ runFile eval file = traverse run file -- FIXME: decompose into a product domain and two atomic domains importGraphAnalysis :: ( Alternative m , Carrier sig m - , Member (Reader Path) sig + , Member (Reader Path.AbsRelFile) sig , Member (Reader Span) sig , Member (State (Heap Name (Value term))) sig , MonadFail m diff --git a/semantic-core/src/Analysis/ScopeGraph.hs b/semantic-core/src/Analysis/ScopeGraph.hs index 79547ebb0..0606d53b1 100644 --- a/semantic-core/src/Analysis/ScopeGraph.hs +++ b/semantic-core/src/Analysis/ScopeGraph.hs @@ -17,7 +17,6 @@ import Control.Effect.Reader import Control.Effect.State import Control.Monad ((>=>)) import Core.File -import Core.Loc import Core.Name import Data.Foldable (fold) import Data.Function (fix) @@ -28,16 +27,17 @@ import qualified Data.Set as Set import Data.Traversable (for) import Prelude hiding (fail) import Source.Span +import qualified System.Path as Path data Decl = Decl { declSymbol :: Name - , declPath :: Path + , declPath :: Path.AbsRelFile , declSpan :: Span } deriving (Eq, Ord, Show) data Ref = Ref - { refPath :: Path + { refPath :: Path.AbsRelFile , refSpan :: Span } deriving (Eq, Ord, Show) @@ -54,13 +54,13 @@ instance Monoid ScopeGraph where scopeGraph :: Ord term => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) ScopeGraph)]) + -> (Heap Name ScopeGraph, [File (Either (Path.AbsRelFile, Span, String) ScopeGraph)]) scopeGraph eval = run . runFresh @@ -75,13 +75,13 @@ runFile , Ord term ) => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) => Analysis term Name ScopeGraph m -> (term -> m ScopeGraph) -> (term -> m ScopeGraph) ) -> File term - -> m (File (Either (Path, Span, String) ScopeGraph)) + -> m (File (Either (Path.AbsRelFile, Span, String) ScopeGraph)) runFile eval file = traverse run file where run = runReader (filePath file) . runReader (fileSpan file) @@ -93,7 +93,7 @@ runFile eval file = traverse run file scopeGraphAnalysis :: ( Alternative m , Carrier sig m - , Member (Reader Path) sig + , Member (Reader Path.AbsRelFile) sig , Member (Reader Span) sig , Member (Reader (Map.Map Name Ref)) sig , Member (State (Heap Name ScopeGraph)) sig diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index f4c2c0603..58eb5fe86 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -17,7 +17,6 @@ import Control.Effect.Reader hiding (Local) import Control.Effect.State import Control.Monad ((>=>), unless) import Core.File -import Core.Loc import Core.Name as Name import Data.Foldable (for_) import Data.Function (fix) @@ -39,6 +38,7 @@ import Syntax.Module import Syntax.Scope import Syntax.Term import Syntax.Var (closed) +import qualified System.Path as Path data Monotype f a = Bool @@ -96,14 +96,14 @@ generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R typecheckingFlowInsensitive :: Ord term => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) 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 (Path, Span, String) (Term (Polytype :+: Monotype) Void))] + , [File (Either (Path.AbsRelFile, Span, String) (Term (Polytype :+: Monotype) Void))] ) typecheckingFlowInsensitive eval = run @@ -120,13 +120,13 @@ runFile , Ord term ) => (forall sig m - . (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m) + . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) => Analysis term Name Type m -> (term -> m Type) -> (term -> m Type) ) -> File term - -> m (File (Either (Path, Span, String) Type)) + -> m (File (Either (Path.AbsRelFile, Span, String) Type)) runFile eval file = traverse run file where run = (\ m -> do diff --git a/semantic-core/src/Control/Carrier/Fail/WithLoc.hs b/semantic-core/src/Control/Carrier/Fail/WithLoc.hs index f2e8b62ea..90cf3c157 100644 --- a/semantic-core/src/Control/Carrier/Fail/WithLoc.hs +++ b/semantic-core/src/Control/Carrier/Fail/WithLoc.hs @@ -12,22 +12,22 @@ import Control.Effect.Carrier import Control.Effect.Error import Control.Effect.Fail (Fail(..), MonadFail(..)) import Control.Effect.Reader -import Core.Loc import Prelude hiding (fail) import Source.Span +import qualified System.Path as Path -runFail :: FailC m a -> m (Either (Path, Span, String) a) +runFail :: FailC m a -> m (Either (Path.AbsRelFile, Span, String) a) runFail = runError . runFailC -newtype FailC m a = FailC { runFailC :: ErrorC (Path, Span, String) m a } +newtype FailC m a = FailC { runFailC :: ErrorC (Path.AbsRelFile, Span, String) m a } deriving (Alternative, Applicative, Functor, Monad) -instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => MonadFail (FailC m) where +instance (Carrier sig m, Effect sig, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig) => MonadFail (FailC m) where fail s = do path <- ask span <- ask - FailC (throwError (path :: Path, span :: Span, s)) + FailC (throwError (path :: Path.AbsRelFile, span :: Span, s)) -instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => Carrier (Fail :+: sig) (FailC m) where +instance (Carrier sig m, Effect sig, Member (Reader Path.AbsRelFile) 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/Core/Core.hs b/semantic-core/src/Core/Core.hs index 1647c6c6b..481a11b7b 100644 --- a/semantic-core/src/Core/Core.hs +++ b/semantic-core/src/Core/Core.hs @@ -37,12 +37,11 @@ module Core.Core import Control.Applicative (Alternative (..)) import Control.Effect.Carrier -import Core.Loc import Core.Name import Data.Bifunctor (Bifunctor (..)) import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Text (Text) import GHC.Generics (Generic1) import GHC.Stack @@ -233,7 +232,7 @@ annAt :: (Carrier sig m, Member (Ann ann) sig) => ann -> m a -> m a annAt ann = send . Ann ann annWith :: (Carrier sig m, Member (Ann Span) sig) => CallStack -> m a -> m a -annWith callStack = maybe id (annAt . snd) (stackLoc callStack) +annWith callStack = maybe id (annAt . spanFromSrcLoc . snd) (listToMaybe (getCallStack callStack)) stripAnnotations :: forall ann a sig . (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann ann :+: sig) a -> Term sig a diff --git a/semantic-core/src/Core/File.hs b/semantic-core/src/Core/File.hs index 69f765162..9962faa5f 100644 --- a/semantic-core/src/Core/File.hs +++ b/semantic-core/src/Core/File.hs @@ -4,18 +4,18 @@ module Core.File , fromBody ) where -import Core.Loc -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, listToMaybe) import GHC.Stack import Source.Span +import qualified System.Path as Path data File a = File - { filePath :: !Path + { filePath :: !Path.AbsRelFile , fileSpan :: {-# UNPACK #-} !Span , fileBody :: !a } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) fromBody :: HasCallStack => a -> File a -fromBody body = File path span body where - (path, span) = fromJust (stackLoc callStack) +fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where + srcLoc = snd (fromJust (listToMaybe (getCallStack callStack))) diff --git a/semantic-core/src/Core/Loc.hs b/semantic-core/src/Core/Loc.hs deleted file mode 100644 index b6c2016f7..000000000 --- a/semantic-core/src/Core/Loc.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Core.Loc -( Path(..) -, here -, stackLoc -) where - -import Data.Text (Text, pack) -import GHC.Stack -import Source.Span - -newtype Path = Path { getPath :: Text } - deriving (Eq, Ord, Show) - - -here :: HasCallStack => Maybe (Path, Span) -here = stackLoc callStack - -stackLoc :: CallStack -> Maybe (Path, Span) -stackLoc cs = case getCallStack cs of - (_, srcLoc):_ -> Just (fromGHCSrcLoc srcLoc) - _ -> Nothing - -fromGHCSrcLoc :: SrcLoc -> (Path, Span) -fromGHCSrcLoc SrcLoc{..} = (Path (pack srcLocFile), Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol)) diff --git a/semantic-python/test/Instances.hs b/semantic-python/test/Instances.hs index 3db17c44a..5a7750d11 100644 --- a/semantic-python/test/Instances.hs +++ b/semantic-python/test/Instances.hs @@ -9,11 +9,11 @@ module Instances () where import Analysis.ScopeGraph import Core.File -import Core.Loc import Core.Name (Name (..)) import Data.Aeson import qualified Data.Map as Map -import Data.Text (Text) +import Data.Text (Text, pack) +import qualified System.Path as Path deriving newtype instance ToJSON Name deriving newtype instance ToJSONKey Name @@ -25,7 +25,8 @@ instance ToJSON a => ToJSON (File a) where , "body" .= fileBody ] -deriving newtype instance ToJSON Path +instance ToJSON Path.AbsRelFile where + toJSON p = toJSON (pack (Path.toString p)) instance ToJSON Ref where toJSON (Ref path span) = object diff --git a/semantic-python/test/Test.hs b/semantic-python/test/Test.hs index 739174b9d..11a5ee333 100644 --- a/semantic-python/test/Test.hs +++ b/semantic-python/test/Test.hs @@ -14,7 +14,6 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Core.Core import Core.Core.Pretty import Core.File -import Core.Loc import Core.Name import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson @@ -51,7 +50,7 @@ import Instances () assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann Span :+: Core) Name -> HUnit.Assertion assertJQExpressionSucceeds directive tree core = do - bod <- case scopeGraph Eval.eval [File (Path "") (Span (Pos 1 1) (Pos 1 1)) core] of + bod <- case scopeGraph Eval.eval [File (Path.absRel "") (Span (Pos 1 1) (Pos 1 1)) core] of (heap, [File _ _ (Right result)]) -> pure $ Aeson.object [ "scope" Aeson..= heap , "heap" Aeson..= result diff --git a/semantic-source/CHANGELOG.md b/semantic-source/CHANGELOG.md index f1859800e..9182facd8 100644 --- a/semantic-source/CHANGELOG.md +++ b/semantic-source/CHANGELOG.md @@ -2,6 +2,7 @@ - Adds an `NFData` instance for `Source`. + # 0.0.0.1 - Loosens the upper bound on `hashable`.