Merge branch 'master' into hack-for-hack

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

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)
 

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
+  [ (fromBody (Core.record
-    [ ("dep", Core.record [ ("var", Core.bool True) ]) ]
+    [ ("dep", Core.record [ ("var", Core.bool True) ]) ]))
-  , File (Path "main") (snd (fromJust here)) $ do' (map (Nothing :<-)
+    { 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)

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

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

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

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)))

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

semantic-core/src/Core/File.hs

@@ -4,18 +4,18 @@ module Core.File
 , fromBody
 ) where
 
-import Core.Loc
+import Data.Maybe (fromJust, listToMaybe)
-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
   }
   deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
 
 fromBody :: HasCallStack => a -> File a
-fromBody body = File path span body where
+fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where
-  (path, span) = fromJust (stackLoc callStack)
+  srcLoc = snd (fromJust (listToMaybe (getCallStack callStack)))

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))

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

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

semantic-source/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 - Adds an `NFData` instance for `Source`.
 
+
 # 0.0.0.1
 
 - Loosens the upper bound on `hashable`.