src/Gyehoek/Scheme/Expand.hs

@@ -14,7 +14,7 @@ import qualified Data.HashMap.Strict as H
 import Data.Foldable
 import Data.These
 import Data.Zip
-import Prelude hiding (zip)
+import Prelude hiding (filter, zip, mapMaybe)
 import qualified Data.List.NonEmpty as NE
 import Data.Monoid (Ap(Ap, getAp))
 import Gyehoek.Sexp.Grammar.Base ((:-)(..))
@@ -28,7 +28,11 @@ import GHC.Exts (IsList(..))
 import Gyehoek.Jalmot
 import Data.Maybe (isNothing)
 import Data.Kind (Type)
-import Data.Traversable (for)
+import Data.Traversable (for, mapAccumR)
+import Effectful.State.Static.Shared
+import Witherable
+import Data.Semigroup (Arg(..))
+import Data.Ord (Down(..))
 
 
 data Bind
@@ -37,16 +41,11 @@ data Bind
   deriving stock (Generic, Eq, Show)
   deriving anyclass (Hashable)
 
-data Scope = MkScope
+newtype Scope = MkScope { identity :: Natural }
-  { name :: Name
-  , identity :: Natural
-  }
   deriving stock (Show, Generic, Eq, Ord)
   deriving anyclass (Hashable)
 
-instance Gen Scope where
+type ScopeSet = HashSet Scope
-  gen = MkScope ""
-  gen' s = MkScope (MkName s)
 
 data Formals
   = FormalsFixed (List Name)
@@ -378,12 +377,26 @@ matchThese _ = empty
 
 
 
-type SymTable = HashMap Key Bind
+-- | this hashmap is "curried" since we often want to traverse the
+-- entire set of scopes associated with a given symbol.
+newtype SymTable = MkSymTable
+  { curried :: HashMap Name (HashMap (HashSet Scope) Bind) }
+  deriving (Show, Generic)
 
-type Expand es = (Writer SymTable :> es, GenSym :> es)
+type instance Index SymTable = Name
+type instance IxValue SymTable = HashMap (HashSet Scope) Bind
+instance Ixed SymTable where ix j = #curried . ix j
+instance At SymTable where at j = #curried . at j
 
-runExpand :: Eff (Writer SymTable : GenSym : es) a -> Eff es (a, SymTable)
+instance Semigroup SymTable where
-runExpand = runGenSym . runWriter
+  MkSymTable c1 <> MkSymTable c2 = MkSymTable $ H.unionWith (<>) c1 c2
+
+instance Monoid SymTable where mempty = MkSymTable mempty
+
+type Expand es = (State SymTable :> es, GenSym :> es)
+
+runExpand :: Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
+runExpand = runGenSym . runState mempty
 
 {- |
 >>> :{
@@ -490,20 +503,27 @@ resolvePrim g scopes (PrimLet (MkPrimLet n bs body)) = do
         , foldMapOf (each . _1) envOfVar bs'
         ]
   body' <- traverse (resolve g' scopes') body
+  let n_g = [ MkKey x scopes' | x <- foldMap (:[]) n ]
+  let bs_g = [ MkKey x scopes | x <- bs ^.. each . _1 ]
   pure [S.sx|
-    (let ##{n'} #{bs}
+    (let ##{n_g} #{bs_g}
       ##{body'})
   |]
 
 resolveSymbol
-  :: (Expand es)
+  :: Expand es
   => HashSet Scope -> Name -> Eff es Bind
 resolveSymbol scopes symbol = do
-  let key = MkKey symbol scopes
   bind <- gensymLexical symbol
-  tell $ H.singleton key bind
+  emit $ binding symbol scopes bind
   pure bind
 
+emit :: (Monoid m, State m :> es) => m -> Eff es ()
+emit x = modify (<> x)
+
+binding :: Name -> HashSet Scope -> Bind -> SymTable
+binding sym scopes = MkSymTable . H.singleton sym . H.singleton scopes
+
 envOfVar :: Bind -> Env
 envOfVar = MkEnv . flip H.singleton DenotVar
 
@@ -513,9 +533,58 @@ gensymLexical symbol = do
   pure $ BindLexical {symbol,identity}
 
 lookupSymbol
-  :: Env -> HashSet Scope -> Text -> Maybe (Bind, Denot)
+  :: (State SymTable :> es, Jalmot :> es)
-lookupSymbol g scopes x = g ^?
+  => Env -> HashSet Scope -> Name -> Eff es (Bind, Denot)
-  failing (iix (BindGlobal $ MkName x)) (iix (BindGlobal $ MkName x)) . withIndex
+lookupSymbol g scopes x = do
+  ss <- fmap fold . preuse @SymTable $ ix x
+  case nearest (MkKey x scopes) (H.keys ss) of
+    [] -> err [i|심벌 #{x}는 정의되지 않다|]
+    (_:_:_) -> err [i|심벌 #{x}는 모호하다|]
+    [s] | Just b <- ss ^? ix s
+        , Just d <- g ^? ix b -> pure (b,d)
+        | otherwise -> error "unreachable"
+
+{- | Given a 'Key' and a collection of 'ScopeSet's, filter that
+collection down to the largest subsets of the 'Key'\'s scope set.
+This is our analogue of the lexical scoping rule which chooses the
+"nearest" binding of a variable when shadowing occurs.
+
+  - If no qualifying subsets are found, the name is not in scope.
+  - If one subset is found, we're on the happy path!
+  - If more than one subset is found, we're on the rarest and
+    saddest path: the reference is ambiguous.
+
+* Examples
+
+> (let ((x {A} 123))
+>   (λ (x {A,B})
+>     (let ((y {A,B,C} 456))
+>       x {A,B,C})))
+    
+>>> :seti -XOverloadedLists
+>>> :{
+nearest
+  (MkKey "x" [MkScope 0, MkScope 1, MkScope 2])
+  [ [MkScope 0]
+  , [MkScope 0, MkScope 1] ]
+:}
+-}
+nearest :: (Traversable f, Filterable f) => Key -> f ScopeSet -> List ScopeSet
+nearest (MkKey symbol scopes) =
+  mapMaybe (\x ->
+    if x `HS.isSubsetOf` scopes
+    then Just . Down $ Arg (length x) x
+    else Nothing)
+  -- 나쁨. 안 좋다. 안 좋아하야.
+  >>> Data.Foldable.toList >>> sort
+  >>> foldr (\cases
+    x [] -> [x]
+    x acc@(y:_) -> case x `compare` y of
+      LT -> acc
+      EQ -> x:acc
+      GT -> [x])
+    []
+  >>> fmap (\(Down (Arg _ x)) -> x)
 
 denotToDatum :: Denot -> Datum
 denotToDatum = _