Merge branch 'master' into hack-for-hack

2025-01-03 04:51:57 +03:00 · 2019-10-11 14:51:18 -04:00 · 2019-10-11 14:51:18 -04:00 · 8d749f7035
commit 8d749f7035
parent c4047af778 f107b925d6
13 changed files with 57 additions and 80 deletions
--- 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
--- 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)

--- 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)
--- 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
--- 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
--- 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
--- 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)))
--- 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
--- 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)))
--- a/semantic-core/src/Core/Loc.hs
+++ b/semantic-core/src/Core/Loc.hs
@ -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))
--- 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
--- 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 "<interactive>") (Span (Pos 1 1) (Pos 1 1)) core] of
+  bod <- case scopeGraph Eval.eval [File (Path.absRel "<interactive>") (Span (Pos 1 1) (Pos 1 1)) core] of
    (heap, [File _ _ (Right result)]) -> pure $ Aeson.object
      [ "scope" Aeson..= heap
      , "heap"  Aeson..= result
--- 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`.