bottom up

README.org

@@ -89,7 +89,9 @@ For the time being, I just disabled the memoisation. This is very, very bad.
 
 ** TODO update architecture diagram                                       :docs:
 
-** TODO pattern support; everywhere                                    :feature:
+** TODO pattern support; everywhere [0%]                                :feature:
+   - [ ] in the type-checker
+   - [ ] in the desugarer
 
 ** TODO G-machine visualiser                                              :docs:
 

rlp.cabal

@@ -16,6 +16,7 @@ tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
+    ghc-options: -fdefer-typed-holes
 
 library
     import:           warnings

src/Rlp/AltSyntax.hs

@@ -4,6 +4,7 @@ module Rlp.AltSyntax
     -- * AST
       Program(..), Decl(..), ExprF(..), Pat(..)
     , RlpExprF, RlpExpr, Binding(..), Alter(..)
+    , RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
     , DataCon(..), Type(..), Kind
     , pattern IntT, pattern TypeT
     , Core.Rec(..)
@@ -54,6 +55,11 @@ import Compiler.Types
 import Core.Syntax              qualified as Core
 --------------------------------------------------------------------------------
 
+type RlpExpr' = RlpExpr PsName
+type RlpExprF' = RlpExprF PsName
+type AnnotatedRlpExpr' = Cofree (RlpExprF PsName)
+type Type' = Type PsName
+
 type AnnotatedRlpExpr b = Cofree (RlpExprF b)
 
 type TypedRlpExpr b = Cofree (RlpExprF b) (Type b)

src/Rlp/HindleyMilner.hs

@@ -1,12 +1,7 @@
-{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedLists #-}
 module Rlp.HindleyMilner
     ( typeCheckRlpProgR
-    , annotate
     , TypeError(..)
-    , runHM'
-    , liftHM
-    , HM
     , renamePrettily
     )
     where
@@ -49,6 +44,8 @@ import Data.Fix                 hiding (cata, para)
 import Control.Comonad.Cofree
 import Control.Comonad
 
+import Effectful
+
 import Compiler.RLPC
 import Compiler.RlpcError
 import Rlp.AltSyntax            as Rlp
@@ -57,439 +54,181 @@ import Core.Syntax              (ExprF(..), Lit(..))
 import Rlp.HindleyMilner.Types
 --------------------------------------------------------------------------------
 
-fixCofree :: (Functor f, Functor g)
+-- | Annotate a structure with the result of a catamorphism at each level.
-          => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b)
+--
-fixCofree = iso sa bt where
+--   Pretentious etymology: 'dendr-' means 'tree'
-    sa = foldFix (() :<)
-    bt (_ :< as) = Fix $ bt <$> as
 
-lookupVar :: PsName -> Context -> HM (Type PsName)
+dendroscribe :: (Functor f, Base t ~ f, Recursive t)
-lookupVar n g = case g ^. contextVars . at n of
+           => (f (Cofree f a) -> a) -> t -> Cofree f a
-    Just t -> pure t
+dendroscribe c (project -> f) = c f' :< f'
-    Nothing -> addFatal $ TyErrUntypedVariable n
+    where f' = dendroscribe c <$> f
 
-gather :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
+dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
-gather e = use hmMemo >>= (H.lookup e >>> maybe memoise pure)
+            => (f (Cofree f a) -> m a) -> t -> m (Cofree f a)
+dendroscribeM c (project -> f) = do
+    as <- dendroscribeM c `traverse` f
+    a <- c as
+    pure (a :< as)
+
+--------------------------------------------------------------------------------
+
+assume :: Name -> Type' -> Judgement
+assume n t = mempty & assumptions .~ H.singleton n [t]
+
+equal :: Type' -> Type' -> Judgement
+equal a b = mempty & constraints .~ [Equality a b]
+
+elim :: Name -> Type' -> Judgement -> Judgement
+elim n t j = j & assumptions %~ H.delete n
+               & constraints <>~ cs
     where
