symantic/Language/Symantic/Compiling/Beta.hs

   1 -- | Beta-reduction of 'Term's.
   2 module Language.Symantic.Compiling.Beta where
   3
   4 import Control.Arrow (left)
   5 import qualified Data.Kind as K
   6
   7 import Language.Symantic.Grammar
   8 import Language.Symantic.Typing
   9 import Language.Symantic.Compiling.Term
  10
  11 -- | Term application: apply second given 'Term' to the first,
  12 -- applying embedded 'TeSym's, or return an error.
  13 betaTerm ::
  14  forall src ss ts vs fun arg.
  15  SourceInj (TypeVT src) src =>
  16  Constable (->) =>
  17  Term src ss ts vs (fun::K.Type) ->
  18  Term src ss ts vs (arg::K.Type) ->
  19  Either (Error_Beta src) (TermT src ss ts vs)
  20 betaTerm (Term qf tf (TeSym te_fun)) (Term qa ta (TeSym te_arg)) =
  21         case tf of
  22          TyApp _ (TyApp _ a2b a2b_a) a2b_b
  23           | Just HRefl <- proj_ConstKiTy @(K (->)) @(->) a2b ->
  24                 case a2b_a `eqType` ta of
  25                  Nothing -> Left $ Error_Beta_Type_mismatch (TypeVT a2b_a) (TypeVT ta)
  26                  Just Refl ->
  27                         Right $
  28                         case (proveConstraint qf, proveConstraint qa) of
  29                          -- NOTE: remove provable Constraints to keep those smaller.
  30                          (Just Dict, Just Dict) -> TermT $ Term (noConstraintLen (lenVars a2b_b)) a2b_b $
  31                                 TeSym $ \c -> te_fun c `app` te_arg c
  32                          (Just Dict, Nothing) -> TermT $ Term qa a2b_b $
  33                                 TeSym $ \c -> te_fun c `app` te_arg c
  34                          (Nothing, Just Dict) -> TermT $ Term qf a2b_b $
  35                                 TeSym $ \c -> te_fun c `app` te_arg c
  36                          (Nothing, Nothing) -> TermT $ Term (qf # qa) a2b_b $
  37                                 TeSym $ \c -> te_fun c `app` te_arg c
  38          _ -> Left $ Error_Beta_Term_not_a_function $ TypeVT (qf #> tf)
  39
  40 -- | Collapse given 'BinTree' of 'TermVT's to compute a resulting 'TermVT', if possible.
  41 betaTerms ::
  42  SourceInj (TypeVT src) src =>
  43  Constable (->) =>
  44  BinTree (TermVT src ss ts) ->
  45  Either (Error_Beta src) (TermVT src ss ts)
  46 betaTerms t =
  47         collapseBT (\acc ele -> do
  48                 TermVT (Term qf tf te_fun) <- acc
  49                 TermVT (Term qa ta te_arg) <- ele
  50                 let (tf', ta') = appendVars tf ta
  51                 let (qf', qa') = appendVars qf qa
  52                 case unTyFun tf' of
  53                  Nothing -> Left $ Error_Beta_Term_not_a_function $ TypeVT tf'
  54                  Just (af, _rf) -> do
  55                         mgu <-
  56                                 (Error_Beta_Unify `left`) $
  57                                 case (unQualsTy af, unQualsTy ta') of
  58                                  (TypeK af', TypeK ta'') -> unifyType mempty af' ta''
  59                         let qf'' = subst mgu qf'
  60                         let qa'' = subst mgu qa'
  61                         let tf'' = subst mgu tf'
  62                         let ta'' = subst mgu ta'
  63                         TermT (Term qr tr te_res) <- betaTerm (Term qf'' tf'' te_fun) (Term qa'' ta'' te_arg)
  64                         normalizeVarsTy (qr #> tr) $ \case
  65                          TyApp _ (TyApp _ _c qr') tr' ->
  66                                 Right $ TermVT $ Term qr' tr' te_res
  67                          _ -> undefined -- FIXME: as of GHC 8.2, GHC is no longer clever enough to rule out other cases
  68          ) (Right <$> t)
  69
  70 -- * Type 'Error_Beta'
  71 data Error_Beta src
  72  =   Error_Beta_Term_not_a_function (TypeVT src)
  73  |   Error_Beta_Type_mismatch (TypeVT src) (TypeVT src)
  74  |   Error_Beta_Unify (Error_Unify src)
  75      -- ^ Cannot unify the expected 'Type' of the argument of the function,
  76      -- with the 'Type' of the argument.
  77  deriving (Eq, Show)
  78
  79 instance ErrorInj (Error_Beta src) (Error_Beta src) where
  80         errorInj = id
  81 instance ErrorInj (Error_Unify src) (Error_Beta src) where
  82         errorInj = Error_Beta_Unify