github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 00:33:59 +03:00
Code Issues Projects Releases Wiki Activity

🔥 the duplication between Monotype & Polytype.

Browse Source
This commit is contained in:
Rob Rix 2019-07-18 15:53:30 -04:00
parent 3e7123ff85
commit 2388800416
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 10 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,8 @@
{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, QuantifiedConstraints, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications #-} {-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, QuantifiedConstraints, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators #-}
module Analysis.Typecheck module Analysis.Typecheck
( Monotype (..) ( Monotype (..)
, Meta , Meta
, Polytype (PForAll, PBool, PArr) , Polytype (..)
, Scope
, typecheckingFlowInsensitive , typecheckingFlowInsensitive
, typecheckingAnalysis , typecheckingAnalysis
) where ) where
@ -59,13 +58,7 @@ instance RightModule Monotype where
type Meta = Int type Meta = Int
data Polytype f a newtype Polytype f a = PForAll (Scope () f a)
= PForAll (Scope () f a)
| PUnit
| PBool
| PString
| PArr (f a) (f a)
| PRecord (Map.Map User (f a))
deriving (Foldable, Functor, Generic1, Traversable) deriving (Foldable, Functor, Generic1, Traversable)
deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Polytype f a) deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Polytype f a)
@ -76,11 +69,6 @@ deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Po
instance HFunctor Polytype instance HFunctor Polytype
instance RightModule Polytype where instance RightModule Polytype where
PForAll b >>=* f = PForAll (b >>=* f) PForAll b >>=* f = PForAll (b >>=* f)
PUnit >>=* _ = PUnit
PBool >>=* _ = PBool
PString >>=* _ = PString
PArr a b >>=* f = PArr (a >>= f) (b >>= f)
PRecord m >>=* f = PRecord ((>>= f) <$> m)
forAll :: (Eq a, Carrier sig m, Member Polytype sig) => a -> m a -> m a forAll :: (Eq a, Carrier sig m, Member Polytype sig) => a -> m a -> m a
@ -89,21 +77,17 @@ 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 :: (Eq a, Carrier sig m, Member Polytype sig, Foldable t) => t a -> m a -> m a
forAlls ns body = foldr forAll body ns forAlls ns body = foldr forAll body ns
generalize :: (Carrier sig m, Member Naming sig) => Term Monotype Meta -> m (Term Polytype Gensym) generalize :: (Carrier sig m, Member Naming sig) => Term Monotype Meta -> m (Term (Polytype :+: Monotype) Gensym)
generalize ty = namespace "generalize" $ do generalize ty = namespace "generalize" $ do
Gensym root _ <- Name.fresh Gensym root _ <- Name.fresh
pure (forAlls (map (Gensym root) (IntSet.toList (mvs ty))) (fold root ty)) pure (Gensym root <$> forAlls (IntSet.toList (mvs ty)) (fold ty))
where fold root = \case where fold :: Term Monotype a -> Term (Polytype :+: Monotype) a
Var v -> pure (Gensym root v) fold = \case
Term t -> Term $ case t of Var v -> Var v
Unit -> PUnit Term t -> Term (R (hmap fold t))
Bool -> PBool
String -> PString
Arr a b -> PArr (fold root a) (fold root b)
Record fs -> PRecord (fold root <$> fs)
typecheckingFlowInsensitive :: [File (Term Core.Core Name)] -> (Heap Name (Term Monotype Meta), [File (Either (Loc, String) (Term Polytype Gensym))]) typecheckingFlowInsensitive :: [File (Term Core.Core Name)] -> (Heap Name (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Gensym))])
typecheckingFlowInsensitive typecheckingFlowInsensitive
= run = run
. runFresh . runFresh