From 407a8f0a16fc0b5dc81365831e1c838214d4ce33 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 6 Mar 2024 11:11:09 -0700 Subject: [PATCH] begin gathering begin gathering --- src/Core/Syntax.hs | 26 +++++++++++++++- src/Rlp/AltParse.y | 11 +++++-- src/Rlp/AltSyntax.hs | 23 ++++++++++++-- src/Rlp/HindleyMilner.hs | 66 ++++++++++++++++++++++++++++++++++++---- 4 files changed, 114 insertions(+), 12 deletions(-) diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 8165fc5..5b25db7 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -51,6 +51,7 @@ import Data.String import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as H import Data.Hashable +import Data.Hashable.Lifted import Data.Foldable (traverse_) import Data.Functor import Data.Monoid @@ -58,7 +59,7 @@ import Data.Functor.Classes import Data.Text qualified as T import Data.Char import Data.These -import GHC.Generics (Generic, Generically(..)) +import GHC.Generics (Generic, Generic1, Generically(..)) import Text.Show.Deriving import Data.Eq.Deriving import Data.Kind qualified @@ -756,3 +757,26 @@ makePrisms ''BindingF makePrisms ''Var makePrisms ''ScDef +deriving instance Generic (ExprF b a) +deriving instance Generic1 (ExprF b) +deriving instance Generic1 (AlterF b) +deriving instance Generic1 (BindingF b) +deriving instance Generic (AlterF b a) +deriving instance Generic (BindingF b a) +deriving instance Generic AltCon +deriving instance Generic Lit +deriving instance Generic Rec +deriving instance Generic Type + +instance Hashable Lit +instance Hashable AltCon +instance Hashable Rec +instance Hashable Type +instance (Hashable b, Hashable a) => Hashable (BindingF b a) +instance (Hashable b, Hashable a) => Hashable (AlterF b a) +instance (Hashable b, Hashable a) => Hashable (ExprF b a) + +instance Hashable b => Hashable1 (AlterF b) +instance Hashable b => Hashable1 (BindingF b) +instance Hashable b => Hashable1 (ExprF b) + diff --git a/src/Rlp/AltParse.y b/src/Rlp/AltParse.y index 6a3883c..7499ad1 100644 --- a/src/Rlp/AltParse.y +++ b/src/Rlp/AltParse.y @@ -127,6 +127,7 @@ Expr :: { RlpExpr PsName } : AppE { $1 } | LetE { $1 } | CaseE { $1 } + | Expr1 { $1 } CaseE :: { RlpExpr PsName } : case Expr of CaseAlts { Finr $ CaseEF $2 $4 } @@ -144,9 +145,15 @@ LetE :: { RlpExpr PsName } Binding :: { Binding PsName (RlpExpr PsName) } : Pat '=' Expr { VarB $1 $3 } +Expr1 :: { RlpExpr PsName } + : VarE { $1 } + | litint { $1 ^. to extract + . singular _TokenLitInt + . to (Finl . Core.LitF . Core.IntL) } + AppE :: { RlpExpr PsName } - : AppE VarE { Finl $ Core.AppF $1 $2 } - | VarE { $1 } + : AppE Expr1 { Finl $ Core.AppF $1 $2 } + | Expr1 { $1 } VarE :: { RlpExpr PsName } : Var { Finl $ Core.VarF $1 } diff --git a/src/Rlp/AltSyntax.hs b/src/Rlp/AltSyntax.hs index 946c2cb..cb2a39b 100644 --- a/src/Rlp/AltSyntax.hs +++ b/src/Rlp/AltSyntax.hs @@ -22,11 +22,13 @@ import Data.Functor.Sum import Control.Comonad.Cofree import Data.Fix import Data.Function (fix) -import GHC.Generics (Generic(..)) +import GHC.Generics (Generic, Generic1) import Data.Hashable +import Data.Hashable.Lifted import Control.Lens import Text.Show.Deriving +import Data.Eq.Deriving import Data.Text qualified as T import Data.Pretty import Misc.Lift1 @@ -49,7 +51,7 @@ data Decl b a = FunD b [Pat b] a deriving Show data DataCon b = DataCon b [Type b] - deriving Show + deriving (Show, Generic) data Type b = VarT b | ConT b @@ -70,13 +72,16 @@ data ExprF b a = InfixEF b a a | LetEF Core.Rec [Binding b a] a | CaseEF a [Alter b a] deriving (Functor, Foldable, Traversable) + deriving (Eq, Generic, Generic1) data Alter b a = Alter (Pat b) a deriving (Show, Functor, Foldable, Traversable) + deriving (Eq, Generic, Generic1) data Binding b a = FunB b [Pat b] a | VarB (Pat b) a deriving (Show, Functor, Foldable, Traversable) + deriving (Eq, Generic, Generic1) -- type Expr b = Cofree (ExprF b) @@ -87,7 +92,7 @@ type RlpExpr b = Fix (RlpExprF b) data Pat b = VarP b | ConP b | AppP (Pat b) (Pat b) - deriving Show + deriving (Eq, Show, Generic) deriveShow1 ''Alter deriveShow1 ''Binding @@ -189,3 +194,15 @@ instance Lift b => Lift1 (ExprF b) where liftCon2 'CaseEF (lf e) as' where as' = liftLift (liftLift lf) as +deriveEq1 ''Binding +deriveEq1 ''Alter +deriveEq1 ''ExprF + +instance (Hashable b) => Hashable (Pat b) +instance (Hashable b, Hashable a) => Hashable (Binding b a) +instance (Hashable b, Hashable a) => Hashable (Alter b a) +instance (Hashable b, Hashable a) => Hashable (ExprF b a) +instance (Hashable b) => Hashable1 (Alter b) +instance (Hashable b) => Hashable1 (Binding b) +instance (Hashable b) => Hashable1 (ExprF b) + diff --git a/src/Rlp/HindleyMilner.hs b/src/Rlp/HindleyMilner.hs index 92ae8a5..05f9677 100644 --- a/src/Rlp/HindleyMilner.hs +++ b/src/Rlp/HindleyMilner.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} module Rlp.HindleyMilner ( infer , check @@ -8,6 +11,7 @@ module Rlp.HindleyMilner -------------------------------------------------------------------------------- import Control.Lens hiding (Context', Context, (:<)) import Control.Monad.Errorful +import Control.Monad.State import Data.Text qualified as T import Data.Pretty import Text.Printf @@ -23,7 +27,9 @@ import Data.Fix import Control.Comonad.Cofree import Compiler.RlpcError -import Rlp.AltSyntax +import Rlp.AltSyntax as Rlp +import Core.Syntax qualified as Core +import Core.Syntax (ExprF(..)) -------------------------------------------------------------------------------- -- | Type error enum. @@ -70,19 +76,67 @@ instance Hashable Constraint type Constraints = HashSet Constraint -data PartialJudgement = - PartialJudgement Constraints Context' - +data PartialJudgement = PartialJudgement Constraints Context' deriving (Generic, Show) deriving (Semigroup, Monoid) via Generically PartialJudgement +constraints :: Lens' PartialJudgement Constraints +constraints = lens sa sbt where + sa (PartialJudgement cs _) = cs + sbt (PartialJudgement _ g) cs' = PartialJudgement cs' g + +assumptions :: Lens' PartialJudgement Context' +assumptions = lens sa sbt where + sa (PartialJudgement _ g) = g + sbt (PartialJudgement cs _) g' = PartialJudgement cs g' + fixCofree :: (Functor f, Functor g) => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b) fixCofree = iso sa bt where sa = foldFix (() :<) bt (_ :< as) = Fix $ bt <$> as -gather :: Context' -> RlpExpr PsName -> HMError (Type PsName, Constraints) -gather = undefined +data TypeState t m = TypeState + { _tsUnique :: Int + , _tsMemo :: HashMap t m + } + deriving Show + +makeLenses ''TypeState + +type TC t = State (TypeState t (Type PsName, PartialJudgement)) + (Type PsName, PartialJudgement) + +freshTv :: State (TypeState t m) (Type PsName) +freshTv = do + n <- use tsUnique + tsUnique %= succ + pure . VarT $ "$a" <> T.pack (show n) + +memoisedTC :: (Hashable a) => (a -> TC a) -> a -> TC a +memoisedTC k a = do + m <- use tsMemo + r <- k a + tsMemo . at a %= \case + Just c -> Just c + Nothing -> Just r + pure r + +gather :: Fix (RlpExprF PsName) -> TC (Fix (RlpExprF PsName)) + +gather (Fix (InL (Core.LitF (Core.IntL _)))) = + pure (ConT "Int#", mempty) + +gather (Fix (InL (Core.VarF n))) = do + tv <- freshTv + let j = mempty & assumptions .~ H.singleton n tv + pure (tv, j) + +gather (Fix (InL (Core.AppF f x))) = do + tv <- freshTv + (tf,j) <- memoisedTC gather f + (tx,j') <- memoisedTC gather x + let j'' = mempty & constraints .~ S.singleton (Equality tf $ tx :-> tv) + pure (tv, j <> j' <> j'')