github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Compute the free metavariables in an ABT.

Browse Source
This commit is contained in:
Rob Rix 2017-09-11 09:35:51 -04:00
parent 65c418359a
commit d064e3f1e5
1 changed files with 10 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/Data/Functor/Binding.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving #-}
module Data.Functor.Binding
( Metavar(..)
-- Abstract binding trees
, BindingF(..)
, bindings
, freeMetavariables
-- Environments
, Env(..)
, envExtend
@ -11,8 +12,11 @@ module Data.Functor.Binding
) where
import Data.Aeson (KeyValue(..), ToJSON(..), object, pairs)
import Data.Foldable (fold)
import Data.Functor.Classes
import Data.Functor.Foldable hiding (fold)
import Data.JSON.Fields
import qualified Data.Set as Set
import Data.Text.Prettyprint.Doc
newtype Metavar = Metavar Int
@ -28,6 +32,11 @@ bindings :: BindingF f recur -> [(Metavar, recur)]
bindings (Let vars _) = vars
bindings _ = []
freeMetavariables :: (Foldable syntax, Functor syntax, Recursive t, Base t ~ BindingF syntax) => t -> Set.Set Metavar
freeMetavariables = cata $ \ diff -> case diff of
Let bindings body -> foldMap snd bindings <> foldr Set.delete (fold body) (fst <$> bindings)
Var v -> Set.singleton v
newtype Env a = Env { unEnv :: [(Metavar, a)] }
deriving (Eq, Foldable, Functor, Monoid, Ord, Show, Traversable)