github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Generalize in pure code.

Browse Source
This commit is contained in:
Rob Rix 2019-07-18 16:10:16 -04:00
parent a83cdffa73
commit 5dbf727985
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 4 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
semantic-core/src/Analysis/Typecheck.hs
View File

@ -27,6 +27,7 @@ import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (nonEmpty)
import Data.Loc
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Name as Name
import Data.Scope
import qualified Data.Set as Set
@ -77,10 +78,8 @@ forAll n body = send (PForAll (Data.Scope.bind1 n body))
forAlls :: (Eq a, Carrier sig m, Member Polytype sig, Foldable t) => t a -> m a -> m a
forAlls ns body = foldr forAll body ns
generalize :: (Carrier sig m, Member Naming sig) => Term Monotype Meta -> m (Term (Polytype :+: Monotype) Gensym)
generalize ty = namespace "generalize" $ do
Gensym root _ <- Name.fresh
pure (Gensym root <$> forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty))
generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Gensym
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) Gensym))])
@ -89,7 +88,7 @@ typecheckingFlowInsensitive
. runFresh
. runNaming
. runHeap (Gen (Gensym (Nil :> "root") 0))
. (>>= traverse (traverse (traverse generalize)))
. fmap (fmap (fmap (fmap generalize)))
. traverse runFile
runFile :: ( Carrier sig m