github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

🔥 Core.Loc.Path.

Browse Source
This commit is contained in:
Rob Rix 2019-10-10 17:33:56 -04:00
parent aee5f5110c
commit c31b151ba8
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
9 changed files with 47 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic-core/semantic-core.cabal
View File

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

18
semantic-core/src/Analysis/Concrete.hs
View File

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

5
semantic-core/src/Analysis/Eval.hs
View File

@ -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") ]
])

14
semantic-core/src/Analysis/ImportGraph.hs
View File

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

16
semantic-core/src/Analysis/ScopeGraph.hs
View File

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

10
semantic-core/src/Analysis/Typecheck.hs
View File

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

12
semantic-core/src/Control/Carrier/Fail/WithLoc.hs
View File

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

3
semantic-core/src/Core/File.hs
View File

@ -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
}

17
semantic-core/src/Core/Loc.hs
View File

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