Merge pull request #202 from github/gen-x

robrix · web-flow · commit 3617455ad2ac · 2019-08-06T11:14:53.000-04:00
🔥 Naming, Name, &amp; Gensym
diff --git 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,23 +189,21 @@ 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 _ _                      = []
         fromConcrete = \case
           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
@@ -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
@@ -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
@@ -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
@@ -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
diff --git a/semantic-core/src/Data/Name.hs b/semantic-core/src/Data/Name.hs
