msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

begin gathering

Browse Source 
begin gathering
This commit is contained in:
crumbtoo
2024-03-06 11:11:09 -07:00
parent 67c88df53a
commit 407a8f0a16
4 changed files with 114 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
src/Core/Syntax.hs
View File

@@ -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)

11
src/Rlp/AltParse.y
View File

@@ -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 }

23
src/Rlp/AltSyntax.hs
View File

@@ -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)

66
src/Rlp/HindleyMilner.hs
View File

@@ -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'')