diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index a13cba65bb..761a697dde 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -22,26 +22,25 @@ import Control.Effect.State import Control.Monad ((<=<), guard) import qualified Data.Core as Core import Data.File -import Data.Foldable (foldl') import Data.Function (fix) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Loc import qualified Data.Map as Map import Data.Monoid (Alt(..)) -import Data.Name hiding (fresh) +import Data.Name import Data.Term import Data.Text (Text, pack) import Prelude hiding (fail) type Precise = Int -type Env = Map.Map Name Precise +type Env = Map.Map User Precise newtype FrameId = FrameId { unFrameId :: Precise } deriving (Eq, Ord, Show) data Concrete - = Closure Loc Name (Term Core.Core Name) Precise + = Closure Loc User (Term Core.Core User) Precise | Unit | Bool Bool | String Text @@ -65,22 +64,20 @@ type Heap = IntMap.IntMap Concrete -- -- >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.bool True)])) -- [Right (Bool True)] -concrete :: [File (Term Core.Core Name)] -> (Heap, [File (Either (Loc, String) Concrete)]) +concrete :: [File (Term Core.Core User)] -> (Heap, [File (Either (Loc, String) Concrete)]) concrete = run . runFresh - . runNaming . runHeap . traverse runFile runFile :: ( Carrier sig m , Effect sig , Member Fresh sig - , Member Naming sig , Member (Reader FrameId) sig , Member (State Heap) sig ) - => File (Term Core.Core Name) + => File (Term Core.Core User) -> m (File (Either (Loc, String) Concrete)) runFile file = traverse run file where run = runReader (fileLoc file) @@ -143,7 +140,7 @@ concreteAnalysis = Analysis{..} assign addr (Obj (f frame)) -lookupConcrete :: Heap -> Name -> Concrete -> Maybe Precise +lookupConcrete :: Heap -> User -> Concrete -> Maybe Precise lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete where -- look up the name in a concrete value inConcrete = inFrame <=< maybeA . objectFrame @@ -171,7 +168,7 @@ runHeap m = do -- > λ let (heap, res) = concrete [ruby] -- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap)) -- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg -heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge Name -> Precise -> G.Graph a) -> Heap -> G.Graph a +heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h) where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest outgoing = \case @@ -192,7 +189,7 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,) addressStyle :: Heap -> G.Style (EdgeType, Precise) Text addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes } where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap) - edgeAttributes _ (Slot name, _) = ["label" G.:= fromName name] + edgeAttributes _ (Slot name, _) = ["label" G.:= name] edgeAttributes _ (Edge Core.Import, _) = ["color" G.:= "blue"] edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"] edgeAttributes _ _ = [] @@ -200,15 +197,13 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes } Unit -> "()" Bool b -> pack $ show b String s -> pack $ show s - Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]" + Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]" Obj _ -> "{}" showPos (Pos l c) = pack (show l) <> ":" <> pack (show c) - fromName (User s) = s - fromName (Gen (Gensym ss i)) = foldl' (\ ss s -> ss <> "." <> s) (pack (show i)) ss data EdgeType = Edge Core.Edge - | Slot Name + | Slot User | Value Concrete deriving (Eq, Ord, Show) diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index 049f8fb358..a90df33753 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -20,20 +20,25 @@ import Data.Functor import Data.Loc import Data.Maybe (fromJust) import Data.Name +import Data.Scope import Data.Term import Data.Text (Text) import GHC.Stack import Prelude hiding (fail) -eval :: (Carrier sig m, Member Naming sig, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Term Core Name -> m value) -> Term Core Name -> m value +eval :: ( Carrier sig m + , Member (Reader Loc) sig + , MonadFail m + ) + => Analysis address value m + -> (Term Core User -> m value) + -> (Term Core User -> m value) eval Analysis{..} eval = \case Var n -> lookupEnv' n >>= deref' n Term c -> case c of - Let n -> alloc (User n) >>= bind (User n) >> unit + Let n -> alloc n >>= bind n >> unit a :>> b -> eval a >> eval b - Lam _ b -> do - n <- Gen <$> fresh - abstract eval n (instantiate (const (pure n)) b) + Lam (Ignored n) b -> abstract eval n (instantiate1 (pure n) b) f :$ a -> do f' <- eval f a' <- eval a @@ -66,8 +71,8 @@ eval Analysis{..} eval = \case Var n -> lookupEnv' n Term c -> case c of Let n -> do - addr <- alloc (User n) - addr <$ bind (User n) addr + addr <- alloc n + addr <$ bind n addr If c t e -> do c' <- eval c >>= asBool if c' then ref t else ref e @@ -109,8 +114,11 @@ prog4 = fromBody $ block prog5 :: File (Term Core User) prog5 = fromBody $ block [ let' "mkPoint" .= lam' "_x" (lam' "_y" (block - [ let' "x" .= pure "_x" - , let' "y" .= pure "_y"])) + [ let' "this" .= Core.frame + , pure "this" Core.... let' "x" .= pure "_x" + , pure "this" Core.... let' "y" .= pure "_y" + , pure "this" + ])) , let' "point" .= pure "mkPoint" $$ Core.bool True $$ Core.bool False , pure "point" Core.... pure "x" , pure "point" Core.... pure "y" .= pure "point" Core.... pure "x" @@ -120,9 +128,7 @@ prog6 :: [File (Term Core User)] prog6 = [ File (Loc "dep" (locSpan (fromJust here))) $ block [ let' "dep" .= Core.frame - , pure "dep" Core.... block - [ let' "var" .= Core.bool True - ] + , pure "dep" Core.... (let' "var" .= Core.bool True) ] , File (Loc "main" (locSpan (fromJust here))) $ block [ load (Core.string "dep") @@ -203,13 +209,13 @@ ruby = fromBody . ann . block $ data Analysis address value m = Analysis - { alloc :: Name -> m address - , bind :: Name -> address -> m () - , lookupEnv :: Name -> m (Maybe address) + { alloc :: User -> m address + , bind :: User -> address -> m () + , lookupEnv :: User -> m (Maybe address) , deref :: address -> m (Maybe value) , assign :: address -> value -> m () - , abstract :: (Term Core Name -> m value) -> Name -> Term Core Name -> m value - , apply :: (Term Core Name -> m value) -> value -> value -> m value + , abstract :: (Term Core User -> m value) -> User -> Term Core User -> m value + , apply :: (Term Core User -> m value) -> value -> value -> m value , unit :: m value , bool :: Bool -> m value , asBool :: value -> m Bool diff --git a/semantic-core/src/Analysis/ImportGraph.hs b/semantic-core/src/Analysis/ImportGraph.hs index 31e55dad3d..7247462f17 100644 --- a/semantic-core/src/Analysis/ImportGraph.hs +++ b/semantic-core/src/Analysis/ImportGraph.hs @@ -22,7 +22,6 @@ import Data.Loc import qualified Data.Map as Map import Data.Name import qualified Data.Set as Set -import Data.Stack import Data.Term import Data.Text (Text) import Prelude hiding (fail) @@ -42,29 +41,27 @@ instance Monoid Value where mempty = Value Abstract mempty data Semi - = Closure Loc Name (Term Core.Core Name) Name + = Closure Loc User (Term Core.Core User) User -- FIXME: Bound String values. | String Text | Abstract deriving (Eq, Ord, Show) -importGraph :: [File (Term Core.Core Name)] -> (Heap Name Value, [File (Either (Loc, String) Value)]) +importGraph :: [File (Term Core.Core User)] -> (Heap User Value, [File (Either (Loc, String) Value)]) importGraph = run . runFresh - . runNaming - . runHeap (Gen (Gensym (Nil :> "root") 0)) + . runHeap "__semantic_root" . traverse runFile runFile :: ( Carrier sig m , Effect sig , Member Fresh sig - , Member Naming sig - , Member (Reader (FrameId Name)) sig - , Member (State (Heap Name Value)) sig + , Member (Reader (FrameId User)) sig + , Member (State (Heap User Value)) sig ) - => File (Term Core.Core Name) + => File (Term Core.Core User) -> m (File (Either (Loc, String) Value)) runFile file = traverse run file where run = runReader (fileLoc file) @@ -75,12 +72,12 @@ runFile file = traverse run file -- FIXME: decompose into a product domain and two atomic domains importGraphAnalysis :: ( Alternative m , Carrier sig m - , Member (Reader (FrameId Name)) sig + , Member (Reader (FrameId User)) sig , Member (Reader Loc) sig - , Member (State (Heap Name Value)) sig + , Member (State (Heap User Value)) sig , MonadFail m ) - => Analysis Name Value m + => Analysis User Value m importGraphAnalysis = Analysis{..} where alloc = pure bind _ _ = pure () @@ -104,7 +101,7 @@ importGraphAnalysis = Analysis{..} asString (Value (String s) _) = pure s asString _ = pure mempty frame = pure mempty - edge Core.Import (User to) = do -- FIXME: figure out some other way to do this + edge Core.Import to = do -- FIXME: figure out some other way to do this Loc{locPath=from} <- ask () <$ pure (Value Abstract (Map.singleton from (Set.singleton to))) edge _ _ = pure () diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index 4c83a933f3..998dc301b6 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -31,7 +31,6 @@ import Data.Maybe (fromJust, fromMaybe) import Data.Name as Name import Data.Scope import qualified Data.Set as Set -import Data.Stack import Data.Term import Data.Void import GHC.Generics (Generic1) @@ -83,28 +82,26 @@ generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Void generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty))) -typecheckingFlowInsensitive :: [File (Term Core.Core Name)] -> (Heap Name (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))]) +typecheckingFlowInsensitive :: [File (Term Core.Core User)] -> (Heap User (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))]) typecheckingFlowInsensitive = run . runFresh - . runNaming - . runHeap (Gen (Gensym (Nil :> "root") 0)) + . runHeap "__semantic_root" . fmap (fmap (fmap (fmap generalize))) . traverse runFile runFile :: ( Carrier sig m , Effect sig , Member Fresh sig - , Member Naming sig - , Member (State (Heap Name (Term Monotype Meta))) sig + , Member (State (Heap User (Term Monotype Meta))) sig ) - => File (Term Core.Core Name) + => File (Term Core.Core User) -> m (File (Either (Loc, String) (Term Monotype Meta))) runFile file = traverse run file where run = (\ m -> do (subst, t) <- m - modify @(Heap Name (Term Monotype Meta)) (fmap (Set.map (substAll subst))) + modify @(Heap User (Term Monotype Meta)) (fmap (Set.map (substAll subst))) pure (substAll subst <$> t)) . runState (mempty :: Substitution) . runReader (fileLoc file) @@ -119,7 +116,15 @@ runFile file = traverse run file v <$ for_ bs (unify v)) . convergeTerm (fix (cacheTerm . eval typecheckingAnalysis)) -typecheckingAnalysis :: (Alternative m, Carrier sig m, Member Fresh sig, Member (State (Set.Set Constraint)) sig, Member (State (Heap Name (Term Monotype Meta))) sig, MonadFail m) => Analysis Name (Term Monotype Meta) m +typecheckingAnalysis + :: ( Alternative m + , Carrier sig m + , Member Fresh sig + , Member (State (Set.Set Constraint)) sig + , Member (State (Heap User (Term Monotype Meta))) sig + , MonadFail m + ) + => Analysis User (Term Monotype Meta) m typecheckingAnalysis = Analysis{..} where alloc = pure bind _ _ = pure () diff --git a/semantic-core/src/Data/Core.hs b/semantic-core/src/Data/Core.hs index e3a6d8c270..31f3912caf 100644 --- a/semantic-core/src/Data/Core.hs +++ b/semantic-core/src/Data/Core.hs @@ -71,7 +71,7 @@ data Core f a deriving (Foldable, Functor, Generic1, Traversable) infixr 1 :>> -infixl 2 :$ +infixl 9 :$ infixl 4 :. infix 3 := @@ -139,7 +139,7 @@ unseqs = go ($$) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a f $$ a = send (f :$ a) -infixl 2 $$ +infixl 9 $$ -- | Application of a function to a sequence of arguments. ($$*) :: (Foldable t, Carrier sig m, Member Core sig) => m a -> t (m a) -> m a diff --git a/semantic-core/src/Data/Core/Pretty.hs b/semantic-core/src/Data/Core/Pretty.hs index 57e70c7cb4..92280c0fd7 100644 --- a/semantic-core/src/Data/Core/Pretty.hs +++ b/semantic-core/src/Data/Core/Pretty.hs @@ -56,16 +56,15 @@ inParens amount go = do pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body) prettyCore :: Style -> Term Core User -> AnsiDoc -prettyCore style = run . runReader @Prec 0 . go (pure . name) - where go :: (Member (Reader Prec) sig, Carrier sig m) => (a -> m AnsiDoc) -> Term Core a -> m AnsiDoc - go var = \case - Var v -> var v +prettyCore style = run . runReader @Prec 0 . go + where go = \case + Var v -> pure (name v) Term t -> case t of Let a -> pure $ keyword "let" <+> name a a :>> b -> do prec <- ask @Prec - fore <- with 12 (go var a) - aft <- with 12 (go var b) + fore <- with 12 (go a) + aft <- with 12 (go b) let open = symbol ("{" <> softline) close = symbol (softline <> "}") @@ -76,37 +75,37 @@ prettyCore style = run . runReader @Prec 0 . go (pure . name) Lam n f -> inParens 11 $ do (x, body) <- bind n f - pure (lambda <> x <+> arrow <+> body) + pure (lambda <> name x <+> arrow <+> body) Frame -> pure $ primitive "frame" Unit -> pure $ primitive "unit" Bool b -> pure $ primitive (if b then "true" else "false") String s -> pure . strlit $ Pretty.viaShow s - f :$ x -> inParens 11 $ (<+>) <$> go var f <*> go var x + f :$ x -> inParens 11 $ (<+>) <$> go f <*> go x If con tru fal -> do - con' <- "if" `appending` go var con - tru' <- "then" `appending` go var tru - fal' <- "else" `appending` go var fal + con' <- "if" `appending` go con + tru' <- "then" `appending` go tru + fal' <- "else" `appending` go fal pure $ Pretty.sep [con', tru', fal'] - Load p -> "load" `appending` go var p - Edge Lexical n -> "lexical" `appending` go var n - Edge Import n -> "import" `appending` go var n + Load p -> "load" `appending` go p + Edge Lexical n -> "lexical" `appending` go n + Edge Import n -> "import" `appending` go n item :. body -> inParens 4 $ do - f <- go var item - g <- go var body + f <- go item + g <- go body pure (f <> symbol "." <> g) lhs := rhs -> inParens 3 $ do - f <- go var lhs - g <- go var rhs + f <- go lhs + g <- go rhs pure (f <+> symbol "=" <+> g) -- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly. - Ann _ c -> go var c - where bind (Ignored x) f = let x' = name x in (,) x' <$> go (incr (const (pure x')) var) (fromScope f) + Ann _ c -> go c + where bind (Ignored x) f = (,) x <$> go (instantiate1 (pure x) f) lambda = case style of Unicode -> symbol "λ" Ascii -> symbol "\\" diff --git a/semantic-core/src/Data/Name.hs b/semantic-core/src/Data/Name.hs index cf2bb4b2d4..d7f644669a 100644 --- a/semantic-core/src/Data/Name.hs +++ b/semantic-core/src/Data/Name.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DeriveTraversable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, OverloadedLists, OverloadedStrings, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Data.Name ( User -, Namespaced -, Name(..) , Named(..) , named , named' @@ -13,52 +11,16 @@ module Data.Name , isSimpleCharacter , needsQuotation , encloseIf -, Gensym(..) -, prime -, fresh -, namespace -, Naming(..) -, runNaming -, NamingC(..) ) where -import Control.Effect.Carrier -import Control.Effect.Reader -import Control.Effect.State -import Control.Monad.Fail -import Control.Monad.IO.Class import qualified Data.Char as Char import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.Stack import Data.Text as Text (Text, any, unpack) -import Data.Text.Prettyprint.Doc (Pretty (..)) -- | User-specified and -relevant names. type User = Text --- | The type of namespaced actions, i.e. actions occurring within some outer name. --- --- This corresponds to the @Agent@ type synonym described in /I Am Not a Number—I Am a Free Variable/. -type Namespaced a = Gensym -> a - -data Name - -- | A locally-bound, machine-generatable name. - -- - -- This should be used for locals, function parameters, and similar names which can’t escape their defining scope. - = Gen Gensym - -- | A name provided by a user. - -- - -- This should be used for names which the user provided and which other code (other functions, other modules, other packages) could call, e.g. declaration names. - | User User - deriving (Eq, Ord, Show) - -instance Pretty Name where - pretty = \case - Gen p -> pretty p - User n -> pretty n - - -- | Annotates an @a@ with a 'User'-provided name, which is ignored for '==' and 'compare'. data Named a = Named (Ignored User) a deriving (Eq, Foldable, Functor, Ord, Show, Traversable) @@ -104,49 +66,3 @@ isSimpleCharacter = \case '_' -> True '?' -> True -- common in Ruby c -> Char.isAlphaNum c - - -data Gensym = Gensym (Stack Text) Int - deriving (Eq, Ord, Show) - -instance Pretty Gensym where - pretty (Gensym _ i) = pretty (alphabet !! r : if q > 0 then show q else "") - where (q, r) = i `divMod` 26 - alphabet = ['a'..'z'] - -prime :: Gensym -> Gensym -prime (Gensym s i) = Gensym s (succ i) - - -fresh :: (Carrier sig m, Member Naming sig) => m Gensym -fresh = send (Fresh pure) - -namespace :: (Carrier sig m, Member Naming sig) => Text -> m a -> m a -namespace s m = send (Namespace s m pure) - - -data Naming m k - = Fresh (Gensym -> m k) - | forall a . Namespace Text (m a) (a -> m k) - -deriving instance Functor m => Functor (Naming m) - -instance HFunctor Naming where - hmap f (Fresh k) = Fresh (f . k) - hmap f (Namespace s m k) = Namespace s (f m) (f . k) - -instance Effect Naming where - handle state handler (Fresh k) = Fresh (handler . (<$ state) . k) - handle state handler (Namespace s m k) = Namespace s (handler (m <$ state)) (handler . fmap k) - - -runNaming :: Functor m => NamingC m a -> m a -runNaming = runReader Nil . evalState 0 . runNamingC - -newtype NamingC m a = NamingC { runNamingC :: StateC Int (ReaderC (Stack Text) m) a } - deriving (Applicative, Functor, Monad, MonadFail, MonadIO) - -instance (Carrier sig m, Effect sig) => Carrier (Naming :+: sig) (NamingC m) where - eff (L (Fresh k)) = NamingC (asks Gensym <*> get <* modify (succ @Int) >>= runNamingC . k) - eff (L (Namespace s m k)) = NamingC (StateC (\ i -> local (:> s) (evalState 0 (runNamingC m)) >>= runState i . runNamingC . k)) - eff (R other) = NamingC (eff (R (R (handleCoercible other))))