From c31b151ba85aa0c2f4967fd1cd34ccec5c816a3b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 10 Oct 2019 17:33:56 -0400 Subject: [PATCH] :fire: Core.Loc.Path. --- semantic-core/semantic-core.cabal | 1 + semantic-core/src/Analysis/Concrete.hs | 18 +++++++++--------- semantic-core/src/Analysis/Eval.hs | 5 +++-- semantic-core/src/Analysis/ImportGraph.hs | 14 +++++++------- semantic-core/src/Analysis/ScopeGraph.hs | 16 ++++++++-------- semantic-core/src/Analysis/Typecheck.hs | 10 +++++----- .../src/Control/Carrier/Fail/WithLoc.hs | 12 ++++++------ semantic-core/src/Core/File.hs | 3 ++- semantic-core/src/Core/Loc.hs | 17 ++++++----------- 9 files changed, 47 insertions(+), 49 deletions(-) diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index 65b9e7004..8f387f695 100644 --- a/semantic-core/semantic-core.cabal +++ b/semantic-core/semantic-core.cabal @@ -65,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 b63c25984..91e5dfdad 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.AbsRelFile "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 (show 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 d8f8d39ff..6f2efa28f 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -28,6 +28,7 @@ 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 @@ -130,9 +131,9 @@ prog5 = fromBody $ ann (do' prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)] prog6 = - [ File (Path "dep") (snd (fromJust here)) $ Core.record + [ File (Path.absRel "dep") (snd (fromJust here)) $ Core.record [ ("dep", Core.record [ ("var", Core.bool True) ]) ] - , File (Path "main") (snd (fromJust here)) $ do' (map (Nothing :<-) + , File (Path.absRel "main") (snd (fromJust here)) $ do' (map (Nothing :<-) [ load (Core.string "dep") , Core.record [ ("thing", pure "dep" Core.... "var") ] ]) diff --git a/semantic-core/src/Analysis/ImportGraph.hs b/semantic-core/src/Analysis/ImportGraph.hs index 9df957023..74d5cdde2 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 2c540af1a..89b085563 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 594d00eef..e1d1a8af6 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/File.hs b/semantic-core/src/Core/File.hs index 69f765162..206e900dc 100644 --- a/semantic-core/src/Core/File.hs +++ b/semantic-core/src/Core/File.hs @@ -8,9 +8,10 @@ import Core.Loc import Data.Maybe (fromJust) 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 } diff --git a/semantic-core/src/Core/Loc.hs b/semantic-core/src/Core/Loc.hs index b6c2016f7..f2d8fe740 100644 --- a/semantic-core/src/Core/Loc.hs +++ b/semantic-core/src/Core/Loc.hs @@ -1,25 +1,20 @@ {-# LANGUAGE RecordWildCards #-} module Core.Loc -( Path(..) -, here +( here , stackLoc ) where -import Data.Text (Text, pack) import GHC.Stack import Source.Span +import qualified System.Path as Path -newtype Path = Path { getPath :: Text } - deriving (Eq, Ord, Show) - - -here :: HasCallStack => Maybe (Path, Span) +here :: HasCallStack => Maybe (Path.AbsRelFile, Span) here = stackLoc callStack -stackLoc :: CallStack -> Maybe (Path, Span) +stackLoc :: CallStack -> Maybe (Path.AbsRelFile, 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)) +fromGHCSrcLoc :: SrcLoc -> (Path.AbsRelFile, Span) +fromGHCSrcLoc SrcLoc{..} = (Path.absRel srcLocFile, Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))