-        memoise = do
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
-            r <- gather' e
+            [Equality t t']
-            hmMemo <>= H.singleton e r
-            pure r
 
-gather' :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
+elimGenerally :: Name -> Type' -> Judgement -> Judgement
-gather' = \case
+elimGenerally n t j = j & assumptions %~ H.delete n
-    Finl (LitF (IntL _)) -> pure (IntT, mempty)
+                        & constraints <>~ cs
+    where
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
+            [ImplicitInstance mempty t' t]
 
-    Finl (VarF n) -> do
+monomorphise :: Type' -> Judgement -> Judgement
-        t <- freshTv
+monomorphise n = constraints . each . _ImplicitInstance . _1 %~ S.insert n
-        let j = mempty & assumptions .~ H.singleton n [t]
-        pure (t,j)
 
-    Finl (AppF f x) -> do
+withoutPatterns :: [Binding b a] -> [(b, a)]
-        tfx <- freshTv
+withoutPatterns bs = bs ^.. each . singular _VarB
-        (tf,jf) <- gather f
+                          & each . _1 %~ view (singular _VarP)
-        (tx,jx) <- gather x
-        let jtfx = mempty & constraints .~ [Equality tf (tx :-> tfx)]
-        pure (tfx, jf <> jx <> jtfx)
 
-    Finl (LamF bs e) -> do
+--------------------------------------------------------------------------------
-        tbs <- for bs (const freshTv)
-        (te,je) <- gather e
-        cs <- bs `zip` tbs
-            & concatMapM (uncurry $ elimAssumptions (je ^. assumptions))
-        let as = foldr H.delete (je ^. assumptions) bs
-            j = mempty & constraints .~ (je ^. constraints <> cs)
-                       & assumptions .~ as
-            t = foldr (:->) te tbs
-        pure (t,j)
 
-    Finr (LetEF NonRec bs e) -> do
+gather :: (Unique :> es)
-        let ks = bs ^.. each . singular _VarB . _1 . singular _VarP
+       => RlpExprF' (Type', Judgement) -> Eff es (Type', Judgement)
-        (txs,jxs) <- unzip <$> generaliseGatherBinds bs
+gather (InL (LitF (IntL _))) = pure (IntT, mempty)
-        (te,je) <- gather e
-        (cs,m) <- fmap fold . for (ks `zip` txs) $ \ (k,t) ->
-            elimAssumptionsMap (je ^. assumptions) k t
-        let jxcs = jxs ^. each . constraints
-                 & each . constraintTypes %~ substMap m
-            as = foldr H.delete (je ^. assumptions) ks
-            j = mempty & constraints .~ je ^. constraints <> jxcs <> cs
-                       & assumptions .~ foldOf (each . assumptions) jxs <> as
-        pure (te, j)
 
-    Finr (LetEF Rec bs e) -> do
+gather (InL (VarF n)) = do
-        let ks = bs ^.. each . singular _VarB . _1 . singular _VarP
+    t <- freshTv
-        (txs,txs',jxs) <- unzip3 <$> gatherBinds bs
+    pure (t, assume n t)
-        let jxsa = foldOf (each . assumptions) jxs
-        jxcs <- elimWithBinds (ks `zip` txs) jxsa
-        (te,je) <- gather e
-        -- ... why don't we need the map?
-        (cs,_) <- fmap fold . for (ks `zip` txs') $ \ (k,t) ->
-            elimAssumptionsMap (je ^. assumptions) k t
-        let as = deleteKeys ks (je ^. assumptions <> jxsa)
-            j = mempty & constraints .~ je ^. constraints <> jxcs <> cs
-                       & assumptions .~ as
-        pure (te,j)
 
-deleteKeys :: (Eq k, Hashable k) => [k] -> HashMap k v -> HashMap k v
+gather (InL (AppF (tf,jf) (tx,jx))) = do
-deleteKeys ks h = foldr H.delete h ks
+    tfx <- freshTv
+    pure (tfx, jf <> jx <> equal tf (tx :-> tfx))
 
-gatherBinds :: [Binding PsName (RlpExpr PsName)]
+gather (InL (LamF xs (te,je))) = do
-            -> HM [( Type PsName -- inferred type
+    bs <- for xs (\x -> (x,) <$> freshTv)
-                   , Type PsName -- generalised type
+    let j = je & forBinds elim bs
-                   , PartialJudgement )]
+               & forBinds (const monomorphise) bs
-gatherBinds bs = for bs $ \ (VarB (VarP k) x) -> do
+        t = foldr (:->) te (bs ^.. each . _2)
-    ((tx,jx),frees) <- listenFreshTvNames $ gather x
+    pure (t, j)
-    let tx' = generalise frees tx
-    pure (tx,tx',jx)
-
-generaliseGatherBinds :: [Binding PsName (RlpExpr PsName)]
-                      -> HM [(Type PsName, PartialJudgement)]
-generaliseGatherBinds = traverse \b ->
-    b ^. singular _VarB . _2 & generaliseGather
-
-generaliseGather :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
-generaliseGather e = do
-    (a,frees) <- listenFreshTvNames $ gather e
-    pure $ a & _1 %~ generalise frees
-
-generalise :: [PsName] -> Type PsName -> Type PsName
-generalise freeTvs t = foldr ForallT t freeTvs
-
-generaliseG :: Context -> Type PsName -> Type PsName
-generaliseG g t = ifoldr (\n _ s -> ForallT n s) t vs where
-    vs = H.difference (freeVariables t ^. hashMap)
-                      (g ^. contextTyVars)
-
-instantiate :: Type PsName -> HM (Type PsName)
-instantiate (ForallT x m) = do
-    tv <- freshTv
-    subst x tv <$> instantiate m
-instantiate x = pure x
-
-instantiateMap :: Type PsName -> HM (Type PsName, HashMap PsName (Type PsName))
-instantiateMap (ForallT x m) = do
-    tv <- freshTv
-    instantiateMap m & mapped . _2 %~ H.insert x tv
-                     & mapped . _1 %~ subst x tv
-instantiateMap t = pure (t, mempty)
-
-saturated :: Type PsName -> HM [Type PsName]
-saturated (ConT con `AppT` as) = do
-    mk <- view $ contextTyCons . at con
-    case mk of
-      Nothing -> addFatal $ TyErrUntypedVariable con
-      Just k | lengthOf arrowStops k - 1 == lengthOf applicants1 as
-             -> pure (as ^.. applicants1)
-             | otherwise
-             -> undefined
-
-unify :: [Constraint] -> HM [(PsName, Type PsName)]
-
-unify [] = pure mempty
-
-unify (Equality (sx :-> sy) (tx :-> ty) : cs) =
-    unify $ Equality sx tx : Equality sy ty : cs
-
-unify (Equality a@(ConT ca `AppT` as) b@(ConT cb `AppT` bs) : cs)
-  | ca == cb = do
-    cs' <- liftA2 (zipWith Equality) (saturated a) (saturated b)
-    unify $ cs' ++ cs
-
--- elim
-unify (Equality (ConT s) (ConT t) : cs) | s == t = unify cs
-unify (Equality (VarT s) (VarT t) : cs) | s == t = unify cs
-
-unify (Equality (VarT s) t : cs)
-    | occurs s t = addFatal $ TyErrRecursiveType s t
-    | otherwise  = unify cs' <&> ((s,t):)
   where
-    cs' = cs & each . constraintTypes %~ subst s t
+    forBinds :: (PsName -> Type' -> Judgement -> Judgement)
+             -> [(PsName, Type')] -> Judgement -> Judgement
+    forBinds f bs j = foldr (uncurry f) j bs
 
--- swap
+    elimBind (x,tx) j1 = elim x tx j1
-unify (Equality s (VarT t) : cs) = unify (Equality (VarT t) s : cs)
 
--- failure!
+gather (InR (LetEF NonRec (withoutPatterns -> bs) (te,je))) = do
-unify (Equality s t : _) = addFatal $ TyErrCouldNotUnify s t
+    let j = foldr elimBind je bs
-
+    pure (te, j)
-annotate :: RlpExpr PsName
-         -> HM (Cofree (RlpExprF PsName) (Type PsName, PartialJudgement))
-annotate = sequenceA . fixtend (gather . wrapFix)
-
-assocs :: IndexedTraversal k [(k,v)] [(k,v')] v v'
-assocs f []         = pure []
-assocs f ((k,v):xs) = (\v' xs' -> (k,v') : xs')
-                  <$> indexed f k v <*> assocs f xs
-
--- | @elimAssumptions as b tb@ eliminates each assumption in @as@ involving @b@
--- by translating the assumptions into constraints equating @b@'s assumed type
--- with @tb@
-
-elimAssumptions :: Assumptions -> PsName -> Type PsName -> HM [Constraint]
-elimAssumptions as b tb =
-    as ^. at b . non' _Empty & traverseOf each k
-  where k t = Equality tb <$> instantiate t
-
-elimAssumptions' :: Assumptions -> PsName -> Type PsName -> HM [Constraint]
-elimAssumptions' as b tb =
-    as ^. at b . non' _Empty & traverseOf each k
-  where k t = Equality <$> instantiate tb <*> instantiate t
-
-elimAssumptionsMap :: Assumptions -> PsName -> Type PsName
-                   -> HM ([Constraint], HashMap PsName (Type PsName))
-elimAssumptionsMap as b tb =
-    runWriterT $ as ^. at b . non' _Empty & traverseOf each k
   where
-    k t = do
+    elimBind (x,(tx,jx)) j1 = elimGenerally x tx (jx <> j1)
-        (tb',w) <- lift $ instantiateMap tb
-        (t',w') <- lift $ instantiateMap t
-        writer (Equality tb' t', w <> w')
 
-substMap :: HashMap PsName (Type PsName) -> Type PsName -> Type PsName
+gather (InR (LetEF Rec (withoutPatterns -> bs) (te,je))) = do
-substMap m t = ifoldr subst t m
+    let j = foldOf (each . _2 . _2) bs
-
+    let j' = foldr elimRecBind j bs
-elimAssumptionsG :: Context -> Assumptions -> HM [Constraint]
+    pure (te, j' <> foldr elimBind je bs)
-elimAssumptionsG g as
-    = g ^. contextVars
-    & itraverse (elimAssumptions' as)
-    & fmap (H.elems >>> concat)
-
-finalJudgement :: Cofree (RlpExprF PsName) (Type PsName, PartialJudgement)
-               -> PartialJudgement
-finalJudgement = foldOf (folded . _2)
-
-infer :: RlpExpr PsName -> HM (Cofree (RlpExprF PsName) (Type PsName))
-infer e = do
-    g0 <- ask
-    e' <- annotate e
-    let (cs,as) = finalJudgement e' ^. lensProduct constraints assumptions
-    cs' <- (<>cs) <$> elimAssumptionsG g0 as
-    -- checkUndefinedVariables e'
-    sub <- solve cs'
-    pure $ e' & fmap (sub . view _1)
-              & _extract %~ generaliseG g0
   where
-    -- intuitively, we'd return mgu(s,t) but the union is left-biased making `s`
+    elimRecBind (x,(tx,_)) j = elim x tx j
-    -- the user-specified type: prioritise her.
+    elimBind (x,(tx,_)) j = elimGenerally x tx j
-    unifyTypes _ s t = unify [Equality s t] $> s
 
-solve :: [Constraint] -> HM (Type PsName -> Type PsName)
+unify :: (Unique :> es)
-solve cs = do
+      => [Constraint] -> ErrorfulT TypeError (Eff es) Subst
-    g <- unify cs
+unify [] = pure id
-    pure $ \t -> ifoldrOf (reversed . assocs) subst t g
+unify (c:cs) = case c of
 
-checkUndefinedVariables
+    Equality (ConT a) (ConT b)
-    :: Cofree (RlpExprF PsName) (Type PsName, PartialJudgement)
+        | a == b
-    -> HM ()
+        -> unify cs
-checkUndefinedVariables ((_,j) :< es)
-    = case j ^. assumptions of
-        [] -> checkUndefinedVariables `traverse_` es
-        as -> doErrs *> checkUndefinedVariables `traverse_` es
-          where doErrs = ifor as \n _ -> addWound $ TyErrUntypedVariable n
 
-infer1 :: RlpExpr PsName -> HM (Type PsName)
+    Equality (VarT a) (VarT b)
-infer1 = fmap extract . infer
+        | a == b
+        -> unify cs
 
-occurs :: PsName -> Type PsName -> Bool
+    Equality (VarT a) t
-occurs n = cata \case
+        | a `occurs` t
-    VarTF m | n == m -> True
+        -> error "recursive type"
-    t                -> or t
+        | otherwise
+        -> unify (subst a t <$> cs) <&> (. subst a t)
 
-subst :: PsName -> Type PsName -> Type PsName -> Type PsName
+    Equality t (VarT a)
-subst n t' = para \case
+        -> unify (Equality (VarT a) t : cs)
-    VarTF m | n == m -> t'
-    -- shadowing
-    ForallTF x (pre,post) | x == n    -> ForallT x pre
-    t -> embed $ t <&> view _2
 
-prettyHM :: (Out a)
+    Equality (s :-> t) (s' :-> t')
-         => Either [TypeError] (a, [Constraint])
+        -> unify (Equality s s' : Equality t t' : cs)
-         -> Either [TypeError] (String, [String])
-prettyHM = over (mapped . _1) rout
-         . over (mapped . _2 . each) rout
 
-fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b
+    ImplicitInstance m s t
-fixtend c (Fix f) = c f :< fmap (fixtend c) f
+        | null $ (freeTvs t `S.difference` freeTvs m)
+                    `S.intersection` activeTvs cs
+        -> unify $ ExplicitInstance s (generalise (freeTvs m) t) : cs
 
-buildInitialContext :: Program PsName a -> Context
+    ExplicitInstance s t -> do
-buildInitialContext = foldMapOf (programDecls . each) \case
+        t' <- lift $ instantiate t
-    TySigD n t    -> contextOfTySig n t
+        unify $ Equality s t' : cs
-    DataD n as cs -> contextOfData n as cs
-    _             -> mempty
 
-contextOfTySig :: PsName -> Type PsName -> Context
+    Equality a b
-contextOfTySig = const $ const mempty
+        -> addFatal $ TyErrCouldNotUnify a b
 
-contextOfData :: PsName -> [PsName] -> [DataCon PsName] -> Context
+    _ -> error "explode (typecheckr explsiong)"
-contextOfData n as cs = kindCtx <> consCtx where
-    kindCtx = mempty & contextTyCons . at n ?~ kind
-        where kind = foldr (\_ t -> TypeT :-> t) TypeT as
 
-    consCtx = foldMap contextOfCon cs
+activeTvs :: [Constraint] -> HashSet Name
+activeTvs = foldMap \case
+    Equality s t           -> freeTvs s <> freeTvs t
+    ImplicitInstance m s t -> freeTvs s <> (freeTvs m `S.intersection` freeTvs t)
+    ExplicitInstance s t   -> freeTvs s <> freeTvs t
 
-    contextOfCon (DataCon c as) =
+instantiate :: (Unique :> es) => Scheme -> Eff es Type'
-        mempty & contextVars . at c ?~ ty
+instantiate (ForallT x t) = do
-      where ty = foralls $ foldr (:->) base as 
+    x' <- freshTv
+    subst x x' <$> instantiate t
+instantiate t = pure t
 
-    base = foldl (\f x -> AppT f (VarT x)) (ConT n) as
+generalise :: HashSet Name -> Type' -> Scheme
+generalise m t = foldr ForallT t as
+    where as = S.toList $ freeTvs t `S.difference` m
 
-    foralls t = foldr ForallT t as
+occurs :: (HasTypes a) => Name -> a -> Bool
+occurs x t = x `elem` freeTvs t
 
-typeCheckRlpProgR :: (Monad m)
+--------------------------------------------------------------------------------
-                  => Program PsName (RlpExpr PsName)
-                  -> RLPCT m (Program PsName
-                      (TypedRlpExpr PsName))
-typeCheckRlpProgR p = liftHM g (inferProg p)
-  where
-    g = buildInitialContext p
 
-inferProg :: Program PsName (RlpExpr PsName)
+annotate :: (Unique :> es)
-          -> HM (Program PsName (TypedRlpExpr PsName))
+         => RlpExpr' -> Eff es (Cofree RlpExprF' (Type', Judgement))
-inferProg p = do
+annotate = dendroscribeM (gather . fmap extract)
-    g0 <- ask
-    traceM $ "g0 : " <> show g0
-    -- we only wipe the memo here as a temporary solution to the memo shadowing
-    -- problem
-    -- p' <- (thenWipeMemo . annotate) `traverse` etaExpandAll p
-    (p',csroot) <- annotateProg (etaExpandAll p)
-    let (cs,as) = foldMap finalJudgement p' ^. lensProduct constraints assumptions
-    cs' <- (\a -> cs <> csroot <> a) <$> elimAssumptionsG g0 as
-    sub <- solve cs'
-    pure $ p' & programDecls . traversed . _FunD . _3
-                %~ ((_extract %~ generaliseG g0) . fmap (sub . view _1))
-  where
-    etaExpandAll = programDecls . each %~ etaExpand
-    thenWipeMemo a = (hmMemo .= mempty) *> a
 
-annotateProg :: Program PsName (RlpExpr PsName)
+orderConstraints :: [Constraint] -> [Constraint]
-             -> HM ( Program PsName
+orderConstraints cs = a <> b
-                      (Cofree (RlpExprF PsName) (Type PsName, PartialJudgement))
+    where (a,b) = partition (isn't _ImplicitInstance) cs
-                   , [Constraint] )
-annotateProg p = do
-    let bs = funsToSimpleBinds (p ^. programDecls)
-        (ks,xs) = unzip bs
-    xs' <- annotate `traverse` xs
-    let jxs = foldOf (each . _extract . _2) xs'
-        txs = xs' ^.. each . _extract . _1
-    cs <- elimWithBinds (ks `zip` txs) (jxs ^. assumptions)
-    -- let p' = annotateDecls (ks `zip` xs') p
-    -- we only wipe the memo here as a temporary solution to the memo shadowing
-    -- problem
-    p' <- (thenWipeMemo . annotate) `traverse` p
-    p'' <- forOf (traversed . traversed . _2) p' \ j -> do
-        c <- elimWithBinds (ks `zip` txs) (j ^. assumptions)
-        pure $ j & constraints <>~ c
-                 & assumptions %~ deleteKeys ks
-    -- TODO: any remaining assumptions should be errors at this point
-    pure (p'',cs)
-  where
-    thenWipeMemo a = (hmMemo .= mempty) *> a
 
--- this sucks! FunDs should probably be stored as a hashmap in Program...
+finalJudgement :: Cofree RlpExprF' (Type', Judgement) -> Judgement
-annotateDecls :: [( PsName
+finalJudgement = snd . extract
-                  , Cofree (RlpExprF PsName) (Type PsName, PartialJudgement) )]
-              -> Program PsName a
-              -> Program PsName
-                  (Cofree (RlpExprF PsName) (Type PsName, PartialJudgement))
-annotateDecls bs = programDecls . traversed . _FunD %~ \case
-    (n,_,_)
-        | Just e <- lookup n bs
-        -> (n,[],e)
 
-gatherBinds' :: [(PsName, RlpExpr PsName)]
+solveTree :: (Unique :> es)
-             -> HM [(Type PsName, Type PsName, PartialJudgement)]
+         => Cofree RlpExprF' (Type', Judgement)
-gatherBinds' = gatherBinds . fmap (uncurry simpleBind)
+         -> ErrorfulT TypeError (Eff es) (Cofree RlpExprF' Type')
+solveTree e = do
+    sub <- unify (orderConstraints $ finalJudgement e ^. constraints . reversed)
+    pure $ sub . view _1 <$> e
 
-elimWithBinds :: [(PsName, Type PsName)]
+typeCheckRlpProgR :: Monad m
-              -> Assumptions
+                  => Program PsName RlpExpr'
-              -> HM [Constraint]
+                  -> RLPCT m (Program PsName (Cofree RlpExprF' Type'))
-elimWithBinds bs jxsa = fmap concat . for bs $ \ (k,t) ->
+typeCheckRlpProgR = undefined
-    elimAssumptions' jxsa k t
 
-simpleBind :: b -> a -> Binding b a
+gatherProg :: (Unique :> es)
-simpleBind k v = VarB (VarP k) v
+           => Program PsName RlpExpr'
+           -> Eff es a
+gatherProg = undefined
 
-funsToSimpleBinds :: [Decl PsName (RlpExpr PsName)]
+--------------------------------------------------------------------------------
-                  -> [(PsName, RlpExpr PsName)]
-funsToSimpleBinds = mapMaybe \case
-    d@(FunD n _ _) -> Just (n, etaExpand' d)
-    _              -> Nothing
 
-simpleBindsToFuns :: [(PsName, TypedRlpExpr PsName)]
+renamePrettily = undefined
-                  -> [Decl PsName (TypedRlpExpr PsName)]
-simpleBindsToFuns = fmap \ (n,e) -> FunD n [] e
-
-wrapLetrec :: [(PsName, RlpExpr PsName)] -> RlpExpr PsName
-wrapLetrec ds = ds & each . _1 %~ VarP
-                   & each %~ review _VarB
-                   & \bs -> Finr $ LetEF Rec bs (Finl . LitF . IntL $ 123)
-
-unwrapLetrec :: TypedRlpExpr PsName -> [(PsName, TypedRlpExpr PsName)]
-unwrapLetrec (_ :< InR (LetEF _ bs _))
-    = bs ^.. each . _VarB
-    & each . _1 %~ view (singular _VarP)
-
-etaExpand' :: Decl b (RlpExpr b) -> RlpExpr b
-etaExpand' (FunD _ [] e) = e
-etaExpand' (FunD _ as e) = Finl . LamF as' $ e
-    where as' = as ^.. each . singular _VarP
-
-etaExpand :: Decl b (RlpExpr b) -> Decl b (RlpExpr b)
-etaExpand (FunD n [] e) = FunD n [] e
-etaExpand (FunD n as e)
-    | Right as' <- allVarP as
-    = FunD n [] (Finl . LamF as' $ e)
-  where
-    allVarP = traverse (matching _VarP)
-etaExpand a = a
-
-liftHM :: (Monad m) => Context -> HM a -> RLPCT m a
-liftHM g = liftEither . runHM g
-
-freeVariables :: Type PsName -> HashSet PsName
-freeVariables = cata \case
-    VarTF x -> S.singleton x
-    ForallTF x m -> S.delete x m
-    vs -> fold vs
-
-boundVariables :: Type PsName -> HashSet PsName
-boundVariables = cata \case
-    ForallTF x m -> S.singleton x <> m
-    vs -> fold vs
-
-freeVariablesLTR :: Type PsName -> [PsName]
-freeVariablesLTR = nub . cata \case
-    VarTF x -> [x]
-    ForallTF x m -> m \\ [x]
-    vs -> concat vs
-
-renamePrettily' :: Type PsName -> Type PsName
-renamePrettily' = join renamePrettily
-
--- | for some type, compute a substitution which will rename all free variables
--- for aesthetic purposes
-
-renamePrettily :: Type PsName -> Type PsName -> Type PsName
-renamePrettily root = (`evalState` alphabetNames) . (renameFree <=< renameBound)
-  where
-    renameBound :: Type PsName -> State [PsName] (Type PsName)
-    renameBound = cata \case
-        ForallTF x m -> do
-            n <- getName
-            ForallT n <$> (subst x (VarT n) <$> m)
-        t -> embed <$> sequenceA t
-
-    renameFree :: Type PsName -> State [PsName] (Type PsName)
-    renameFree t = do
-        subs <- forM (freeVariablesLTR root) $ \v -> do
-            n <- getName
-            pure $ Endo (subst v (VarT n))
-        pure . appEndo (fold subs) $ t
-
-    getName :: State [PsName] PsName
-    getName = state (fromJust . uncons)
-
-alphabetNames :: [PsName]
-alphabetNames = alphabet ++ concatMap appendAlphabet alphabetNames
-    where alphabet = [ T.pack [c] | c <- ['a'..'z'] ]
-          appendAlphabet c = [ c <> c' | c' <- alphabet ]
 

src/Rlp/HindleyMilner/Types.hs

@@ -11,77 +11,45 @@ import Data.HashSet             qualified as S
 import GHC.Generics             (Generic(..), Generically(..))
 import Data.Kind                qualified
 import Data.Text                qualified as T
-import Control.Monad.Writer
+import Effectful.State.Static.Local
-import Control.Monad.Accum
+import Effectful.Labeled
-import Control.Monad.Trans.Accum
+import Effectful
-import Control.Monad.Errorful
-import Control.Monad.State
-import Control.Monad.Reader
 import Text.Printf
 import Data.Pretty
 import Data.Function
 
-import Control.Lens             hiding (Context', Context)
+import Control.Lens             hiding (Context', Context, para)
+
+import Data.Functor.Foldable    hiding (fold)
+import Data.Foldable
 
 import Compiler.RlpcError
 import Rlp.AltSyntax
 --------------------------------------------------------------------------------
 
-data Context = Context
+-- | A polymorphic type
-    { _contextVars      :: HashMap PsName (Type PsName)
-    , _contextTyVars    :: HashMap PsName (Type PsName)
-    , _contextTyCons    :: HashMap PsName (Kind PsName)
-    }
-    deriving (Show, Generic)
-    deriving (Semigroup, Monoid)
-        via Generically Context
 
-data Constraint = Equality (Type PsName) (Type PsName)
+type Scheme = Type'
-                | GeneralisedEquality (Type PsName) (Type PsName)
-                deriving (Eq, Generic, Show)
 
-type Assumptions = HashMap PsName [Type PsName]
+type Subst = Type' -> Type'
 
-data PartialJudgement = PartialJudgement
+data Constraint = Equality Type' Type'
-    { _constraints :: [Constraint]
+                | ImplicitInstance (HashSet Type') Type' Type'
-    , _assumptions :: Assumptions
+                | ExplicitInstance Type' Scheme
-    }
+                deriving Show
-    deriving (Generic, Show)
-    deriving (Monoid)
-        via Generically PartialJudgement
 
-instance Semigroup PartialJudgement where
+instance Out Constraint where
-    a <> b = PartialJudgement
+    out (Equality s t) =
-        { _constraints = ((<>) `on` _constraints) a b
+        hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
-        , _assumptions = (H.unionWith (<>) `on` _assumptions) a b
-        }
 
-instance Hashable Constraint
+--------------------------------------------------------------------------------
-
-type Memo = HashMap (RlpExpr PsName) (Type PsName, PartialJudgement)
-
-data HMState = HMState
-    { _hmMemo :: Memo
-    , _hmUniq :: Int
-    }
-    deriving Show
-
-newtype HM a = HM {
-        unHM :: ErrorfulT TypeError
-            (ReaderT Context (State HMState)) a
-    }
-    deriving (Functor, Applicative, Monad)
-    deriving ( MonadReader Context
-             , MonadState HMState
-             , MonadErrorful TypeError
-             )
 
 -- | Type error enum.
 data TypeError
     -- | Two types could not be unified
-    = TyErrCouldNotUnify (Type Name) (Type Name)
+    = TyErrCouldNotUnify Type' Type'
     -- | @x@ could not be unified with @t@ because @x@ occurs in @t@
-    | TyErrRecursiveType Name (Type Name)
+    | TyErrRecursiveType Name Type'
     -- | Untyped, potentially undefined variable
     | TyErrUntypedVariable Name
     | TyErrMissingTypeSig Name
@@ -105,60 +73,100 @@ instance IsRlpcError TypeError where
                               (rout @String t) (rout @String x)
             ]
 
-runHM :: Context -> HM a -> Either [TypeError] a
+--------------------------------------------------------------------------------
-runHM g e = maybe (Left es) Right ma
-    where
-        (ma,es) =  (`evalState` (HMState mempty 0))
-                    . (`runReaderT` g) . runErrorfulT $ unHM e
 
-runHM' :: HM a -> Either [TypeError] a
+type Unique = State Int
-runHM' = runHM mempty
 
-makePrisms ''PartialJudgement
+freshTv :: (Unique :> es) => Eff es (Type PsName)
-makeLenses ''PartialJudgement
+freshTv = do
-makeLenses ''Context
+    n <- get
-makePrisms ''Constraint
+    modify @Int succ
-makePrisms ''TypeError
+    pure (VarT $ tvNameOfInt n)
-makeLenses ''HMState
-
-supplement :: [(PsName, Type PsName)] -> Context -> Context
-supplement bs = contextVars %~ (H.fromList bs <>)
-
-demoContext :: Context
-demoContext = mempty
-    & contextVars .~
-        [ ("+#", IntT :-> IntT :-> IntT)
-        , ("Nil", ForallT "a" $ ConT "List" `AppT` VarT "a")
-        ]
-    & contextTyCons .~
-        [ ("List", TypeT :-> TypeT)
-        ]
-
-constraintTypes :: Traversal' Constraint (Type PsName)
-constraintTypes k (Equality s t) = Equality <$> k s <*> k t
-constraintTypes k (GeneralisedEquality s t) =
-    GeneralisedEquality <$> k s <*> k t
-
-instance Out Constraint where
-    out (Equality s t) =
-        hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
 
 tvNameOfInt :: Int -> PsName
 tvNameOfInt n = "$a" <> T.pack (show n)
 
-freshTv :: HM (Type PsName)
+--------------------------------------------------------------------------------
-freshTv = do
-    n <- use hmUniq
-    hmUniq %= succ
-    pure (VarT $ tvNameOfInt n)
 
-listenFreshTvs :: HM a -> HM (a, [Type PsName])
+-- | A 'Judgement' is a sort of "co-context" used in bottom-up inference. The
-listenFreshTvs hm = listenFreshTvNames hm & mapped . _2 . each %~ VarT
+--   typical algorithms J, W, and siblings pass some context Γ to the inference
+--   algorithm which is used to lookup variables and such. Here in rlpc we
+--   infer a type under zero context; inference returns the assumptions made of
+--   a variable which may be later eliminated and solved.
 
-listenFreshTvNames :: HM a -> HM (a, [PsName])
+data Judgement = Judgement
-listenFreshTvNames hm = do
+    { _constraints :: [Constraint]
-    n <- use hmUniq
+    , _assumptions :: Assumptions
-    a <- hm
+    }
-    n' <- use hmUniq
+    deriving (Show)
-    pure (a, [ tvNameOfInt k | k <- [n .. pred n'] ])
+
+type Assumptions = HashMap PsName [Type PsName]
+
+instance Semigroup Judgement where
+    a <> b = Judgement
+        { _constraints = ((<>) `on` _constraints) a b
+        , _assumptions = (H.unionWith (<>) `on` _assumptions) a b
+        }
+
+instance Monoid Judgement where
+    mempty = Judgement
+        { _constraints = mempty
+        , _assumptions = mempty
+        }
+
+--------------------------------------------------------------------------------
+
+class HasTypes a where
+    types :: Traversal' a Type'
+    freeTvs :: a -> HashSet PsName
+    boundTvs :: a -> HashSet PsName
+    subst :: Name -> Type' -> a -> a
+
+    freeTvs = foldMapOf types $ cata \case
+        VarTF n -> S.singleton n
+        t       -> fold t
+
+    boundTvs = const mempty
+
+    subst k v = types %~ cata \case
+        VarTF n | k == n -> v
+        t                -> embed t
+
+instance HasTypes Constraint where
+    types k (Equality s t) = Equality <$> types k s <*> types k t
+    types k (ImplicitInstance m s t) =
+        ImplicitInstance <$> types k m <*> types k s <*> types k t
+    types k (ExplicitInstance s t) =
+        ExplicitInstance <$> types k s <*> types k t
+
+instance (Hashable a, HasTypes a) => HasTypes (HashSet a) where
+    types k = traverseHashSetBad (types k)
+
+instance HasTypes Type' where
+    types = id
+    freeTvs = cata \case
+        VarTF n -> S.singleton n
+        ForallTF x t -> S.delete x t
+        t -> fold t
+    boundTvs = cata \case
+        ForallTF x t -> S.insert x t
+        t -> fold t
+    subst k v = para \case
+        VarTF n | k == n -> v
+        ForallTF x (pre,post)
+            | k == x -> ForallT x pre
+        t -> embed $ snd <$> t
+
+-- illegal traversal
+traverseHashSetBad :: (Hashable a, Hashable b)
+                   => Traversal (HashSet a) (HashSet b) a b
+traverseHashSetBad k s = fmap S.fromList $ traverse k (S.toList s)
+
+
+--------------------------------------------------------------------------------
+
+makePrisms ''Judgement
+makeLenses ''Judgement
+makePrisms ''Constraint
+makePrisms ''TypeError