Fix breakableFill: do not impose alignment.

[haskell/symantic.git] / symantic / Language / Symantic / Compiling / Beta.hs

diff --git a/symantic/Language/Symantic/Compiling/Beta.hs b/symantic/Language/Symantic/Compiling/Beta.hs
index 6c6fc3743d1590fc4ce672cabb1e211e63486904..5fa44a1e148c4067b6e5b92c657a772786687656 100644 (file)
--- a/symantic/Language/Symantic/Compiling/Beta.hs
+++ b/symantic/Language/Symantic/Compiling/Beta.hs
@@ -11,12 +11,12 @@ import Language.Symantic.Compiling.Term
 -- | Term application: apply second given 'TermT' to the first,
 -- applying embedded 'TeSym's, or return an error.
 betaTerm ::
- forall src ss es vs fun arg.
+ forall src ss ts vs fun arg.
  SourceInj (TypeVT src) src =>
  Constable (->) =>
- Term src ss es vs (fun::K.Type) ->
- Term src ss es vs (arg::K.Type) ->
- Either (Error_Beta src) (TermT src ss es vs)
+ Term src ss ts vs (fun::K.Type) ->
+ Term src ss ts vs (arg::K.Type) ->
+ Either (Error_Beta src) (TermT src ss ts vs)
 betaTerm (Term qf tf (TeSym te_fun)) (Term qa ta (TeSym te_arg)) =
        case tf of
         TyApp _ (TyApp _ a2b a2b_a) a2b_b
@@ -41,8 +41,8 @@ betaTerm (Term qf tf (TeSym te_fun)) (Term qa ta (TeSym te_arg)) =
 betaTerms ::
  SourceInj (TypeVT src) src =>
  Constable (->) =>
- BinTree (TermVT src ss es) ->
- Either (Error_Beta src) (TermVT src ss es)
+ BinTree (TermVT src ss ts) ->
+ Either (Error_Beta src) (TermVT src ss ts)
 betaTerms t =
        collapseBT (\acc ele -> do
                TermVT (Term qf tf te_fun) <- acc
@@ -61,8 +61,10 @@ betaTerms t =
                        let tf'' = subst mgu tf'
                        let ta'' = subst mgu ta'
                        TermT (Term qr tr te_res) <- betaTerm (Term qf'' tf'' te_fun) (Term qa'' ta'' te_arg)
-                       normalizeVarsTy (qr #> tr) $ \(TyApp _ (TyApp _ _c qr') tr') ->
+                       normalizeVarsTy (qr #> tr) $ \case
+                        TyApp _ (TyApp _ _c qr') tr' ->
                                Right $ TermVT $ Term qr' tr' te_res
+                        _ -> undefined -- FIXME: as of GHC 8.2, GHC is no longer clever enough to rule out other cases
         ) (Right <$> t)
 
 -- * Type 'Error_Beta'