diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index 8789791..6d6fd02 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/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 - { name :: Name - , identity :: Natural - } +newtype Scope = MkScope { identity :: Natural } deriving stock (Show, Generic, Eq, Ord) deriving anyclass (Hashable) -instance Gen Scope where - gen = MkScope "" - gen' s = MkScope (MkName s) +type ScopeSet = HashSet Scope 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) -runExpand = runGenSym . runWriter +instance Semigroup SymTable where + 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) -lookupSymbol g scopes x = g ^? - failing (iix (BindGlobal $ MkName x)) (iix (BindGlobal $ MkName x)) . withIndex + :: (State SymTable :> es, Jalmot :> es) + => Env -> HashSet Scope -> Name -> Eff es (Bind, Denot) +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 = _