From d33de55fb0121f57c7bdf2a2e352210d5d53e184 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 5 Feb 2020 18:08:53 -0500 Subject: [PATCH 01/38] add Elaborate.hs --- liquidhaskell.cabal | 3 + src/Language/Haskell/Liquid/Bare.hs | 223 +++++++- src/Language/Haskell/Liquid/Bare/DataType.hs | 4 +- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 475 ++++++++++++++++++ src/Language/Haskell/Liquid/Bare/Plugged.hs | 4 +- src/Language/Haskell/Liquid/Bare/Resolve.hs | 4 +- src/Language/Haskell/Liquid/GHC/Interface.hs | 30 +- src/Language/Haskell/Liquid/GHC/Misc.hs | 78 ++- src/Language/Haskell/Liquid/Transforms/ANF.hs | 15 +- .../Haskell/Liquid/Transforms/CoreToLogic.hs | 4 +- 10 files changed, 799 insertions(+), 41 deletions(-) create mode 100644 src/Language/Haskell/Liquid/Bare/Elaborate.hs diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index c987cba782..978eb91aa3 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -90,6 +90,7 @@ library Language.Haskell.Liquid.Bare.Resolve Language.Haskell.Liquid.Bare.ToBare Language.Haskell.Liquid.Bare.Types + Language.Haskell.Liquid.Bare.Elaborate Language.Haskell.Liquid.Constraint.Constraint Language.Haskell.Liquid.Constraint.Env Language.Haskell.Liquid.Constraint.Fresh @@ -190,6 +191,8 @@ library , transformers >= 0.3 , unordered-containers >= 0.2 , vector >= 0.10 + , free + , recursion-schemes default-language: Haskell98 default-extensions: PatternGuards ghc-options: -W -fwarn-missing-signatures diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 6014c18ec3..01c5e5d834 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -23,6 +23,9 @@ module Language.Haskell.Liquid.Bare ( import Prelude hiding (error) import Control.Monad (unless) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.IO.Class (liftIO) import qualified Control.Exception as Ex import qualified Data.Binary as B import qualified Data.Maybe as Mb @@ -42,7 +45,8 @@ import qualified Language.Haskell.Liquid.GHC.API as Ghc import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.WiredIn import qualified Language.Haskell.Liquid.Measure as Ms -import qualified Language.Haskell.Liquid.Bare.Types as Bare +import qualified Language.Haskell.Liquid.Bare.Types as Bare +import Language.Haskell.Liquid.Bare.Elaborate import qualified Language.Haskell.Liquid.Bare.Resolve as Bare import qualified Language.Haskell.Liquid.Bare.DataType as Bare import qualified Language.Haskell.Liquid.Bare.Expand as Bare @@ -53,7 +57,8 @@ import qualified Language.Haskell.Liquid.Bare.ToBare as Bare import qualified Language.Haskell.Liquid.Bare.Class as Bare import qualified Language.Haskell.Liquid.Bare.Check as Bare import qualified Language.Haskell.Liquid.Bare.Laws as Bare -import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic +import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic +import qualified Language.Haskell.Liquid.Transforms.ANF as ANF import Control.Arrow (second) -------------------------------------------------------------------------------- @@ -96,15 +101,15 @@ saveLiftedSpec src sp = do -- | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then -- validates it using @checkGhcSpec@. ------------------------------------------------------------------------------------- -makeGhcSpec :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> GhcSpec +makeGhcSpec :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- -makeGhcSpec cfg src lmap mspecs0 - = checkThrow (Bare.checkGhcSpec mspecs src renv cbs sp) +makeGhcSpec cfg src lmap mspecs0 = do + sp <- makeGhcSpec0 cfg src lmap mspecs + let renv = ghcSpecEnv sp + pure $ checkThrow (Bare.checkGhcSpec mspecs src renv cbs sp) where mspecs = [ (m, checkThrow $ Bare.checkBareSpec m sp) | (m, sp) <- mspecs0, isTarget m ] ++ [ (m, sp) | (m, sp) <- mspecs0, not (isTarget m)] - sp = makeGhcSpec0 cfg src lmap mspecs - renv = ghcSpecEnv sp cbs = giCbs src checkThrow :: Ex.Exception e => Either e c -> c @@ -125,6 +130,142 @@ ghcSpecEnv sp = fromListSEnv binds vSort = Bare.varSortedReft emb rSort = rTypeSortedReft emb +-- witness of the isomorphism between elaboration binders and safe text +-- toHaskellBinder :: F.Symbol -> F.Symbol +-- toHaskellBinder = F.symbol . ('_':) . fmap +-- (\x -> case x of +-- '$' -> '_' +-- '#' -> '_' +-- _ -> x) . F.symbolString + +-- toGhcExpr :: F.Expr -> String +-- toGhcExpr e = +-- paren $ case e of +-- F.ECon (F.I c) -> show c +-- F.ECon (F.R c) -> show c +-- -- F.ECon (F.L _ _) -> todo Nothing "Don't know how to handle F.ECon (F.L _ _)" +-- F.EVar x -> F.symbolString x +-- F.EApp e0 e1 -> toGhcExpr e0 ++ toGhcExpr e1 +-- F.ENeg e0 -> "-" ++ toGhcExpr e0 +-- F.EBin bop e0 e1 -> bopToExpr bop ++ toGhcExpr e0 ++ toGhcExpr e1 +-- F.EIte p e0 e1 -> "if" ++ toGhcExpr p ++ "then" ++ toGhcExpr e0 ++ "else" ++ toGhcExpr e1 +-- F.ECst e0 _ -> toGhcExpr e0 +-- F.PAnd es -> "and" ++ bracket (L.intercalate "," $ toGhcExpr <$> es ) +-- F.POr es -> "or" ++ bracket (L.intercalate "," $ toGhcExpr <$> es) +-- F.PNot e -> "not" ++ toGhcExpr e +-- F.PImp e0 e1 -> "(==>)" ++ toGhcExpr e0 ++ toGhcExpr e1 +-- F.PAtom brel e0 e1 -> brelToExpr brel ++ toGhcExpr e0 ++ toGhcExpr e1 +-- _ -> todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e) +-- where paren x = "(" ++ x ++ ")" +-- bracket x = "["++ x ++ "]" +-- bopToExpr :: F.Bop -> String +-- bopToExpr bop = case bop of +-- F.Plus -> "(+)" +-- F.Minus -> "(-)" +-- F.Times -> "(*)" +-- F.Div -> "(/)" +-- F.Mod -> "mod" +-- F.RTimes -> "(*)" +-- F.RDiv -> "(/)" +-- brelToExpr :: F.Brel -> String +-- brelToExpr brel = case brel of +-- Eq -> "(==)" +-- Ne -> "(/=)" +-- Gt -> "(>)" +-- Lt -> "(<)" +-- Ge -> "(>=)" +-- Le -> "(<=)" +-- _ -> impossible Nothing "brelToExpr: Unsupported operation" + +-- -- FROM double [int, semigroup a] TO semigroup a => int -> double +-- buildTypeAnn :: String -> [SpecType] -> String +-- buildTypeAnn vvTy = L.foldl' f (paren ("(->)"++ paren vvTy ++"(Bool)")) +-- where f :: String -> SpecType -> String +-- f res ty +-- | isClassType ty = paren $ paren (GM.showPpr $ toType ty) ++ "=>" ++ res +-- | otherwise = paren $ "(->)" ++ paren (GM.showPpr $ toType ty) ++ res +-- paren x = "(" ++ x ++ ")" + +-- -- FROM (vv, x + y) [x,y] TO \(y)(x)(vv)->((+)(x)(y)) +-- buildExpr :: F.Reft -> [F.Symbol] -> String +-- buildExpr (F.Reft (vv, toGhcExpr -> e)) = +-- let vv' = if F.isDummy vv then "_" else F.symbolString vv +-- in paren . (++) "\\" . L.foldl' f (paren vv' ++ "->" ++ e) +-- where paren x = "(" ++ x ++ ")" +-- f res binder = paren (F.symbolString binder) ++ res + +-- elaborateSpecType :: [(F.Symbol,SpecType)] -- binders come in reverse order +-- -> (Ghc.CoreExpr -> Expr) +-- -> SpecType +-- -> Ghc.Ghc (SpecType, [F.Symbol]) -- binders for dictionaries +-- -- should have returned Maybe [F.Symbol] +-- elaborateSpecType bts coreToLogic t = +-- case F.tracepp ("elaborateSpecType: " ++ F.showpp bts) t of +-- RVar (RTV tv) (MkUReft reft@(F.Reft(vv,_oldE)) p) -> do +-- elaborateReft (reft, GM.showPpr tv) (pure (t, [])) +-- (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv,ee)) p), bs')) +-- RFun bind tin tout ureft@(MkUReft reft@(F.Reft(vv,_oldE)) p) -> do +-- let bts' = (bind,tin):bts +-- (eTin, bs') <- elaborateSpecType bts' coreToLogic tin +-- (eTout, bs'') <- elaborateSpecType bts' coreToLogic tout +-- -- eTin and eTout might have different dictionary names +-- -- need to do a substitution to make the reference to dictionaries consistent +-- -- if isClassType eTin +-- elaborateReft (reft, GM.showPpr $ toType t) (pure (RFun bind eTin eTout ureft, bs')) (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv,ee)) p), bs)) +-- RImpF bind tin tout ureft@(MkUReft reft@(F.Reft(vv,_oldE)) p) -> do +-- let bts' = (bind,tin):bts +-- (eTin, bs') <- elaborateSpecType bts' coreToLogic tin +-- (eTout, bs'') <- elaborateSpecType bts' coreToLogic tout +-- -- eTin and eTout might have different dictionary names +-- -- need to do a substitution to make the reference to dictionaries consistent +-- elaborateReft (reft, GM.showPpr $ toType t) (pure (RImpF bind eTin eTout ureft, bs')) +-- (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv,ee)) p), bs)) +-- -- support for RankNTypes/ref +-- RAllT (RTVar tv ty) tout ref -> do +-- (eTout, bts') <- elaborateSpecType bts coreToLogic tout +-- pure (RAllT (RTVar tv ty) eTout ref, bts') +-- RAllP pvbind tout -> do +-- (eTout, bts') <- elaborateSpecType bts coreToLogic tout +-- pure (RAllP pvbind eTout, bts') +-- -- pargs not handled for now +-- -- RApp tycon args pargs reft +-- RApp tycon args pargs ureft@(MkUReft reft@(F.Reft(vv,_)) p) +-- | isClass tycon -> +-- pure (t, []) +-- | otherwise -> +-- elaborateReft (reft, GM.showPpr $ toType t) (pure (RApp tycon args pargs ureft, bs)) +-- (\bs' ee -> pure (RApp tycon args pargs (MkUReft (F.Reft (vv,ee)) p), bs')) + +-- _ -> +-- todo Nothing ("Not sure how to elaborate " ++ F.showpp t) +-- where elaborateReft :: (F.Reft, String) -> Ghc.Ghc a -> ([F.Symbol] -> F.Expr -> Ghc.Ghc a) -> Ghc.Ghc a +-- elaborateReft (reft, vvTy) trivial nonTrivialCont = +-- if isTrivial reft +-- then trivial +-- else do +-- let query = buildQuery reft id vvTy +-- liftIO $ putStrLn query +-- mbExpr <- GM.elaborateExprInst query +-- case mbExpr of +-- Nothing -> panic Nothing ("Ghc is unable to elaborate the expression: " ++ query) +-- Just (coreToLogic -> eeWithLams) -> do +-- let (bs', ee) = grabLams ([], eeWithLams) +-- nonTrivialCont bs' ee +-- bs = [b | (b,t) <- bts, not (isClassType t)] +-- ts = snd <$> bts +-- buildQuery reft f vvTy = buildExprAnn (buildExpr reft bs) (buildTypeAnn (f vvTy) ts) +-- buildExprAnn e ann = e ++ "::" ++ ann +-- grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr) +-- grabLams (bs, F.ELam (b,_) e) = grabLams (b:bs, e) +-- grabLams bse = bse +-- isTrivial :: F.Reft -> Bool +-- isTrivial (F.Reft (_,ee)) = (L.null . F.syms) ee + + + + + + ------------------------------------------------------------------------------------- -- | @makeGhcSpec0@ slurps up all the relevant information needed to generate @@ -133,27 +274,57 @@ ghcSpecEnv sp = fromListSEnv binds -- essentially, to get to the `BareRTEnv` as soon as possible, as thats what -- lets us use aliases inside data-constructor definitions. ------------------------------------------------------------------------------------- -makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> GhcSpec +makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- -makeGhcSpec0 cfg src lmap mspecs = SP - { gsConfig = cfg - , gsImps = makeImports mspecs - , gsSig = addReflSigs refl sig - , gsRefl = refl - , gsLaws = laws - , gsData = sData - , gsQual = qual - , gsName = makeSpecName env tycEnv measEnv name - , gsVars = makeSpecVars cfg src mySpec env measEnv - , gsTerm = makeSpecTerm cfg mySpec env name - , gsLSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1 { - impSigs = makeImports mspecs, - expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ], - dataDecls = dataDecls mySpec2 - } - } +makeGhcSpec0 cfg src lmap mspecs = do + -- liftIO $ mapM_ (putStrLn . F.showpp) (val.snd<$>gsTySigs sig) + -- liftIO $ mapM_ (mapReftM (\(MkUReft (F.Reft (vv,r)) _) -> putStrLn$(F.symbolSafeString vv ++ ":" ++ toGhcExpr r))) (val.snd<$> gsTySigs sig) + -- let sigs = val.snd <$> + -- [(x,y) | (x,y) <- gsTySigs sig, ("VerifiedMonad" `L.isPrefixOf` GM.showPpr x )] :: [SpecType] + let sigs = val.snd <$> gsTySigs sig + elaboratedSigs <- mapM (elaborateSpecType (pure ()) coreToLg) sigs + liftIO $ putStrLn "Before:" + liftIO $ putStrLn $ F.showpp sigs + liftIO $ putStrLn "After:" + liftIO $ putStrLn $ F.showpp elaboratedSigs + + -- liftIO $ putStrLn "[DUMPING toType]" + -- liftIO $ mapM_ (putStrLn . GM.showPpr . Ghc.typeToLHsType) (toType <$> sigs) + -- liftIO $ putStrLn "[DUMPING toType DONE]" + -- mapM_ (liftIO . putStrLn . F.showpp <=< elaborateSpecType [] coreToLg) sigs + + -- e <- Mb.fromJust <$> GM.elaborateExprInst "1 + 1 :: Int" + -- liftIO $ putStrLn (GM.showPpr e) + -- hscEnv <- Ghc.getSession + -- e' <- liftIO $ ANF.anormalizeExpr cfg hscEnv (GM.tracePpr "OHQO" e) + + -- e <- Rec.transformRecSingleExpr. Mb.fromJust <$> GM.elaborateExprInst "let x = 10 in x" + -- liftIO . print $ CoreToLogic.runToLogic embs lmap dm (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e') + -- liftIO $ putStrLn "" + pure $ SP + { gsConfig = cfg + , gsImps = makeImports mspecs + , gsSig = addReflSigs refl sig + , gsRefl = refl + , gsLaws = laws + , gsData = sData + , gsQual = qual + , gsName = makeSpecName env tycEnv measEnv name + , gsVars = makeSpecVars cfg src mySpec env measEnv + , gsTerm = makeSpecTerm cfg mySpec env name + , gsLSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1 { + impSigs = makeImports mspecs, + expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ], + dataDecls = dataDecls mySpec2 + } + } where - -- build up spec components + -- build up spec components + coreToLg = \e -> case CoreToLogic.runToLogic embs lmap dm + (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e) + of Left _ -> impossible Nothing "can't reach here" + Right e -> e + dm = Bare.tcDataConMap tycEnv myRTE = myRTEnv src env sigEnv rtEnv qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs sData = makeSpecData src env sigEnv measEnv sig specs diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 1486248c89..7f60eeb6af 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -529,12 +529,12 @@ ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataCo } where c' = Bare.lookupGhcDataCon env name "ofBDataCtor" c - ts' = Bare.ofBareType env name l (Just ps) <$> ts + ts' = F.notracepp "OHQO" $ Bare.ofBareType env name l (Just ps) <$> ts res' = Bare.ofBareType env name l (Just ps) <$> res t0' = dataConResultTy c' αs t0 res' _cfg = getConfig env (yts, ot) = -- F.tracepp ("dataConTys: " ++ F.showpp (c, αs)) $ - qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') + F.notracepp "OHQO2" $ qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') zts = zipWith (normalizeField c') [1..] (reverse yts) usedTvs = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts')) cs = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ] diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs new file mode 100644 index 0000000000..8ea0c9af6a --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +-- | This module uses GHC API to elaborate the resolves expressions + +module Language.Haskell.Liquid.Bare.Elaborate + ( fixExprToHsExpr + , elaborateSpecType + ) +where + +import qualified Language.Fixpoint.Types as F +import qualified Language.Haskell.Liquid.GHC.Misc + as GM +import Language.Haskell.Liquid.Types.Types +import Language.Haskell.Liquid.Types.RefType +import qualified Data.List as L +import Language.Haskell.Liquid.Types.Errors +import Control.Monad.Free +import Data.Functor.Foldable +import GHC +import OccName +import FastString +import HsPat +import SrcLoc +import Control.Monad +import CoreSyn +import Exception +import Inst +import Panic hiding ( panic ) +import Desugar +import TcRnMonad +import TcHsSyn +import RnExpr +import GhcMonad +import TcSimplify +import PrelNames +import Outputable hiding ( panic ) +import TysWiredIn ( boolTyCon ) +import HscTypes +import ErrUtils +import HscMain +import TcExpr +import HsExpr +import RdrName +import TysWiredIn +import BasicTypes +import PrelNames +import Data.Default ( def ) + + +-- | Base functor of RType +data RTypeF c tv r f + = RVarF { + rtf_var :: !tv + , rtf_reft :: !r + } + + | RFunF { + rtf_bind :: !F.Symbol + , rtf_in :: !f + , rtf_out :: !f + , rtf_reft :: !r + } + + | RImpFF { + rtf_bind :: !F.Symbol + , rtf_in :: !f + , rtf_out :: !f + , rtf_reft :: !r + } + + | RAllTF { + rtf_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ())) + , rtf_ty :: !f + , rtf_ref :: !r + } + + -- | "forall x y . TYPE" + -- ^^^^^^^^^^^^^^^^^^^ (rtf_pvbind) + | RAllPF { + rtf_pvbind :: !(PVU c tv) -- ar (RType c tv ())) + , rtf_ty :: !f + } + + -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`) + -- * the `RProp` denoted by `{\h -> v > h}` to + -- * the `RTyCon` denoted by `[]`. + | RAppF { + rtf_tycon :: !c + , rtf_args :: ![f] + , rtf_pargs :: ![RTPropF c tv f] + , rtf_reft :: !r + } + + | RAllEF { + rtf_bind :: !F.Symbol + , rtf_allarg :: !f + , rtf_ty :: !f + } + + | RExF { + rtf_bind :: !F.Symbol + , rtf_exarg :: !f + , rtf_ty :: !f + } + + | RExprArgF (F.Located F.Expr) + + | RAppTyF{ + rtf_arg :: !f + , rtf_res :: !f + , rtf_reft :: !r + } + + | RRTyF { + rtf_env :: ![(F.Symbol, f)] + , rtf_ref :: !r + , rtf_obl :: !Oblig + , rtf_ty :: !f + } + + | RHoleF r + deriving (Functor) + +-- It's probably ok to treat (RType c tv ()) as a leaf.. +type RTPropF c tv f = Ref (RType c tv ()) f + + +-- | SpecType with Holes. +-- It provides us a context to construct the ghc queries. +-- I don't think we can reuse RHole since it is not intended +-- for this use case + +type SpecTypeF = RTypeF RTyCon RTyVar RReft +type PartialSpecType = Free (RTypeF RTyCon RTyVar RReft) () + +type instance Base (RType c tv r) = RTypeF c tv r + +instance Recursive (RType c tv r) where + project (RVar var reft ) = RVarF var reft + project (RFun bind tin tout reft) = RFunF bind tin tout reft + project (RImpF bind tin tout reft) = RImpFF bind tin tout reft + project (RAllT tvbind ty ref ) = RAllTF tvbind ty ref + project (RAllP pvbind ty ) = RAllPF pvbind ty + project (RApp c args pargs reft ) = RAppF c args pargs reft + project (RAllE bind allarg ty ) = RAllEF bind allarg ty + project (REx bind exarg ty ) = RExF bind exarg ty + project (RExprArg e ) = RExprArgF e + project (RAppTy arg res reft ) = RAppTyF arg res reft + project (RRTy env ref obl ty ) = RRTyF env ref obl ty + project (RHole r ) = RHoleF r + +instance Corecursive (RType c tv r) where + embed (RVarF var reft ) = RVar var reft + embed (RFunF bind tin tout reft) = RFun bind tin tout reft + embed (RImpFF bind tin tout reft) = RImpF bind tin tout reft + embed (RAllTF tvbind ty ref ) = RAllT tvbind ty ref + embed (RAllPF pvbind ty ) = RAllP pvbind ty + embed (RAppF c args pargs reft ) = RApp c args pargs reft + embed (RAllEF bind allarg ty ) = RAllE bind allarg ty + embed (RExF bind exarg ty ) = REx bind exarg ty + embed (RExprArgF e ) = RExprArg e + embed (RAppTyF arg res reft ) = RAppTy arg res reft + embed (RRTyF env ref obl ty ) = RRTy env ref obl ty + embed (RHoleF r ) = RHole r + + +-- specTypeToLHsType :: SpecType -> LHsType GhcPs +-- specTypeToLHsType = typeToLHsType . toType + +-- -- Given types like x:a -> y:a -> _, this function returns x:a -> y:a -> Bool +-- -- Free monad takes care of substitution + +-- A one-way function. Kind of like injecting something into Maybe +specTypeToPartial :: forall a . SpecType -> SpecTypeF (Free SpecTypeF a) +specTypeToPartial = hylo (fmap wrap) project + +-- probably should return spectype instead.. +plugType :: SpecType -> PartialSpecType -> SpecType +plugType t = refix . f + where + f = hylo Fix $ \case + Pure _ -> specTypeToPartial t + Free res -> res + +-- build the expression we send to ghc for elaboration +-- YL: tweak this function to see if ghc accepts explicit dictionary binders +buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs +buildHsExpr res = para $ \case + RFunF bind (tin, _) (_, res) _ + | isClassType tin -> res + | otherwise -> mkHsLam [nlVarPat (symbolToRdrName varName bind)] res + RImpFF bind (tin, _) (_, res) _ + | isClassType tin -> res + | otherwise -> mkHsLam [nlVarPat (symbolToRdrName varName bind)] res + RAllEF _ _ (_, res) -> res + RAllTF _ (_, res) _ -> res + RExF _ _ (_, res) -> res + RAppTyF _ (_, res) _ -> res + RRTyF _ _ _ (_, res) -> res + _ -> res + +elaborateSpecType + :: PartialSpecType + -> (CoreExpr -> F.Expr) + -> SpecType + -> Ghc (SpecType, [F.Symbol]) -- binders for dictionaries + -- should have returned Maybe [F.Symbol] +elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t of + RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + elaborateReft + (reft, t) + (pure (t, [])) + (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs')) + RFun bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + -- the reft is never actually used by the child + -- maybe i should enforce this information at the type level + let partialFunTp = + Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType + partialTp' = partialTp >> partialFunTp :: PartialSpecType + (eTin , bs' ) <- elaborateSpecType partialTp' coreToLogic tin + (eTout, bs'') <- elaborateSpecType partialTp' coreToLogic tout + -- eTin and eTout might have different dictionary names + -- need to do a substitution to make the reference to dictionaries consistent + -- if isClassType eTin + elaborateReft + (reft, t) + (pure (RFun bind eTin eTout ureft, bs')) + (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv, ee)) p), bs') + ) + RImpF bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + let partialFunTp = + Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType + partialTp' = partialTp >> partialFunTp :: PartialSpecType + (eTin , bs' ) <- elaborateSpecType partialTp' coreToLogic tin + (eTout, bs'') <- elaborateSpecType partialTp' coreToLogic tout + -- eTin and eTout might have different dictionary names + -- need to do a substitution to make the reference to dictionaries consistent + -- if isClassType eTin + elaborateReft + (reft, t) + (pure (RImpF bind eTin eTout ureft, bs')) + (\bs' ee -> + pure (RImpF bind eTin eTout (MkUReft (F.Reft (vv, ee)) p), bs') + ) + -- support for RankNTypes/ref + RAllT (RTVar tv ty) tout ref -> do + (eTout, bts') <- elaborateSpecType + (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ref)) + coreToLogic + tout + pure (RAllT (RTVar tv ty) eTout ref, bts') + RAllP pvbind tout -> do + (eTout, bts') <- elaborateSpecType (partialTp >> Free (RAllPF pvbind (pure ()))) + coreToLogic + tout + pure (RAllP pvbind eTout, bts') + -- pargs not handled for now + -- RApp tycon args pargs reft + RApp tycon args pargs ureft@(MkUReft reft@(F.Reft (vv, _)) p) + | isClass tycon -> pure (t, []) + | otherwise -> elaborateReft + (reft, t) + (pure (RApp tycon args pargs ureft, [])) + (\bs' ee -> + pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') + ) + RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do + (eArg, bs' ) <- elaborateSpecType partialTp coreToLogic arg + (eRes, bs'') <- elaborateSpecType partialTp coreToLogic res + elaborateReft + (reft, t) + (pure (RAppTy eArg eRes ureft, bs'')) + (\bs' ee -> pure (RAppTy eArg eRes (MkUReft (F.Reft (vv, ee)) p), bs'')) + RAllE _ _ _ -> todo Nothing ("Not sure how to elaborate RAllE" ++ F.showpp t) + REx _ _ _ -> todo Nothing ("Not sure how to elaborate REx" ++ F.showpp t) + RExprArg _ -> + todo Nothing ("Not sure how to elaborate RExprArg" ++ F.showpp t) + RRTy _ _ _ _ -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t) + _ -> todo Nothing ("Not sure how to elaborate " ++ F.showpp t) + where + boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType + elaborateReft + :: (F.Reft, SpecType) -> Ghc a -> ([F.Symbol] -> F.Expr -> Ghc a) -> Ghc a + elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont = + if isTrivial reft + then trivial + else do +-- liftIO $ putStrLn query + let querySpecType = + plugType (rFun vv vvTy boolType) partialTp :: SpecType + hsExpr = + buildHsExpr + ( + fixExprToHsExpr e + ) + querySpecType :: LHsExpr GhcPs + exprWithTySigs = + GM.tracePpr "exprWithTySigs" $ noLoc $ ExprWithTySig + (mkLHsSigWcType $ specTypeToLHsType (F.tracepp "querySpecType" querySpecType)) + hsExpr :: LHsExpr GhcPs + (msgs, mbExpr) <- GM.elaborateHsExprInst exprWithTySigs + case mbExpr of + Nothing -> panic + Nothing + ( "Ghc is unable to elaborate the expression: " + ++ GM.showPpr exprWithTySigs + ++ "\n" + ++ GM.showPpr (GM.showSDoc <$> pprErrMsgBagWithLoc (snd msgs)) + ) + Just eeWithLamsCore -> do + let eeWithLams = + coreToLogic (GM.tracePpr "eeWithLamsCore" eeWithLamsCore) + (bs', ee) = F.tracepp "grabLams" $ grabLams ([], eeWithLams) + nonTrivialCont (GM.dropModuleUnique <$> bs') + (dropBinderUnique bs' ee) + isTrivial :: F.Reft -> Bool + isTrivial (F.Reft (_, ee)) = (L.null . F.syms) ee + grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr) + grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e) + grabLams bse = bse + dropBinderUnique :: [F.Symbol] -> F.Expr -> F.Expr + dropBinderUnique binders = F.tracepp "ElaboratedExpr" + . F.substa (\x -> if L.elem x binders then GM.dropModuleUnique x else x) + + + + +-- | Embed fixpoint expressions into parsed haskell expressions. +-- It allows us to bypass the GHC parser and use arbitrary symbols +-- for identifiers (compared to using the string API) +fixExprToHsExpr :: F.Expr -> LHsExpr GhcPs +fixExprToHsExpr (F.ECon c) = constantToHsExpr c +fixExprToHsExpr (F.EVar x) = + noLoc (HsVar NoExt (noLoc (symbolToRdrName varName x))) +fixExprToHsExpr (F.EApp e0 e1) = + noLoc (HsApp NoExt (fixExprToHsExpr e0) (fixExprToHsExpr e1)) +fixExprToHsExpr (F.ENeg e) = noLoc + (HsApp NoExt + (noLoc (HsVar NoExt (noLoc (nameRdrName negateName)))) + (fixExprToHsExpr e) + ) +fixExprToHsExpr (F.EBin bop e0 e1) = noLoc + (HsApp NoExt + (noLoc (HsApp NoExt (bopToHsExpr bop) (fixExprToHsExpr e0))) + (fixExprToHsExpr e1) + ) +fixExprToHsExpr (F.EIte p e0 e1) = noLoc + (HsIf NoExt + Nothing + (fixExprToHsExpr p) + (fixExprToHsExpr e0) + (fixExprToHsExpr e1) + ) +-- FIXME: convert sort to HsType +fixExprToHsExpr (F.ECst e0 _) = fixExprToHsExpr e0 +fixExprToHsExpr (F.PAnd es ) = noLoc + (HsApp + NoExt + (noLoc (HsVar NoExt (noLoc (varQual_RDR dATA_FOLDABLE (fsLit "and"))))) + (noLoc (ExplicitList NoExt Nothing (fixExprToHsExpr <$> es))) + ) +fixExprToHsExpr (F.POr es) = noLoc + (HsApp + NoExt + (noLoc (HsVar NoExt (noLoc (varQual_RDR dATA_FOLDABLE (fsLit "or"))))) + (noLoc (ExplicitList NoExt Nothing (fixExprToHsExpr <$> es))) + ) +fixExprToHsExpr (F.PNot e) = + noLoc (HsApp NoExt (noLoc (HsVar NoExt (noLoc not_RDR))) (fixExprToHsExpr e)) +fixExprToHsExpr (F.PAtom brel e0 e1) = noLoc + (HsApp NoExt + (noLoc (HsApp NoExt (brelToHsExpr brel) (fixExprToHsExpr e0))) + (fixExprToHsExpr e1) + ) +fixExprToHsExpr (F.PImp e0 e1) = noLoc + (HsApp + NoExt + (noLoc + (HsApp NoExt + (noLoc (HsVar NoExt (noLoc (mkVarUnqual (mkFastString "==>"))))) + (fixExprToHsExpr e0) + ) + ) + (fixExprToHsExpr e1) + ) +fixExprToHsExpr e = + todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e) + +constantToHsExpr :: F.Constant -> LHsExpr GhcPs +-- constantToHsExpr (F.I c) = noLoc (HsLit NoExt (HsInt NoExt (mkIntegralLit c))) +constantToHsExpr (F.I i) = + noLoc (HsOverLit NoExt (mkHsIntegral (mkIntegralLit i))) +constantToHsExpr (F.R d) = + noLoc (HsOverLit NoExt (mkHsFractional (mkFractionalLit d))) +constantToHsExpr _ = + todo Nothing "constantToHsExpr: Not sure how to handle constructor L" + +-- This probably won't work because of the qualifiers +bopToHsExpr :: F.Bop -> LHsExpr GhcPs +bopToHsExpr bop = noLoc (HsVar NoExt (noLoc (f bop))) + where + f F.Plus = plus_RDR + f F.Minus = minus_RDR + f F.Times = times_RDR + f F.Div = mkVarUnqual (fsLit "/") + f F.Mod = varQual_RDR gHC_REAL (fsLit "mod") + f F.RTimes = times_RDR + f F.RDiv = varQual_RDR gHC_REAL (fsLit "/") + +brelToHsExpr :: F.Brel -> LHsExpr GhcPs +brelToHsExpr brel = noLoc (HsVar NoExt (noLoc (f brel))) + where + f F.Eq = mkVarUnqual (mkFastString "==") + f F.Gt = gt_RDR + f F.Lt = lt_RDR + f F.Ge = ge_RDR + f F.Le = le_RDR + f F.Ne = mkVarUnqual (mkFastString "/=") + f _ = impossible Nothing "brelToExpr: Unsupported operation" + + +symbolToRdrName :: NameSpace -> F.Symbol -> RdrName +symbolToRdrName ns x + | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s)) + | otherwise = mkQual + ns + (mkFastString (F.symbolString modName), mkFastString (F.symbolString s)) + where (modName, s) = GM.splitModuleName x + + +-- SpecType -> LHsType +-- SpecTypeF LHsType -> LHsType +-- SpecType -> SpectypeF +-- distPara :: Corecursive t => Base t (t, a) -> (t, Base t a) +-- SpecTypeF ((t,) SpecType) -> (t,) (SpecTypeF SpecType) +specTypeToLHsType :: SpecType -> LHsType GhcPs +-- surprised that the type annotaiton is necessary +specTypeToLHsType = + flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case + RVarF (RTV tv) _ -> nlHsTyVar (getRdrName tv) + RFunF _ (tin, tin') (_, tout) _ + | isClassType tin -> noLoc $ HsQualTy NoExt (noLoc [tin']) tout + | otherwise -> nlHsFunTy tin' tout + RImpFF _ (_, tin) (_, tout) _ -> nlHsFunTy tin tout + RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> + noLoc $ HsForAllTy NoExt (userHsTyVarBndrs noSrcSpan [getRdrName tv]) t + RAllPF _ (_, ty) -> ty + RAppF RTyCon { rtc_tc = tc } ts _ _ -> nlHsTyConApp + (getRdrName tc) + [ hst | (t, hst) <- ts, notExprArg t ] + where + notExprArg (RExprArg _) = False + notExprArg _ = True + RAllEF _ _ (_, t) -> t + RExF _ _ (_, t) -> t + RAppTyF (_, t) (RExprArg _, _ ) _ -> t + RAppTyF (_, t) (_ , t') _ -> nlHsAppTy t t' + RRTyF _ _ _ (_, t) -> t + RHoleF _ -> noLoc $ HsWildCardTy NoExt + RExprArgF _ -> todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg" + + + + + +-- toType (RApp (RTyCon {rtc_tc = c}) ts _ _) +-- = TyConApp c (toType <$> filter notExprArg ts) +-- where +-- notExprArg (RExprArg _) = False +-- notExprArg _ = True diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs index 3980eed77c..d4d2a911c1 100644 --- a/src/Language/Haskell/Liquid/Bare/Plugged.hs +++ b/src/Language/Haskell/Liquid/Bare/Plugged.hs @@ -50,7 +50,7 @@ makePluggedSig :: ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> Ghc.NameSet -> LocSpecType makePluggedSig name embs tyi exports kx t - | Just x <- kxv = mkPlug x + | Just x <- kxv = F.notracepp ("makePluggedSig:" ++ F.showpp t) $ mkPlug x | otherwise = t where kxv = Bare.plugSrc kx @@ -209,7 +209,7 @@ goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecTy -> SpecType goPlug tce tyi err f = go where - go t (RHole r) = (addHoles t') { rt_reft = f t r } + go t (RHole r) = (F.notracepp "goPlug" $ addHoles t') { rt_reft = f t r } where t' = everywhere (mkT $ addRefs tce tyi) t addHoles = everywhere (mkT $ addHole) diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs index a6268439cd..f25992391d 100644 --- a/src/Language/Haskell/Liquid/Bare/Resolve.hs +++ b/src/Language/Haskell/Liquid/Bare/Resolve.hs @@ -687,7 +687,7 @@ maybeResolveSym env name kind x = case resolveLocSym env name kind x of -- | @ofBareType@ and @ofBareTypeE@ should be the _only_ @SpecType@ constructors ------------------------------------------------------------------------------- ofBareType :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType -ofBareType env name l ps t = either fail id (ofBareTypeE env name l ps t) +ofBareType env name l ps t = F.notracepp ("ofBareType:" ++ F.showpp name) $ either fail id (ofBareTypeE env name l ps t) where fail = Ex.throw -- fail = Misc.errorP "error-ofBareType" . F.showpp @@ -983,4 +983,4 @@ type SymMap = M.HashMap F.Symbol F.Symbol --------------------------------------------------------------------------------- partitionLocalBinds :: [(Ghc.Var, a)] -> ([(Ghc.Var, a)], [(Ghc.Var, a)]) --------------------------------------------------------------------------------- -partitionLocalBinds = L.partition (Mb.isJust . localKey . fst) \ No newline at end of file +partitionLocalBinds = L.partition (Mb.isJust . localKey . fst) diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 32f6f369cf..2c271772e9 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -431,8 +431,34 @@ processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = d let modSum = pm_mod_summary (tm_parsed_module typechecked) ghcSrc <- makeGhcSrc cfg file typechecked modSum bareSpecs <- makeBareSpecs cfg depGraph specEnv modSum bareSpec - let ghcSpec = makeGhcSpec cfg ghcSrc logicMap bareSpecs - _ <- liftIO $ saveLiftedSpec ghcSrc ghcSpec + -- preparing environment for evaluation + setContext [iimport |(modName, _) <- bareSpecs, + let iimport = if isTarget modName + then IIModule (getModName modName) + else IIDecl (simpleImportDecl (getModName modName))] + -- enable partial type inference + dflags <- getSessionDynFlags + setSessionDynFlags (dflags + `xopt_set` + PartialTypeSignatures + `xopt_set` + RankNTypes) + void $ execStmt + "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}" + execOptions + void $ execStmt + "let {infix 4 ==; _ == _ = undefined}" + execOptions + void $ execStmt + "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}" + execOptions + void $ execStmt + "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}" + execOptions + void $ execStmt + "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}" + execOptions + ghcSpec <- makeGhcSpec cfg ghcSrc logicMap bareSpecs return $ GI ghcSrc ghcSpec --------------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 7bef43171a..7cc3d57a05 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -19,7 +19,17 @@ module Language.Haskell.Liquid.GHC.Misc where import Class (classKey) import Data.String import qualified Data.List as L -import PrelNames (fractionalClassKeys) +import PrelNames (fractionalClassKeys, itName) +import Inst +import GhcMonad +import DsMonad +import DsExpr +import RnExpr +import TcRnMonad +import TcExpr +import TcSimplify +import TcHsSyn +import TcEvidence import FamInstEnv import Debug.Trace -- import qualified ConLike as Ghc @@ -34,14 +44,14 @@ import qualified CoreSyn as Core import CostCentre import GHC hiding (L) import HscTypes (ModGuts(..), HscEnv(..), FindResult(..), - Dependencies(..)) + Dependencies(..), runInteractiveHsc) import TysWiredIn (anyTy) import NameSet (NameSet) import SrcLoc hiding (L) import Bag import ErrUtils import CoreLint -import CoreMonad +import CoreMonad hiding (getHscEnv) import Text.Parsec.Pos (incSourceColumn, sourceName, sourceLine, sourceColumn, newPos) @@ -836,3 +846,65 @@ defaultDataCons (TyConApp tc argτs) ds = do defaultDataCons _ _ = Nothing +-------------------------------------------------------------------------------- +-- | Elaboration +-------------------------------------------------------------------------------- + +-- elaborateExprInst :: GhcMonad m => String -> m (Maybe CoreExpr) +-- elaborateExprInst = elaborateExpr TM_Inst + +-- elaborateExpr :: GhcMonad m => TcRnExprMode -> String -> m (Maybe CoreExpr) +-- elaborateExpr mode expr = +-- withSession $ \hsc_env -> liftIO $ hscElabExpr hsc_env mode expr + +elaborateHsExprInst + :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr) +elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr + + +elaborateHsExpr + :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr) +elaborateHsExpr mode expr = + withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr + +hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr) +hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + liftIO $ elabRnExpr hsc_env mode expr + + + +-- hscElabExpr :: HscEnv -> TcRnExprMode -> String -> IO (Messages, Maybe CoreExpr) +-- hscElabExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do +-- hsc_env <- getHscEnv +-- parsed_expr <- hscParseExpr expr +-- liftIO $ elabRnExpr hsc_env mode parsed_expr + +elabRnExpr + :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr) +elabRnExpr hsc_env mode rdr_expr = + runTcInteractive hsc_env $ do + (rn_expr, _fvs) <- rnLExpr rdr_expr + failIfErrsM + uniq <- newUnique + let fresh_it = itName uniq (getLoc rdr_expr) + orig = lexprCtOrigin rn_expr + (tclvl, lie, (tc_expr, res_ty)) <- pushLevelAndCaptureConstraints $ do + (_tc_expr, expr_ty) <- tcInferSigma rn_expr + expr_ty' <- if inst + then snd <$> deeplyInstantiate orig expr_ty + else return expr_ty + return (_tc_expr, expr_ty') + (_, _, evbs, residual, _) <- simplifyInfer tclvl + infer_mode + [] {- No sig vars -} + [(fresh_it, res_ty)] + lie + evbs' <- perhaps_disable_default_warnings $ simplifyInteractive residual + full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr)) + initDsTc $ dsLExpr full_expr + where + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (True, NoRestrictions, id) + TM_NoInst -> (False, NoRestrictions, id) + TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index bfbd26ddf0..c644e65494 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -10,13 +10,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.Liquid.Transforms.ANF (anormalize) where +module Language.Haskell.Liquid.Transforms.ANF (anormalize, anormalizeExpr) where import Prelude hiding (error) import CoreSyn hiding (mkTyArg) import CoreUtils (exprType) import qualified DsMonad -import DsMonad (initDsWithModGuts) +import DsMonad (initDsWithModGuts, initDsTc) import GHC hiding (exprType) import HscTypes import OccName (OccName, mkVarOccFS) @@ -86,10 +86,21 @@ modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis fis = mgi_fam_insts mg -} +anormalizeExpr :: (UX.HasConfig cfg) => cfg -> HscEnv -> CoreExpr -> IO CoreExpr +anormalizeExpr cfg hscEnv e = do + (_, mbE) <- runTcInteractive hscEnv $ initDsTc $ normalizeExpr γ0 e + case mbE of + Nothing -> panic Nothing "Oops, cannot A-Normalize Refinement Expression!" + Just e' -> pure e' + where γ0 = emptyAnfEnv (UX.getConfig cfg) + -------------------------------------------------------------------------------- -- | A-Normalize a @CoreBind@ -------------------------------------------------- -------------------------------------------------------------------------------- +normalizeExpr :: AnfEnv -> CoreExpr -> DsMonad.DsM CoreExpr +normalizeExpr γ e = runDsM $ evalStateT (stitch γ e) (DsST []) + -- Can't make the below default for normalizeBind as it -- fails tests/pos/lets.hs due to GHCs odd let-bindings diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs index 07bfdee7c9..a59e1df039 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -383,7 +383,7 @@ toPredApp p = go . Misc.mapFst opSym . splitArgs $ p | f == symbol ("&&" :: String) = PAnd <$> mapM coreToLg [e1, e2] | f == symbol ("==>" :: String) - = PImp <$> coreToLg e1 <*> coreToLg e2 + = F.tracepp "toPredApp" <$> (PImp <$> coreToLg e1 <*> coreToLg e2) go (Just f, es) | f == symbol ("or" :: String) = POr <$> mapM coreToLg es @@ -524,7 +524,7 @@ isBangInteger [(C.DataAlt s, _, _), (C.DataAlt jp,_,_), (C.DataAlt jn,_,_)] isBangInteger _ = False isErasable :: Id -> Bool -isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v) +isErasable v = F.tracepp msg $ isGhcSplId v && not (isDCId v) where msg = "isErasable: " ++ GM.showPpr (v, Var.idDetails v) From 7f412d45b8c2ed51e22ac90379ab161f006466ef Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 7 Feb 2020 12:24:12 -0500 Subject: [PATCH 02/38] elaborate almost done --- src/Language/Haskell/Liquid/Bare.hs | 36 ++- src/Language/Haskell/Liquid/Bare/DataType.hs | 4 +- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 270 ++++++++++++------ src/Language/Haskell/Liquid/Bare/Measure.hs | 10 +- src/Language/Haskell/Liquid/Bare/ToBare.hs | 2 +- .../Haskell/Liquid/Constraint/Fresh.hs | 4 +- .../Haskell/Liquid/Constraint/Generate.hs | 4 +- .../Haskell/Liquid/Constraint/ToFixpoint.hs | 4 +- src/Language/Haskell/Liquid/GHC/Interface.hs | 3 - src/Language/Haskell/Liquid/GHC/Misc.hs | 2 +- .../Haskell/Liquid/Transforms/CoreToLogic.hs | 16 +- .../Haskell/Liquid/Transforms/Rewrite.hs | 2 +- src/Language/Haskell/Liquid/Types/PredType.hs | 10 +- .../Haskell/Liquid/Types/PrettyPrint.hs | 8 +- src/Language/Haskell/Liquid/Types/RefType.hs | 2 +- src/Language/Haskell/Liquid/Types/Types.hs | 6 +- src/Language/Haskell/Liquid/UX/CTags.hs | 2 +- 17 files changed, 253 insertions(+), 132 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 01c5e5d834..36d436f760 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -200,7 +200,7 @@ ghcSpecEnv sp = fromListSEnv binds -- -> Ghc.Ghc (SpecType, [F.Symbol]) -- binders for dictionaries -- -- should have returned Maybe [F.Symbol] -- elaborateSpecType bts coreToLogic t = --- case F.tracepp ("elaborateSpecType: " ++ F.showpp bts) t of +-- case F.notracepp ("elaborateSpecType: " ++ F.showpp bts) t of -- RVar (RTV tv) (MkUReft reft@(F.Reft(vv,_oldE)) p) -> do -- elaborateReft (reft, GM.showPpr tv) (pure (t, [])) -- (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv,ee)) p), bs')) @@ -279,14 +279,22 @@ makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc makeGhcSpec0 cfg src lmap mspecs = do -- liftIO $ mapM_ (putStrLn . F.showpp) (val.snd<$>gsTySigs sig) -- liftIO $ mapM_ (mapReftM (\(MkUReft (F.Reft (vv,r)) _) -> putStrLn$(F.symbolSafeString vv ++ ":" ++ toGhcExpr r))) (val.snd<$> gsTySigs sig) - -- let sigs = val.snd <$> + -- let sigs = val.mapsnd <$> -- [(x,y) | (x,y) <- gsTySigs sig, ("VerifiedMonad" `L.isPrefixOf` GM.showPpr x )] :: [SpecType] - let sigs = val.snd <$> gsTySigs sig - elaboratedSigs <- mapM (elaborateSpecType (pure ()) coreToLg) sigs - liftIO $ putStrLn "Before:" - liftIO $ putStrLn $ F.showpp sigs - liftIO $ putStrLn "After:" - liftIO $ putStrLn $ F.showpp elaboratedSigs + -- let sigs = val.snd <$> gsTySigs sig + sigs' <- forM + [(x,y) | (x,y) <- gsTySigs sig] $ \(x,locSpec) -> do + locSpec' <- traverse (elaborateSpecType (pure ()) coreToLg) locSpec + pure (x, fst <$> locSpec') + + -- liftIO $ mapM_ (mapReftM (\(MkUReft (F.Reft (vv,r)) _) -> putStrLn$(F.symbolSafeString vv ++ ":" ++ show r))) (val.snd <$> sigs') + + + -- elaboratedSigs <- mapM (elaborateSpecType (pure ()) coreToLg) sigs + -- liftIO $ putStrLn "Before:" + -- liftIO $ putStrLn $ F.showpp sigs' + -- liftIO $ putStrLn "After:" + -- liftIO $ putStrLn $ F.showpp sigs -- liftIO $ putStrLn "[DUMPING toType]" -- liftIO $ mapM_ (putStrLn . GM.showPpr . Ghc.typeToLHsType) (toType <$> sigs) @@ -304,7 +312,7 @@ makeGhcSpec0 cfg src lmap mspecs = do pure $ SP { gsConfig = cfg , gsImps = makeImports mspecs - , gsSig = addReflSigs refl sig + , gsSig = addReflSigs refl sig {gsTySigs = sigs'} , gsRefl = refl , gsLaws = laws , gsData = sData @@ -320,7 +328,7 @@ makeGhcSpec0 cfg src lmap mspecs = do } where -- build up spec components - coreToLg = \e -> case CoreToLogic.runToLogic embs lmap dm + coreToLg e = case CoreToLogic.runToLogic embs lmap dm (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e) of Left _ -> impossible Nothing "can't reach here" Right e -> e @@ -484,7 +492,7 @@ makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual } where quals = concatMap (makeQualifiers env tycEnv) (M.toList specs) - -- mSyms = F.tracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv) + -- mSyms = F.notracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv) okQual q = F.notracepp ("okQual: " ++ F.showpp q) $ all (`S.member` mSyms) (F.syms q) mSyms = F.notracepp "MSYMS" . S.fromList @@ -981,7 +989,7 @@ makeSpecName env tycEnv measEnv name = SpNames where datacons, cls :: [DataConP] datacons = Bare.tcDataCons tycEnv - cls = F.tracepp "meClasses" $ Bare.meClasses measEnv + cls = F.notracepp "meClasses" $ Bare.meClasses measEnv tycons = Bare.tcTyCons tycEnv @@ -1006,8 +1014,8 @@ makeTycEnv cfg myName env embs mySpec iSpecs = Bare.TycEnv specs = (myName, mySpec) : M.toList iSpecs tcs = Misc.snd3 <$> tcDds tyi = Bare.qualifyTopDummy env myName (makeTyConInfo embs fiTcs tycons) - -- tycons = F.tracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons - -- datacons = Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.tracepp "DATACONS" $ concat dcs) wiredDataCons) + -- tycons = F.notracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons + -- datacons = Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.notracepp "DATACONS" $ concat dcs) wiredDataCons) tycons = tcs ++ knownWiredTyCons env myName datacons = Bare.makePluggedDataCon embs tyi <$> (concat dcs ++ knownWiredDataCons env myName) tds = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds] diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 7f60eeb6af..65d2625093 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -130,7 +130,7 @@ makeFamInstEmbeds cs0 embs = L.foldl' embed embs famInstSorts {- famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type famInstTyConType c = case Ghc.tyConFamInst_maybe c of - Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) + Just (c', ts) -> F.notracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) $ Just (famInstType (Ghc.tyConArity c) c' ts) Nothing -> Nothing @@ -533,7 +533,7 @@ ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataCo res' = Bare.ofBareType env name l (Just ps) <$> res t0' = dataConResultTy c' αs t0 res' _cfg = getConfig env - (yts, ot) = -- F.tracepp ("dataConTys: " ++ F.showpp (c, αs)) $ + (yts, ot) = -- F.notracepp ("dataConTys: " ++ F.showpp (c, αs)) $ F.notracepp "OHQO2" $ qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') zts = zipWith (normalizeField c') [1..] (reverse yts) usedTvs = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts')) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 8ea0c9af6a..73cb152c48 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -18,6 +18,8 @@ import qualified Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType import qualified Data.List as L +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import Language.Haskell.Liquid.Types.Errors import Control.Monad.Free import Data.Functor.Foldable @@ -39,7 +41,9 @@ import GhcMonad import TcSimplify import PrelNames import Outputable hiding ( panic ) -import TysWiredIn ( boolTyCon ) +import TysWiredIn ( boolTyCon + , true_RDR + ) import HscTypes import ErrUtils import HscMain @@ -50,6 +54,7 @@ import TysWiredIn import BasicTypes import PrelNames import Data.Default ( def ) +import qualified Data.Maybe as Mb -- | Base functor of RType @@ -136,7 +141,7 @@ type RTPropF c tv f = Ref (RType c tv ()) f -- for this use case type SpecTypeF = RTypeF RTyCon RTyVar RReft -type PartialSpecType = Free (RTypeF RTyCon RTyVar RReft) () +type PartialSpecType = Free SpecTypeF () type instance Base (RType c tv r) = RTypeF c tv r @@ -189,20 +194,54 @@ plugType t = refix . f -- build the expression we send to ghc for elaboration -- YL: tweak this function to see if ghc accepts explicit dictionary binders -buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs +-- returning both expression since ghc adds unique id to the expressions +buildHsExpr :: LHsExpr GhcPs -> SpecType -> (LHsExpr GhcPs, [F.Symbol]) buildHsExpr res = para $ \case - RFunF bind (tin, _) (_, res) _ - | isClassType tin -> res - | otherwise -> mkHsLam [nlVarPat (symbolToRdrName varName bind)] res - RImpFF bind (tin, _) (_, res) _ - | isClassType tin -> res - | otherwise -> mkHsLam [nlVarPat (symbolToRdrName varName bind)] res + RFunF bind (tin, _) (_, bres@(res, bs)) _ + | isClassType tin + -> bres + | otherwise + -> (mkHsLam [nlVarPat (symbolToRdrName varName bind)] res, bind : bs) + RImpFF bind (tin, _) (_, bres@(res, bs)) _ + | isClassType tin + -> bres + | otherwise + -> (mkHsLam [nlVarPat (symbolToRdrName varName bind)] res, bind : bs) RAllEF _ _ (_, res) -> res RAllTF _ (_, res) _ -> res RExF _ _ (_, res) -> res RAppTyF _ (_, res) _ -> res RRTyF _ _ _ (_, res) -> res - _ -> res + _ -> (res, []) + +-- _:Semigroup a -> {x:a | x <> x == x} -> {y:a | y <> x == x <> y} -> {} +-- in gives [dict0] +-- out gives [dict1] + +-- I wish there's a way to make this function polymorphic wrt to +-- tuples. microlens's Each seems to do exactly what I want.. +-- buildDictBinderSubst :: [[F.Symbol]] -> Maybe _ +-- bulidDictBinderSubst dbss = +-- case L.filter (not . null) dbss of +-- [] -> Nothing +-- [_] -> Nothing +-- (dbs:dbss') -> Just $ +-- buildSubst $ zip dbs (L.transpose dbss') +-- where buildSubst + +renameDictBinder :: (F.Subable a) => [F.Symbol] -> [F.Symbol] -> a -> a +renameDictBinder [] _ = id +renameDictBinder _ [] = id +renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl + where tbl = F.tracepp "TBL" $ M.fromList (zip ds canonicalDs) + + +canonicalizeDictBinder :: F.Subable a => [F.Symbol] -> [F.Symbol] -> a -> (a,[F.Symbol]) +canonicalizeDictBinder [] bs' e' = (e',bs') +canonicalizeDictBinder bs [] e' = (e',bs) +canonicalizeDictBinder bs bs' e' = (renameDictBinder bs bs' e', bs) + + elaborateSpecType :: PartialSpecType @@ -216,48 +255,97 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t (reft, t) (pure (t, [])) (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs')) + -- YL : Fix RFun bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do -- the reft is never actually used by the child -- maybe i should enforce this information at the type level let partialFunTp = Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs' ) <- elaborateSpecType partialTp' coreToLogic tin - (eTout, bs'') <- elaborateSpecType partialTp' coreToLogic tout - -- eTin and eTout might have different dictionary names - -- need to do a substitution to make the reference to dictionaries consistent - -- if isClassType eTin - elaborateReft - (reft, t) - (pure (RFun bind eTin eTout ureft, bs')) - (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv, ee)) p), bs') - ) + (eTin , bs ) <- elaborateSpecType partialTp coreToLogic tin + (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + let + buildRFunContTrivial + | isClassType tin, dictBinder : bs0' <- bs' = do + let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs0' eTout + pure + ( F.notracepp "RFunTrivial0" $ RFun dictBinder + eTin + eToutRenamed + ureft + , canonicalBinders + ) + | otherwise = do + let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout + pure + ( F.notracepp "RFunTrivial1" $ RFun bind eTin eToutRenamed ureft + , canonicalBinders + ) + buildRFunCont bs'' ee + | isClassType tin, dictBinder : bs0' <- bs' = do + let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs0' eTout + eeRenamed = renameDictBinder canonicalBinders bs'' ee + pure + ( RFun dictBinder + eTin + eToutRenamed + (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders + ) + | otherwise = do + let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout + eeRenamed = renameDictBinder canonicalBinders bs'' ee + pure + ( RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders + ) + elaborateReft (reft, t) + buildRFunContTrivial + buildRFunCont + + -- (\bs' ee | isClassType tin -> do + -- let eeRenamed = renameDictBinder canonicalBinders bs' ee + -- pure (RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), bs') + -- ) + -- YL: implicit dictionary param doesn't seem possible.. RImpF bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do let partialFunTp = Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs' ) <- elaborateSpecType partialTp' coreToLogic tin - (eTout, bs'') <- elaborateSpecType partialTp' coreToLogic tout + (eTin , bs ) <- elaborateSpecType partialTp' coreToLogic tin + (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout + -- eTin and eTout might have different dictionary names -- need to do a substitution to make the reference to dictionaries consistent -- if isClassType eTin elaborateReft (reft, t) - (pure (RImpF bind eTin eTout ureft, bs')) - (\bs' ee -> - pure (RImpF bind eTin eTout (MkUReft (F.Reft (vv, ee)) p), bs') + (pure (RImpF bind eTin eToutRenamed ureft, canonicalBinders)) + (\bs'' ee -> do + let eeRenamed = renameDictBinder canonicalBinders bs'' ee + pure (RImpF bind eTin eTout (MkUReft (F.Reft (vv, eeRenamed)) p), bs') ) -- support for RankNTypes/ref - RAllT (RTVar tv ty) tout ref -> do - (eTout, bts') <- elaborateSpecType - (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ref)) + RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do + (eTout, bs) <- elaborateSpecType + (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft)) coreToLogic tout - pure (RAllT (RTVar tv ty) eTout ref, bts') + elaborateReft + (ref, RVar tv mempty) + (pure (RAllT (RTVar tv ty) eTout ureft, bs)) + (\bs' ee -> + let (eeRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' ee in + pure (RAllT (RTVar tv ty) eTout (MkUReft (F.Reft (vv, eeRenamed)) p), canonicalBinders) + ) + -- pure (RAllT (RTVar tv ty) eTout ref, bts') + -- todo: might as well print an error message? RAllP pvbind tout -> do - (eTout, bts') <- elaborateSpecType (partialTp >> Free (RAllPF pvbind (pure ()))) - coreToLogic - tout + (eTout, bts') <- elaborateSpecType + (partialTp >> Free (RAllPF pvbind (pure ()))) + coreToLogic + tout pure (RAllP pvbind eTout, bts') -- pargs not handled for now -- RApp tycon args pargs reft @@ -270,39 +358,50 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') ) RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do - (eArg, bs' ) <- elaborateSpecType partialTp coreToLogic arg - (eRes, bs'') <- elaborateSpecType partialTp coreToLogic res + (eArg, bs ) <- elaborateSpecType partialTp coreToLogic arg + (eRes, bs') <- elaborateSpecType partialTp coreToLogic res + let (eResRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eRes elaborateReft (reft, t) - (pure (RAppTy eArg eRes ureft, bs'')) - (\bs' ee -> pure (RAppTy eArg eRes (MkUReft (F.Reft (vv, ee)) p), bs'')) - RAllE _ _ _ -> todo Nothing ("Not sure how to elaborate RAllE" ++ F.showpp t) - REx _ _ _ -> todo Nothing ("Not sure how to elaborate REx" ++ F.showpp t) - RExprArg _ -> - todo Nothing ("Not sure how to elaborate RExprArg" ++ F.showpp t) + (pure (RAppTy eArg eResRenamed ureft, canonicalBinders)) + (\bs'' ee -> + let eeRenamed = renameDictBinder canonicalBinders bs'' ee in + pure (RAppTy eArg eResRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), canonicalBinders)) + RAllE bind allarg ty -> do + (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + pure (RAllE bind eAllarg eTy, bs) + REx bind allarg ty -> do + (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + pure (RAllE bind eAllarg eTy, bs) + -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard + -- in the future + RExprArg _ -> impossible Nothing "RExprArg should not appear here" + RHole _ -> impossible Nothing "RHole should not appear here" RRTy _ _ _ _ -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t) - _ -> todo Nothing ("Not sure how to elaborate " ++ F.showpp t) where boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType elaborateReft - :: (F.Reft, SpecType) -> Ghc a -> ([F.Symbol] -> F.Expr -> Ghc a) -> Ghc a + :: (F.PPrint a) => (F.Reft, SpecType) -> Ghc a -> ([F.Symbol] -> F.Expr -> Ghc a) -> Ghc a elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont = if isTrivial reft then trivial else do -- liftIO $ putStrLn query - let querySpecType = - plugType (rFun vv vvTy boolType) partialTp :: SpecType - hsExpr = - buildHsExpr - ( - fixExprToHsExpr e - ) - querySpecType :: LHsExpr GhcPs - exprWithTySigs = - GM.tracePpr "exprWithTySigs" $ noLoc $ ExprWithTySig - (mkLHsSigWcType $ specTypeToLHsType (F.tracepp "querySpecType" querySpecType)) - hsExpr :: LHsExpr GhcPs + let + querySpecType = + plugType (rFun vv vvTy boolType) partialTp :: SpecType + (hsExpr, origBinders) = + buildHsExpr (fixExprToHsExpr e) querySpecType :: ( LHsExpr GhcPs + , [F.Symbol] + ) + exprWithTySigs = + GM.notracePpr "exprWithTySigs" $ noLoc $ ExprWithTySig + ( mkLHsSigWcType + $ specTypeToLHsType (F.notracepp "querySpecType" querySpecType) + ) + hsExpr :: LHsExpr GhcPs (msgs, mbExpr) <- GM.elaborateHsExprInst exprWithTySigs case mbExpr of Nothing -> panic @@ -313,19 +412,33 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t ++ GM.showPpr (GM.showSDoc <$> pprErrMsgBagWithLoc (snd msgs)) ) Just eeWithLamsCore -> do - let eeWithLams = - coreToLogic (GM.tracePpr "eeWithLamsCore" eeWithLamsCore) - (bs', ee) = F.tracepp "grabLams" $ grabLams ([], eeWithLams) - nonTrivialCont (GM.dropModuleUnique <$> bs') - (dropBinderUnique bs' ee) + let + eeWithLams = + coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore) + (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams) + (dictbs, nondictbs) = + L.partition (F.isPrefixOfSym (F.symbol "$d")) bs' + -- invariant: length nondictbs == length origBinders + subst = if length nondictbs == length origBinders + then F.notracepp "SUBST" $ zip (L.reverse nondictbs) origBinders + else panic + Nothing + "Oops, Ghc gave back more/less binders than I expected" + ret <- nonTrivialCont + dictbs + (F.notracepp "nonTrivialContEE" $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) ee) -- (GM.dropModuleUnique <$> bs') + pure (F.notracepp "result" ret) + -- (F.substa ) isTrivial :: F.Reft -> Bool - isTrivial (F.Reft (_, ee)) = (L.null . F.syms) ee + isTrivial (F.Reft (_, F.PTrue)) = True + isTrivial _ = False + grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr) grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e) grabLams bse = bse - dropBinderUnique :: [F.Symbol] -> F.Expr -> F.Expr - dropBinderUnique binders = F.tracepp "ElaboratedExpr" - . F.substa (\x -> if L.elem x binders then GM.dropModuleUnique x else x) + -- dropBinderUnique :: [F.Symbol] -> F.Expr -> F.Expr + -- dropBinderUnique binders = F.notracepp "ElaboratedExpr" + -- . F.substa (\x -> if L.elem x binders then GM.dropModuleUnique x else x) @@ -357,13 +470,10 @@ fixExprToHsExpr (F.EIte p e0 e1) = noLoc (fixExprToHsExpr e1) ) -- FIXME: convert sort to HsType -fixExprToHsExpr (F.ECst e0 _) = fixExprToHsExpr e0 -fixExprToHsExpr (F.PAnd es ) = noLoc - (HsApp - NoExt - (noLoc (HsVar NoExt (noLoc (varQual_RDR dATA_FOLDABLE (fsLit "and"))))) - (noLoc (ExplicitList NoExt Nothing (fixExprToHsExpr <$> es))) - ) +fixExprToHsExpr (F.ECst e0 _ ) = fixExprToHsExpr e0 +fixExprToHsExpr (F.PAnd [] ) = nlHsVar true_RDR +fixExprToHsExpr (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr e) es + where f x acc = mkHsApp (mkHsApp (nlHsVar and_RDR) (fixExprToHsExpr x)) acc fixExprToHsExpr (F.POr es) = noLoc (HsApp NoExt @@ -433,19 +543,14 @@ symbolToRdrName ns x where (modName, s) = GM.splitModuleName x --- SpecType -> LHsType --- SpecTypeF LHsType -> LHsType --- SpecType -> SpectypeF --- distPara :: Corecursive t => Base t (t, a) -> (t, Base t a) --- SpecTypeF ((t,) SpecType) -> (t,) (SpecTypeF SpecType) specTypeToLHsType :: SpecType -> LHsType GhcPs --- surprised that the type annotaiton is necessary +-- surprised that the type application is necessary specTypeToLHsType = flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case - RVarF (RTV tv) _ -> nlHsTyVar (getRdrName tv) - RFunF _ (tin, tin') (_, tout) _ + RVarF (RTV tv) _ -> nlHsTyVar (getRdrName tv) + RFunF _ (tin, tin') (_, tout) _ | isClassType tin -> noLoc $ HsQualTy NoExt (noLoc [tin']) tout - | otherwise -> nlHsFunTy tin' tout + | otherwise -> nlHsFunTy tin' tout RImpFF _ (_, tin) (_, tout) _ -> nlHsFunTy tin tout RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> noLoc $ HsForAllTy NoExt (userHsTyVarBndrs noSrcSpan [getRdrName tv]) t @@ -460,9 +565,10 @@ specTypeToLHsType = RExF _ _ (_, t) -> t RAppTyF (_, t) (RExprArg _, _ ) _ -> t RAppTyF (_, t) (_ , t') _ -> nlHsAppTy t t' - RRTyF _ _ _ (_, t) -> t - RHoleF _ -> noLoc $ HsWildCardTy NoExt - RExprArgF _ -> todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg" + RRTyF _ _ _ (_, t) -> t + RHoleF _ -> noLoc $ HsWildCardTy NoExt + RExprArgF _ -> + todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg" diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs index a478ba3c4d..13d8bf8a5d 100644 --- a/src/Language/Haskell/Liquid/Bare/Measure.hs +++ b/src/Language/Haskell/Liquid/Bare/Measure.hs @@ -151,11 +151,11 @@ makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon] -------------------------------------------------------------------------------- makeHaskellDataDecls cfg name spec tcs | exactDCFlag cfg = Mb.mapMaybe tyConDataDecl - -- . F.tracepp "makeHaskellDataDecls-3" + -- . F.notracepp "makeHaskellDataDecls-3" . zipMap (hasDataDecl name spec . fst) - -- . F.tracepp "makeHaskellDataDecls-2" + -- . F.notracepp "makeHaskellDataDecls-2" . liftableTyCons - -- . F.tracepp "makeHaskellDataDecls-1" + -- . F.notracepp "makeHaskellDataDecls-1" . filter isReflectableTyCon $ tcs | otherwise = [] @@ -172,7 +172,7 @@ liftableTyCons . filter (not . Ghc.isBoxedTupleTyCon) . F.notracepp "LiftableTCs 1" -- . (`sortDiff` wiredInTyCons) - -- . F.tracepp "LiftableTCs 0" + -- . F.notracepp "LiftableTCs 0" zipMap :: (a -> b) -> [a] -> [(a, b)] zipMap f xs = zip xs (map f xs) @@ -284,7 +284,7 @@ dataConSel dc n Check = mkArrow (zip as (repeat mempty)) [] [] [xt] bareBool dataConSel dc n (Proj i) = mkArrow (zip as (repeat mempty)) [] [] [xt] (mempty <$> ti) where ti = Mb.fromMaybe err $ Misc.getNth (i-1) ts - (as, ts, xt) = {- F.tracepp ("bkDatacon dc = " ++ F.showpp (dc, n)) $ -} bkDataCon dc n + (as, ts, xt) = {- F.notracepp ("bkDatacon dc = " ++ F.showpp (dc, n)) $ -} bkDataCon dc n err = panic Nothing $ "DataCon " ++ show dc ++ "does not have " ++ show i ++ " fields" -- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft)) diff --git a/src/Language/Haskell/Liquid/Bare/ToBare.hs b/src/Language/Haskell/Liquid/Bare/ToBare.hs index 99a595cf49..5bca2cab3c 100644 --- a/src/Language/Haskell/Liquid/Bare/ToBare.hs +++ b/src/Language/Haskell/Liquid/Bare/ToBare.hs @@ -25,7 +25,7 @@ specToBare :: SpecType -> BareType -------------------------------------------------------------------------------- specToBare = txRType specToBareTC specToBareTV --- specToBare t = F.tracepp ("specToBare t2 = " ++ F.showpp t2) t1 +-- specToBare t = F.notracepp ("specToBare t2 = " ++ F.showpp t2) t1 -- where -- t1 = bareOfType . toType $ t -- t2 = _specToBare t diff --git a/src/Language/Haskell/Liquid/Constraint/Fresh.hs b/src/Language/Haskell/Liquid/Constraint/Fresh.hs index db7ee7360a..f436f98ef8 100644 --- a/src/Language/Haskell/Liquid/Constraint/Fresh.hs +++ b/src/Language/Haskell/Liquid/Constraint/Fresh.hs @@ -80,7 +80,7 @@ freshTy_expr k e _ = freshTy_reftype k $ exprRefType e freshTy_reftype :: KVKind -> SpecType -> CG SpecType freshTy_reftype k _t = (fixTy t >>= refresh) =>> addKVars k where - t = {- F.tracepp ("freshTy_reftype:" ++ show k) -} _t + t = {- F.notracepp ("freshTy_reftype:" ++ show k) -} _t -- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive -- definitions, and also to update the KVar profile. @@ -103,7 +103,7 @@ addKuts _x t = modify $ \s -> s { kuts = mappend (F.KS ks) (kuts s) } ks' = S.fromList $ specTypeKVars t ks | S.null ks' = ks' - | otherwise = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks' + | otherwise = {- F.notracepp ("addKuts: " ++ showpp _x) -} ks' specTypeKVars :: SpecType -> [F.KVar] specTypeKVars = foldReft (\ _ r ks -> (kvars $ ur_reft r) ++ ks) [] diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index 81719966b1..2080a50fd7 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -1332,7 +1332,7 @@ varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType -------------------------------------------------------------------------------- varRefType γ x = do xt <- varRefType' γ x <$> (γ ??= x) - return xt -- F.tracepp (printf "varRefType x = [%s]" (showpp x)) + return xt -- F.notracepp (printf "varRefType x = [%s]" (showpp x)) varRefType' :: CGEnv -> Var -> SpecType -> SpecType varRefType' γ x t' @@ -1451,7 +1451,7 @@ isGeneric γ α t = isGenericVar α t && not (isPLETerm γ) -- | @isPLETerm γ@ returns @True@ if the "currrent" top-level binder in γ has PLE enabled. isPLETerm :: CGEnv -> Bool isPLETerm γ - | Just x <- cgVar γ = {- F.tracepp ("isPLEVar:" ++ F.showpp x) $ -} isPLEVar (giSpec . cgInfo $ γ) x + | Just x <- cgVar γ = {- F.notracepp ("isPLEVar:" ++ F.showpp x) $ -} isPLEVar (giSpec . cgInfo $ γ) x | otherwise = False -- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs index 54c04759cc..6eb8cc945c 100644 --- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -86,11 +86,11 @@ makeAxiomEnvironment info xts fcs sp = giSpec info _isClassOrDict :: Id -> Bool -_isClassOrDict x = F.tracepp ("isClassOrDict: " ++ F.showpp x) +_isClassOrDict x = F.notracepp ("isClassOrDict: " ++ F.showpp x) $ (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x)) hasClassArg :: Id -> Bool -hasClassArg x = F.tracepp msg $ (GM.isDataConId x && any Ghc.isClassPred (t:ts)) +hasClassArg x = F.notracepp msg $ (GM.isDataConId x && any Ghc.isClassPred (t:ts)) where msg = "hasClassArg: " ++ showpp (x, t:ts) (ts, t) = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 2c271772e9..ee1cb69443 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -449,9 +449,6 @@ processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = d void $ execStmt "let {infix 4 ==; _ == _ = undefined}" execOptions - void $ execStmt - "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}" - execOptions void $ execStmt "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}" execOptions diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 7cc3d57a05..9d3db0048e 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -563,7 +563,7 @@ tyConTyVarsDef c | noTyVars c = [] | otherwise = TC.tyConTyVars c --where - -- none = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c) + -- none = notracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c) noTyVars :: TyCon -> Bool noTyVars c = (TC.isPrimTyCon c || isFunTyCon c || TC.isPromotedDataCon c) diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs index a59e1df039..4429328b70 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -383,7 +383,7 @@ toPredApp p = go . Misc.mapFst opSym . splitArgs $ p | f == symbol ("&&" :: String) = PAnd <$> mapM coreToLg [e1, e2] | f == symbol ("==>" :: String) - = F.tracepp "toPredApp" <$> (PImp <$> coreToLg e1 <*> coreToLg e2) + = F.notracepp "toPredApp" <$> (PImp <$> coreToLg e1 <*> coreToLg e2) go (Just f, es) | f == symbol ("or" :: String) = POr <$> mapM coreToLg es @@ -407,10 +407,20 @@ toLogicApp e = do makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr makeApp _ _ f [e] | val f == symbol ("GHC.Num.negate" :: String) = ENeg e + | val f == symbol ("GHC.Num.fromInteger" :: String) + , ECon c <- e + = ECon c + + makeApp _ _ f [e1, e2] | Just op <- M.lookup (val f) bops = EBin op e1 e2 +makeApp _ _ f [e1, e2] | (modName, sym) <- GM.splitModuleName (val f) + , symbol ("Ghci" :: String) `isPrefixOfSym` modName + , Just op <- M.lookup (mappendSym (symbol ("GHC.Num." :: String)) sym) bops + = EBin op e1 e2 + makeApp def lmap f es = eAppWithMap lmap f es def -- where msg = "makeApp f = " ++ show f ++ " es = " ++ show es ++ " def = " ++ show def @@ -524,7 +534,7 @@ isBangInteger [(C.DataAlt s, _, _), (C.DataAlt jp,_,_), (C.DataAlt jn,_,_)] isBangInteger _ = False isErasable :: Id -> Bool -isErasable v = F.tracepp msg $ isGhcSplId v && not (isDCId v) +isErasable v = F.tracepp msg $ False -- isGhcSplId v && not (isDCId v) where msg = "isErasable: " ++ GM.showPpr (v, Var.idDetails v) @@ -626,6 +636,6 @@ instance Simplify C.CoreBind where instance Simplify C.CoreAlt where simplify (c, xs, e) = (c, xs, simplify e) - -- where xs = F.tracepp _msg xs0 + -- where xs = F.notracepp _msg xs0 -- _msg = "isCoVars? " ++ F.showpp [(x, isCoVar x, varType x) | x <- xs0] inline p (c, xs, e) = (c, xs, inline p e) diff --git a/src/Language/Haskell/Liquid/Transforms/Rewrite.hs b/src/Language/Haskell/Liquid/Transforms/Rewrite.hs index 3fbde1964b..242494b19a 100644 --- a/src/Language/Haskell/Liquid/Transforms/Rewrite.hs +++ b/src/Language/Haskell/Liquid/Transforms/Rewrite.hs @@ -436,7 +436,7 @@ isVarTup xs e isVarTup _ _ = Nothing eqVars :: [Var] -> [Var] -> Bool -eqVars xs ys = {- F.tracepp ("eqVars: " ++ show xs' ++ show ys') -} xs' == ys' +eqVars xs ys = {- F.notracepp ("eqVars: " ++ show xs' ++ show ys') -} xs' == ys' where xs' = {- F.symbol -} show <$> xs ys' = {- F.symbol -} show <$> ys diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs index d90c5a034c..01f212d2db 100644 --- a/src/Language/Haskell/Liquid/Types/PredType.hs +++ b/src/Language/Haskell/Liquid/Types/PredType.hs @@ -107,9 +107,9 @@ dcWorkSpecType c wrT = fromRTypeRep (meetWorkWrapRep c wkR wrR) dataConWorkRep :: DataCon -> SpecRep dataConWorkRep c = toRTypeRep - -- . F.tracepp ("DCWR-2: " ++ F.showpp c) + -- . F.notracepp ("DCWR-2: " ++ F.showpp c) . ofType - -- . F.tracepp ("DCWR-1: " ++ F.showpp c) + -- . F.notracepp ("DCWR-1: " ++ F.showpp c) . dataConRepType -- . Var.varType -- . dataConWorkId @@ -126,7 +126,7 @@ dataConWorkRep dc = RTypeRep , ty_res = t' } where - (ts', t') = F.tracepp "DCWR-1" (ofType <$> ts, ofType t) + (ts', t') = F.notracepp "DCWR-1" (ofType <$> ts, ofType t) as = makeRTVar . rTyVar <$> αs tArg (αs,_,eqs,th,ts,t) = dataConFullSig dc @@ -158,7 +158,7 @@ meetWorkWrapRep c workR wrapR | otherwise = panic (Just (getSrcSpan c)) errMsg where - pad = {- F.tracepp ("MEETWKRAP: " ++ show (ty_vars workR)) $ -} workN - wrapN + pad = {- F.notracepp ("MEETWKRAP: " ++ show (ty_vars workR)) $ -} workN - wrapN (xs, _) = splitAt pad (ty_binds workR) (ts, ts') = splitAt pad (ty_args workR) workN = length (ty_args workR) @@ -170,7 +170,7 @@ strengthenRType wkT wrT = maybe wkT (strengthen wkT) (stripRTypeBase wrT) dcWrapSpecType :: DataCon -> DataConP -> SpecType dcWrapSpecType dc (DataConP _ _ vs ps cs yts rt _ _ _) - = {- F.tracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -} + = {- F.notracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -} mkArrow makeVars' ps [] ts' rt' where (xs, ts) = unzip (reverse yts) diff --git a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs index 714d8ea1af..6c22e2c942 100644 --- a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs +++ b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs @@ -324,19 +324,19 @@ brkFun out = ([], out) ppr_forall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc ppr_forall bb p t = maybeParen p funPrec $ sep [ ppr_foralls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep) - , ppr_clss cls + -- , ppr_clss [] , ppr_rtype bb topPrec t' ] where trep = toRTypeRep t - (cls, t') = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []} + (_,_, t') = bkUniv $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []} ppr_foralls False _ _ = empty ppr_foralls _ [] [] = empty ppr_foralls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot - ppr_clss [] = empty - ppr_clss cs = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>" + -- ppr_clss [] = empty + -- ppr_clss cs = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>" dαs αs = ppr_rtvar_def αs diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs index b1eae8f21f..6354967acf 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -890,7 +890,7 @@ famInstArgs c = case Ghc.tyConFamInst_maybe c of cArity = Ghc.tyConArity c -- TODO:faminst-preds: case Ghc.tyConFamInst_maybe c of --- TODO:faminst-preds: Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) +-- TODO:faminst-preds: Just (c', ts) -> F.notracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) -- TODO:faminst-preds: $ Just (famInstType (Ghc.tyConArity c) c' ts) -- TODO:faminst-preds: Nothing -> Nothing diff --git a/src/Language/Haskell/Liquid/Types/Types.hs b/src/Language/Haskell/Liquid/Types/Types.hs index 32f61ec947..b66f14e7dd 100644 --- a/src/Language/Haskell/Liquid/Types/Types.hs +++ b/src/Language/Haskell/Liquid/Types/Types.hs @@ -714,7 +714,7 @@ data RType c tv r | RAllE { rt_bind :: !Symbol , rt_allarg :: !(RType c tv r) - , rt_ty :: !(RType c tv r) + , rt_ty :: !(RType c tv r) -- bind goes here } | REx { @@ -733,9 +733,9 @@ data RType c tv r | RRTy { rt_env :: ![(Symbol, RType c tv r)] - , rt_ref :: !r + , rt_ref :: !r -- depends on env , rt_obl :: !Oblig - , rt_ty :: !(RType c tv r) + , rt_ty :: !(RType c tv r) -- does not depend on env } | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_` diff --git a/src/Language/Haskell/Liquid/UX/CTags.hs b/src/Language/Haskell/Liquid/UX/CTags.hs index e267679fab..40c52c5172 100644 --- a/src/Language/Haskell/Liquid/UX/CTags.hs +++ b/src/Language/Haskell/Liquid/UX/CTags.hs @@ -48,7 +48,7 @@ memTagEnv :: TagKey -> TagEnv -> Bool memTagEnv = M.member makeTagEnv :: [CoreBind] -> TagEnv -makeTagEnv = {- tracepp "TAGENV" . -} M.map (:[]) . callGraphRanks . makeCallGraph +makeTagEnv = {- notracepp "TAGENV" . -} M.map (:[]) . callGraphRanks . makeCallGraph -- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns From 4cf69983717028b03ff7fa899dc405d5d5779e71 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 8 Feb 2020 00:37:34 -0500 Subject: [PATCH 03/38] drop only dictionaries of type Eq, Ord, Numerical, and ~ --- src/Language/Haskell/Liquid/Bare/Axiom.hs | 2 +- .../Haskell/Liquid/Constraint/Generate.hs | 14 +++--- .../Haskell/Liquid/Constraint/Split.hs | 2 +- .../Haskell/Liquid/Constraint/ToFixpoint.hs | 2 +- src/Language/Haskell/Liquid/GHC/Misc.hs | 48 ++++++++++++++++++- src/Language/Haskell/Liquid/LawInstances.hs | 2 +- src/Language/Haskell/Liquid/Measure.hs | 2 +- .../Haskell/Liquid/Transforms/CoreToLogic.hs | 8 ++-- src/Language/Haskell/Liquid/Types/Fresh.hs | 4 +- src/Language/Haskell/Liquid/Types/RefType.hs | 2 +- src/Language/Haskell/Liquid/Types/Types.hs | 40 +++++++++++----- 11 files changed, 93 insertions(+), 33 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs index 6f966c509a..c415eb568e 100644 --- a/src/Language/Haskell/Liquid/Bare/Axiom.hs +++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs @@ -178,7 +178,7 @@ axiomType s t = AT to (reverse xts) res (to, (_,xts, Just res)) = runState (go t) (1,[], Nothing) go (RAllT a t r) = RAllT a <$> go t <*> return r go (RAllP p t) = RAllP p <$> go t - go (RFun x tx t r) | isClassType tx = (\t' -> RFun x tx t' r) <$> go t + go (RFun x tx t r) | isEmbeddedClass tx = (\t' -> RFun x tx t' r) <$> go t go (RFun x tx t r) = do (i,bs,res) <- get let x' = unDummy x i diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index aeeefbbad2..291f8ef086 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -318,7 +318,7 @@ consCBSizedTys γ xes let rts = (recType autoenv <$>) <$> xeets let xts = zip xs ts γ' <- foldM extender γ xts - let γs = zipWith makeRecInvariants [γ' `setTRec` zip xs rts' | rts' <- rts] (filter (not . GM.isPredVar) <$> vs) + let γs = zipWith makeRecInvariants [γ' `setTRec` zip xs rts' | rts' <- rts] (filter (not . GM.isEmbeddedDictVar) <$> vs) let xets' = zip3 xs es ts mapM_ (uncurry $ consBind True) (zip γs xets') return γ' @@ -724,7 +724,7 @@ splitConstraints :: TyConable c => RType c tv r -> ([[(F.Symbol, RType c tv r)]], RType c tv r) splitConstraints (RRTy cs _ OCons t) = let (css, t') = splitConstraints t in (cs:css, t') -splitConstraints (RFun x tx@(RApp c _ _ _) t r) | isClass c +splitConstraints (RFun x tx@(RApp c _ _ _) t r) | isEmbeddedDict c = let (css, t') = splitConstraints t in (css, RFun x tx t' r) splitConstraints t = ([], t) @@ -1122,7 +1122,7 @@ dropExists γ (REx x tx t) = (, t) <$> γ += ("dropExists", x, tx) dropExists γ t = return (γ, t) dropConstraints :: CGEnv -> SpecType -> CG SpecType -dropConstraints γ (RFun x tx@(RApp c _ _ _) t r) | isClass c +dropConstraints γ (RFun x tx@(RApp c _ _ _) t r) | isEmbeddedDict c = (flip (RFun x tx)) r <$> dropConstraints γ t dropConstraints γ (RRTy cts _ OCons t) = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts @@ -1161,7 +1161,7 @@ caseEnv γ x _ (DataAlt c) ys pIs = do tdc <- (γ ??= (dataConWorkId c) >>= refreshVV) let (rtd,yts',_) = unfoldR tdc xt ys yts <- projectTypes pIs yts' - let ys'' = F.symbol <$> filter (not . GM.isPredVar) ys + let ys'' = F.symbol <$> filter (not . GM.isEmbeddedDictVar) ys let r1 = dataConReft c ys'' let r2 = dataConMsReft rtd ys'' let xt = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2)) @@ -1305,7 +1305,7 @@ lamExpr γ (Lit c) = snd $ literalConst (emb γ) c lamExpr γ (Tick _ e) = lamExpr γ e lamExpr γ (App e (Type _)) = lamExpr γ e lamExpr γ (App e1 e2) = case (lamExpr γ e1, lamExpr γ e2) of - (Just p1, Just p2) | not (GM.isPredExpr e2) -- (isClassPred $ exprType e2) + (Just p1, Just p2) | not (GM.isEmbeddedDictExpr e2) -- (isClassPred $ exprType e2) -> Just $ F.EApp p1 p2 (Just p1, Just _ ) -> Just p1 _ -> Nothing @@ -1357,7 +1357,7 @@ makeSingleton γ e t | higherOrderFlag γ, App f x <- simplify e = case (funExpr γ f, argForAllExpr x) of (Just f', Just x') - | not (GM.isPredExpr x) -- (isClassPred $ exprType x) + | not (GM.isEmbeddedDictExpr x) -- (isClassPred $ exprType x) -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x')) (Just f', Just _) -> strengthenMeet t (uTop $ F.exprReft f') @@ -1390,7 +1390,7 @@ funExpr γ (Var v) | S.member v (fargs γ) || GM.isDataConId v funExpr γ (App e1 e2) = case (funExpr γ e1, argExpr γ e2) of - (Just e1', Just e2') | not (GM.isPredExpr e2) -- (isClassPred $ exprType e2) + (Just e1', Just e2') | not (GM.isEmbeddedDictExpr e2) -- (isClassPred $ exprType e2) -> Just (F.EApp e1' e2') (Just e1', Just _) -> Just e1' diff --git a/src/Language/Haskell/Liquid/Constraint/Split.hs b/src/Language/Haskell/Liquid/Constraint/Split.hs index ce971bf37d..99fb282ed7 100644 --- a/src/Language/Haskell/Liquid/Constraint/Split.hs +++ b/src/Language/Haskell/Liquid/Constraint/Split.hs @@ -249,7 +249,7 @@ splitC (SubC γ t1'@(RAllT α1 t1 _) t2'@(RAllT α2 t2 _)) (Just (x1, _), Just (x2, _)) -> F.mkSubst [(x1, F.EVar x2)] _ -> F.mkSubst [] -splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2 +splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isEmbeddedDict c1 && c1 == c2 = return [] splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)) diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs index bf26ce94c3..3ddc506df9 100644 --- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -184,7 +184,7 @@ specTypeToLogic es e t su = F.mkSubst $ zip xs es - (cls, nocls) = L.partition (isClassType.snd) $ zip (ty_binds trep) (ty_args trep) + (cls, nocls) = L.partition (isEmbeddedClass.snd) $ zip (ty_binds trep) (ty_args trep) :: ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)]) (xs, ts) = unzip nocls :: ([F.Symbol], [SpecType]) diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 7bef43171a..f71de9332b 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -19,7 +19,7 @@ module Language.Haskell.Liquid.GHC.Misc where import Class (classKey) import Data.String import qualified Data.List as L -import PrelNames (fractionalClassKeys) +import PrelNames (fractionalClassKeys, itName, ordClassKey, numericClassKeys, eqClassKey) import FamInstEnv import Debug.Trace -- import qualified ConLike as Ghc @@ -56,7 +56,7 @@ import TcRnDriver import RdrName -import Type (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind) +import Type (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind, tyConAppTyCon_maybe) import TyCoRep import Var import IdInfo @@ -219,6 +219,9 @@ unTickExpr x = x isFractionalClass :: Class -> Bool isFractionalClass clas = classKey clas `elem` fractionalClassKeys +isOrdClass :: Class -> Bool +isOrdClass clas = classKey clas == ordClassKey + -------------------------------------------------------------------------------- -- | Pretty Printers ----------------------------------------------------------- -------------------------------------------------------------------------------- @@ -802,6 +805,47 @@ binders (Rec xes) = fst <$> xes expandVarType :: Var -> Type expandVarType = expandTypeSynonyms . varType + +-------------------------------------------------------------------------------- +-- | The following functions test if a `CoreExpr` or `CoreVar` can be +-- embedded in logic. With type-class support, we can no longer erase +-- such expressions arbitrarily. +-------------------------------------------------------------------------------- +isEmbeddedDictExpr :: CoreExpr -> Bool +isEmbeddedDictExpr = isEmbeddedDictType . CoreUtils.exprType + +isEmbeddedDictVar :: Var -> Bool +isEmbeddedDictVar v = F.notracepp msg . isEmbeddedDictType . varType $ v + where + msg = "isGoodCaseBind v = " ++ show v + +isEmbeddedDictType :: Type -> Bool +isEmbeddedDictType = anyF [isOrdPred, isNumericPred, isEqPred, isPrelEqPred] + +-- unlike isNumCls, isFracCls, these two don't check if the argument's +-- superclass is Ord or Num. I believe this is the more predictable behavior + +isPrelEqPred :: Type -> Bool +isPrelEqPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> isPrelEqTyCon tyCon + _ -> False + + +isPrelEqTyCon :: TyCon -> Bool +isPrelEqTyCon tc = tc `hasKey` eqClassKey + +isOrdPred :: Type -> Bool +isOrdPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> tyCon `hasKey` ordClassKey + _ -> False + +-- Not just Num, but Fractional, Integral as well +isNumericPred :: Type -> Bool +isNumericPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> getUnique tyCon `elem` numericClassKeys + _ -> False + + -------------------------------------------------------------------------------- -- | The following functions test if a `CoreExpr` or `CoreVar` are just types -- in disguise, e.g. have `PredType` (in the GHC sense of the word), and so diff --git a/src/Language/Haskell/Liquid/LawInstances.hs b/src/Language/Haskell/Liquid/LawInstances.hs index f01a877bee..071bdc4244 100644 --- a/src/Language/Haskell/Liquid/LawInstances.hs +++ b/src/Language/Haskell/Liquid/LawInstances.hs @@ -90,6 +90,6 @@ splitTypeConstraints :: [(F.Symbol, SpecType)] -> ([(F.Symbol, SpecType)], [(F.S splitTypeConstraints = go [] where go cs (b@(_x, RApp c _ _ _):ts) - | isClass c + | isEmbeddedDict c = go (b:cs) ts go cs r = (reverse cs, map (\(x, t) -> (x, shiftVV t x)) r) diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs index 2e8a67a580..1dbe95df88 100644 --- a/src/Language/Haskell/Liquid/Measure.hs +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -261,7 +261,7 @@ mapArgumens lc t1 t2 = go xts1' xts2' xts1' = dropWhile canDrop xts1 xts2' = dropWhile canDrop xts2 - canDrop (_, t) = isClassType t || isEqType t + canDrop (_, t) = isEmbeddedClass t go xs ys | length xs == length ys && and (zipWith (==) (toRSort . snd <$> xts1') (toRSort . snd <$> xts2')) diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs index 0a7f26a8b2..d47ed04028 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -63,7 +63,7 @@ logicType :: (Reftable r) => Type -> RRType r logicType τ = fromRTypeRep $ t { ty_binds = bs, ty_args = as, ty_refts = rs} where t = toRTypeRep $ ofType τ - (bs, as, rs) = unzip3 $ dropWhile (isClassType . Misc.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t) + (bs, as, rs) = unzip3 $ dropWhile (isEmbeddedClass . Misc.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t) {- | [NOTE:inlineSpecType type]: the refinement depends on whether the result type is a Bool or not: CASE1: measure f@logic :: X -> Bool <=> f@haskell :: x:X -> {v:Bool | v <=> (f@logic x)} @@ -77,7 +77,7 @@ inlineSpecType v = fromRTypeRep $ rep {ty_res = res `strengthen` r , ty_binds = rep = toRTypeRep t res = ty_res rep xs = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep] - vxs = dropWhile (isClassType . snd) $ zip xs (ty_args rep) + vxs = dropWhile (isEmbeddedClass . snd) $ zip xs (ty_args rep) f = dummyLoc (symbol v) t = ofType (GM.expandVarType v) :: SpecType mkA = EVar . fst @@ -104,7 +104,7 @@ measureSpecType v = go mkT [] [1..] t go f args i (RAllT a t r) = RAllT a (go f args i t) r go f args i (RAllP p t) = RAllP p $ go f args i t go f args i (RFun x t1 t2 r) - | isClassType t1 = RFun x t1 (go f args i t2) r + | isEmbeddedClass t1 = RFun x t1 (go f args i t2) r go f args i t@(RFun _ t1 t2 r) | hasRApps t = RFun x' t1 (go f (x':args) (tail i) t2) r where x' = intSymbol (symbol ("x" :: String)) (head i) @@ -127,7 +127,7 @@ weakenResult v t = F.notracepp msg t' rep = toRTypeRep t weaken x = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts vE = mkEApp vF xs - xs = EVar . fst <$> dropWhile (isClassType . snd) xts + xs = EVar . fst <$> dropWhile (isEmbeddedClass . snd) xts xts = zip (ty_binds rep) (ty_args rep) vF = dummyLoc (symbol v) diff --git a/src/Language/Haskell/Liquid/Types/Fresh.hs b/src/Language/Haskell/Liquid/Types/Fresh.hs index a28a2b1dd3..622773282d 100644 --- a/src/Language/Haskell/Liquid/Types/Fresh.hs +++ b/src/Language/Haskell/Liquid/Types/Fresh.hs @@ -91,7 +91,7 @@ trueRefType (RImpF _ t t' _) trueRefType (RFun _ t t' _) = rFun <$> fresh <*> true t <*> true t' -trueRefType (RApp c ts _ _) | isClass c +trueRefType (RApp c ts _ _) | isEmbeddedDict c = rRCls c <$> mapM true ts trueRefType (RApp c ts rs r) @@ -144,7 +144,7 @@ refreshRefType (RFun b t t' _) | b == F.dummySymbol = rFun <$> fresh <*> refresh t <*> refresh t' | otherwise = rFun b <$> refresh t <*> refresh t' -refreshRefType (RApp rc ts _ _) | isClass rc +refreshRefType (RApp rc ts _ _) | isEmbeddedDict rc = return $ rRCls rc ts refreshRefType (RApp rc ts rs r) diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs index 65f1244eee..efadeaaf5e 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -150,7 +150,7 @@ dataConArgs trep = unzip [ (x, t) | (x, t) <- zip xs ts, isValTy t] where xs = ty_binds trep ts = ty_args trep - isValTy = not . GM.isPredType . toType + isValTy = not . GM.isEmbeddedDictType . toType pdVar :: PVar t -> Predicate diff --git a/src/Language/Haskell/Liquid/Types/Types.hs b/src/Language/Haskell/Liquid/Types/Types.hs index 32f61ec947..8c5eedf850 100644 --- a/src/Language/Haskell/Liquid/Types/Types.hs +++ b/src/Language/Haskell/Liquid/Types/Types.hs @@ -52,7 +52,7 @@ module Language.Haskell.Liquid.Types.Types ( , rTyConPVs , rTyConPropVs -- , isClassRTyCon - , isClassType, isEqType, isRVar, isBool + , isClassType, isEqType, isRVar, isBool, isEmbeddedClass -- * Refinement Types , RType (..), Ref(..), RTProp, rPropP @@ -616,6 +616,11 @@ isClassType :: TyConable c => RType c t t1 -> Bool isClassType (RApp c _ _ _) = isClass c isClassType _ = False +isEmbeddedClass :: TyConable c => RType c t t1 -> Bool +isEmbeddedClass (RApp c _ _ _) = isEmbeddedDict c +isEmbeddedClass _ = False + + -- rTyConPVHPs = filter isHPropPV . rtc_pvars -- isHPropPV = not . isPropPV @@ -896,15 +901,20 @@ class (Eq c) => TyConable c where isTuple :: c -> Bool ppTycon :: c -> Doc isClass :: c -> Bool + isEmbeddedDict :: c -> Bool isEqual :: c -> Bool isNumCls :: c -> Bool isFracCls :: c -> Bool + isOrdCls :: c -> Bool + isEqCls :: c -> Bool - isClass = const False - isEqual = const False - isNumCls = const False - isFracCls = const False + isClass = const False + isEmbeddedDict c = isNumCls c || isEqual c || isOrdCls c || isEqCls c + isEqual = const False + isNumCls = const False + isFracCls = const False + isOrdCls = const False -- Should just make this a @Pretty@ instance but its too damn tedious @@ -929,10 +939,13 @@ instance TyConable RTyCon where isEqual = isEqual . rtc_tc ppTycon = F.toFix - isNumCls c = maybe False (isClassOrSubClass isNumericClass) + isNumCls c = maybe False isNumericClass + (tyConClass_maybe $ rtc_tc c) + isFracCls c = maybe False isFractionalClass (tyConClass_maybe $ rtc_tc c) - isFracCls c = maybe False (isClassOrSubClass isFractionalClass) + isOrdCls c = maybe False isOrdClass (tyConClass_maybe $ rtc_tc c) + isEqCls c = isEqCls (rtc_tc c) instance TyConable TyCon where @@ -943,10 +956,13 @@ instance TyConable TyCon where isEqual c = c == eqPrimTyCon || c == eqReprPrimTyCon ppTycon = text . showPpr - isNumCls c = maybe False (isClassOrSubClass isNumericClass) - (tyConClass_maybe $ c) - isFracCls c = maybe False (isClassOrSubClass isFractionalClass) - (tyConClass_maybe $ c) + isNumCls c = maybe False isNumericClass + (tyConClass_maybe c) + isFracCls c = maybe False isFractionalClass + (tyConClass_maybe c) + isOrdCls c = maybe False isOrdClass + (tyConClass_maybe c) + isEqCls c = isPrelEqTyCon c isClassOrSubClass :: (Class -> Bool) -> Class -> Bool @@ -1665,7 +1681,7 @@ efoldReft logicBind cb dty g f fp = go go γ z (RAllP p t) = go (fp p γ) z t go γ z (RImpF x t t' r) = go γ z (RFun x t t' r) go γ z me@(RFun _ (RApp c ts _ _) t' r) - | isClass c = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t') + | isEmbeddedDict c = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t') go γ z me@(RFun x t t' r) | logicBind x t = f γ (Just me) r (go γ' (go γ z t) t') | otherwise = f γ (Just me) r (go γ (go γ z t) t') From d5c24641b2cb4b0e91f7f20fa959f8389b3219ca Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 8 Feb 2020 16:59:19 -0500 Subject: [PATCH 04/38] clean up Elaborate --- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 542 +++++++++--------- 1 file changed, 276 insertions(+), 266 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 73cb152c48..06f51ede6a 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -17,42 +17,24 @@ import qualified Language.Haskell.Liquid.GHC.Misc as GM import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType + ( ) import qualified Data.List as L import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import Language.Haskell.Liquid.Types.Errors import Control.Monad.Free import Data.Functor.Foldable +import Data.Char ( isUpper ) import GHC import OccName import FastString -import HsPat -import SrcLoc -import Control.Monad import CoreSyn -import Exception -import Inst -import Panic hiding ( panic ) -import Desugar -import TcRnMonad -import TcHsSyn -import RnExpr -import GhcMonad -import TcSimplify import PrelNames -import Outputable hiding ( panic ) import TysWiredIn ( boolTyCon , true_RDR ) -import HscTypes import ErrUtils -import HscMain -import TcExpr -import HsExpr import RdrName -import TysWiredIn import BasicTypes -import PrelNames import Data.Default ( def ) import qualified Data.Maybe as Mb @@ -194,53 +176,54 @@ plugType t = refix . f -- build the expression we send to ghc for elaboration -- YL: tweak this function to see if ghc accepts explicit dictionary binders --- returning both expression since ghc adds unique id to the expressions -buildHsExpr :: LHsExpr GhcPs -> SpecType -> (LHsExpr GhcPs, [F.Symbol]) +-- returning both expressions and binders since ghc adds unique id to the expressions + +collectSpecTypeBinders :: SpecType -> [F.Symbol] +collectSpecTypeBinders = para $ \case + RFunF bind (tin, _) (_, bs) _ | isClassType tin -> bs + | otherwise -> bind : bs + RImpFF bind (tin, _) (_, bs) _ | isClassType tin -> bs + | otherwise -> bind : bs + RAllEF b _ (_, res) -> b : res + RAllTF _ (_, res) _ -> res + RExF b _ (_, res) -> b : res + RAppTyF _ (_, res) _ -> res + RRTyF _ _ _ (_, res) -> res + _ -> [] + +-- really should be fused with collectBinders. However, we need the binders +-- to correctly convert fixpoint expressions to ghc expressions because of +-- namespace related issues (whether the symbol denotes a varName or a datacon) +buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs buildHsExpr res = para $ \case - RFunF bind (tin, _) (_, bres@(res, bs)) _ - | isClassType tin - -> bres - | otherwise - -> (mkHsLam [nlVarPat (symbolToRdrName varName bind)] res, bind : bs) - RImpFF bind (tin, _) (_, bres@(res, bs)) _ - | isClassType tin - -> bres - | otherwise - -> (mkHsLam [nlVarPat (symbolToRdrName varName bind)] res, bind : bs) + RFunF bind (tin, _) (_, res) _ + | isClassType tin -> res + | otherwise -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res + RImpFF bind (tin, _) (_, res) _ + | isClassType tin -> res + | otherwise -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res RAllEF _ _ (_, res) -> res RAllTF _ (_, res) _ -> res RExF _ _ (_, res) -> res RAppTyF _ (_, res) _ -> res RRTyF _ _ _ (_, res) -> res - _ -> (res, []) + _ -> res --- _:Semigroup a -> {x:a | x <> x == x} -> {y:a | y <> x == x <> y} -> {} --- in gives [dict0] --- out gives [dict1] --- I wish there's a way to make this function polymorphic wrt to --- tuples. microlens's Each seems to do exactly what I want.. --- buildDictBinderSubst :: [[F.Symbol]] -> Maybe _ --- bulidDictBinderSubst dbss = --- case L.filter (not . null) dbss of --- [] -> Nothing --- [_] -> Nothing --- (dbs:dbss') -> Just $ --- buildSubst $ zip dbs (L.transpose dbss') --- where buildSubst -renameDictBinder :: (F.Subable a) => [F.Symbol] -> [F.Symbol] -> a -> a -renameDictBinder [] _ = id -renameDictBinder _ [] = id -renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl - where tbl = F.tracepp "TBL" $ M.fromList (zip ds canonicalDs) -canonicalizeDictBinder :: F.Subable a => [F.Symbol] -> [F.Symbol] -> a -> (a,[F.Symbol]) -canonicalizeDictBinder [] bs' e' = (e',bs') -canonicalizeDictBinder bs [] e' = (e',bs) -canonicalizeDictBinder bs bs' e' = (renameDictBinder bs bs' e', bs) - +canonicalizeDictBinder + :: F.Subable a => [F.Symbol] -> (a, [F.Symbol]) -> (a, [F.Symbol]) +canonicalizeDictBinder [] (e', bs') = (e', bs') +canonicalizeDictBinder bs (e', [] ) = (e', bs) +canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs) + where + renameDictBinder :: (F.Subable a) => [F.Symbol] -> [F.Symbol] -> a -> a + renameDictBinder [] _ = id + renameDictBinder _ [] = id + renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl + where tbl = F.tracepp "TBL" $ M.fromList (zip ds canonicalDs) elaborateSpecType @@ -249,141 +232,169 @@ elaborateSpecType -> SpecType -> Ghc (SpecType, [F.Symbol]) -- binders for dictionaries -- should have returned Maybe [F.Symbol] -elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t of - RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do - elaborateReft - (reft, t) - (pure (t, [])) - (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs')) - -- YL : Fix - RFun bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do - -- the reft is never actually used by the child - -- maybe i should enforce this information at the type level - let partialFunTp = - Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType - partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType partialTp coreToLogic tin - (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout - let - buildRFunContTrivial - | isClassType tin, dictBinder : bs0' <- bs' = do - let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs0' eTout +elaborateSpecType partialTp coreToLogic t = + case F.tracepp "elaborateSpecType" t of + RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + elaborateReft + (reft, t) + (pure (t, [])) + (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs')) + -- YL : Fix + RFun bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + -- the reft is never actually used by the child + -- maybe i should enforce this information at the type level + let partialFunTp = + Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType + partialTp' = partialTp >> partialFunTp :: PartialSpecType + (eTin , bs ) <- elaborateSpecType partialTp coreToLogic tin + (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + let buildRFunContTrivial + | isClassType tin, dictBinder : bs0' <- bs' = do + let (eToutRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eTout, bs0') + pure + ( F.notracepp "RFunTrivial0" + $ RFun dictBinder eTin eToutRenamed ureft + , canonicalBinders + ) + | otherwise = do + let (eToutRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eTout, bs') + pure + ( F.notracepp "RFunTrivial1" $ RFun bind eTin eToutRenamed ureft + , canonicalBinders + ) + buildRFunCont bs'' ee + | isClassType tin, dictBinder : bs0' <- bs' = do + let (eToutRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eTout, bs0') + (eeRenamed, canonicalBinders') = + canonicalizeDictBinder canonicalBinders (ee, bs'') + pure + ( RFun dictBinder + eTin + eToutRenamed + (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders' + ) + | otherwise = do + let (eToutRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eTout, bs') + (eeRenamed, canonicalBinders') = + canonicalizeDictBinder canonicalBinders (ee, bs'') + pure + ( RFun bind + eTin + eToutRenamed + (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders' + ) + elaborateReft (reft, t) buildRFunContTrivial buildRFunCont + + -- (\bs' ee | isClassType tin -> do + -- let eeRenamed = renameDictBinder canonicalBinders bs' ee + -- pure (RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), bs') + -- ) + -- YL: implicit dictionary param doesn't seem possible.. + RImpF bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do + let partialFunTp = + Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType + partialTp' = partialTp >> partialFunTp :: PartialSpecType + (eTin , bs ) <- elaborateSpecType partialTp' coreToLogic tin + (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + let (eToutRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eTout, bs') + + -- eTin and eTout might have different dictionary names + -- need to do a substitution to make the reference to dictionaries consistent + -- if isClassType eTin + elaborateReft + (reft, t) + (pure (RImpF bind eTin eToutRenamed ureft, canonicalBinders)) + (\bs'' ee -> do + let (eeRenamed, canonicalBinders') = + canonicalizeDictBinder canonicalBinders (ee, bs'') pure - ( F.notracepp "RFunTrivial0" $ RFun dictBinder - eTin - eToutRenamed - ureft - , canonicalBinders + ( RImpF bind eTin eTout (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders' ) - | otherwise = do - let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout - pure - ( F.notracepp "RFunTrivial1" $ RFun bind eTin eToutRenamed ureft - , canonicalBinders - ) - buildRFunCont bs'' ee - | isClassType tin, dictBinder : bs0' <- bs' = do - let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs0' eTout - eeRenamed = renameDictBinder canonicalBinders bs'' ee - pure - ( RFun dictBinder - eTin - eToutRenamed - (MkUReft (F.Reft (vv, eeRenamed)) p) - , canonicalBinders - ) - | otherwise = do - let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout - eeRenamed = renameDictBinder canonicalBinders bs'' ee - pure - ( RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p) - , canonicalBinders - ) - elaborateReft (reft, t) - buildRFunContTrivial - buildRFunCont - - -- (\bs' ee | isClassType tin -> do - -- let eeRenamed = renameDictBinder canonicalBinders bs' ee - -- pure (RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), bs') - -- ) - -- YL: implicit dictionary param doesn't seem possible.. - RImpF bind tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do - let partialFunTp = - Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType - partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType partialTp' coreToLogic tin - (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout - let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eTout - - -- eTin and eTout might have different dictionary names - -- need to do a substitution to make the reference to dictionaries consistent - -- if isClassType eTin - elaborateReft - (reft, t) - (pure (RImpF bind eTin eToutRenamed ureft, canonicalBinders)) - (\bs'' ee -> do - let eeRenamed = renameDictBinder canonicalBinders bs'' ee - pure (RImpF bind eTin eTout (MkUReft (F.Reft (vv, eeRenamed)) p), bs') - ) - -- support for RankNTypes/ref - RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do - (eTout, bs) <- elaborateSpecType - (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft)) - coreToLogic - tout - elaborateReft - (ref, RVar tv mempty) - (pure (RAllT (RTVar tv ty) eTout ureft, bs)) - (\bs' ee -> - let (eeRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' ee in - pure (RAllT (RTVar tv ty) eTout (MkUReft (F.Reft (vv, eeRenamed)) p), canonicalBinders) - ) - -- pure (RAllT (RTVar tv ty) eTout ref, bts') - -- todo: might as well print an error message? - RAllP pvbind tout -> do - (eTout, bts') <- elaborateSpecType - (partialTp >> Free (RAllPF pvbind (pure ()))) - coreToLogic - tout - pure (RAllP pvbind eTout, bts') - -- pargs not handled for now - -- RApp tycon args pargs reft - RApp tycon args pargs ureft@(MkUReft reft@(F.Reft (vv, _)) p) - | isClass tycon -> pure (t, []) - | otherwise -> elaborateReft - (reft, t) - (pure (RApp tycon args pargs ureft, [])) - (\bs' ee -> - pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') - ) - RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do - (eArg, bs ) <- elaborateSpecType partialTp coreToLogic arg - (eRes, bs') <- elaborateSpecType partialTp coreToLogic res - let (eResRenamed, canonicalBinders) = canonicalizeDictBinder bs bs' eRes - elaborateReft - (reft, t) - (pure (RAppTy eArg eResRenamed ureft, canonicalBinders)) - (\bs'' ee -> - let eeRenamed = renameDictBinder canonicalBinders bs'' ee in - pure (RAppTy eArg eResRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), canonicalBinders)) - RAllE bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty - pure (RAllE bind eAllarg eTy, bs) - REx bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty - pure (RAllE bind eAllarg eTy, bs) - -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard - -- in the future - RExprArg _ -> impossible Nothing "RExprArg should not appear here" - RHole _ -> impossible Nothing "RHole should not appear here" - RRTy _ _ _ _ -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t) + ) + -- support for RankNTypes/ref + RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do + (eTout, bs) <- elaborateSpecType + (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft)) + coreToLogic + tout + elaborateReft + (ref, RVar tv mempty) + (pure (RAllT (RTVar tv ty) eTout ureft, bs)) + (\bs' ee -> + let (eeRenamed, canonicalBinders) = + canonicalizeDictBinder bs (ee, bs') + in pure + ( RAllT (RTVar tv ty) eTout (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders + ) + ) + -- pure (RAllT (RTVar tv ty) eTout ref, bts') + -- todo: might as well print an error message? + RAllP pvbind tout -> do + (eTout, bts') <- elaborateSpecType + (partialTp >> Free (RAllPF pvbind (pure ()))) + coreToLogic + tout + pure (RAllP pvbind eTout, bts') + -- pargs not handled for now + -- RApp tycon args pargs reft + RApp tycon args pargs ureft@(MkUReft reft@(F.Reft (vv, _)) p) + | isClass tycon -> pure (t, []) + | otherwise -> elaborateReft + (reft, t) + (pure (RApp tycon args pargs ureft, [])) + (\bs' ee -> + pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') + ) + RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do + (eArg, bs ) <- elaborateSpecType partialTp coreToLogic arg + (eRes, bs') <- elaborateSpecType partialTp coreToLogic res + let (eResRenamed, canonicalBinders) = + canonicalizeDictBinder bs (eRes, bs') + elaborateReft + (reft, t) + (pure (RAppTy eArg eResRenamed ureft, canonicalBinders)) + (\bs'' ee -> + let (eeRenamed, canonicalBinders') = + canonicalizeDictBinder canonicalBinders (ee, bs'') + in pure + ( RAppTy eArg eResRenamed (MkUReft (F.Reft (vv, eeRenamed)) p) + , canonicalBinders' + ) + ) + -- todo: Existential support + RAllE bind allarg ty -> do + (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') + pure (RAllE bind eAllarg eTyRenamed, canonicalBinders) + REx bind allarg ty -> do + (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') + pure (REx bind eAllarg eTyRenamed, canonicalBinders) + -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard + -- in the future + RExprArg _ -> impossible Nothing "RExprArg should not appear here" + RHole _ -> impossible Nothing "RHole should not appear here" + RRTy _ _ _ _ -> + todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t) where boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType elaborateReft - :: (F.PPrint a) => (F.Reft, SpecType) -> Ghc a -> ([F.Symbol] -> F.Expr -> Ghc a) -> Ghc a + :: (F.PPrint a) + => (F.Reft, SpecType) + -> Ghc a + -> ([F.Symbol] -> F.Expr -> Ghc a) + -> Ghc a elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont = if isTrivial reft then trivial @@ -392,14 +403,14 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t let querySpecType = plugType (rFun vv vvTy boolType) partialTp :: SpecType - (hsExpr, origBinders) = - buildHsExpr (fixExprToHsExpr e) querySpecType :: ( LHsExpr GhcPs - , [F.Symbol] - ) + origBinders = collectSpecTypeBinders querySpecType + hsExpr = + buildHsExpr (fixExprToHsExpr (S.fromList origBinders) e) + querySpecType :: LHsExpr GhcPs exprWithTySigs = GM.notracePpr "exprWithTySigs" $ noLoc $ ExprWithTySig - ( mkLHsSigWcType - $ specTypeToLHsType (F.notracepp "querySpecType" querySpecType) + (mkLHsSigWcType $ specTypeToLHsType + (F.notracepp "querySpecType" querySpecType) ) hsExpr :: LHsExpr GhcPs (msgs, mbExpr) <- GM.elaborateHsExprInst exprWithTySigs @@ -425,14 +436,16 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t Nothing "Oops, Ghc gave back more/less binders than I expected" ret <- nonTrivialCont - dictbs - (F.notracepp "nonTrivialContEE" $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) ee) -- (GM.dropModuleUnique <$> bs') + dictbs + ( F.notracepp "nonTrivialContEE" + $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) ee + ) -- (GM.dropModuleUnique <$> bs') pure (F.notracepp "result" ret) -- (F.substa ) isTrivial :: F.Reft -> Bool isTrivial (F.Reft (_, F.PTrue)) = True - isTrivial _ = False - + isTrivial _ = False + grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr) grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e) grabLams bse = bse @@ -446,59 +459,47 @@ elaborateSpecType partialTp coreToLogic t = case F.tracepp "elaborateSpecType" t -- | Embed fixpoint expressions into parsed haskell expressions. -- It allows us to bypass the GHC parser and use arbitrary symbols -- for identifiers (compared to using the string API) -fixExprToHsExpr :: F.Expr -> LHsExpr GhcPs -fixExprToHsExpr (F.ECon c) = constantToHsExpr c -fixExprToHsExpr (F.EVar x) = - noLoc (HsVar NoExt (noLoc (symbolToRdrName varName x))) -fixExprToHsExpr (F.EApp e0 e1) = - noLoc (HsApp NoExt (fixExprToHsExpr e0) (fixExprToHsExpr e1)) -fixExprToHsExpr (F.ENeg e) = noLoc - (HsApp NoExt - (noLoc (HsVar NoExt (noLoc (nameRdrName negateName)))) - (fixExprToHsExpr e) - ) -fixExprToHsExpr (F.EBin bop e0 e1) = noLoc - (HsApp NoExt - (noLoc (HsApp NoExt (bopToHsExpr bop) (fixExprToHsExpr e0))) - (fixExprToHsExpr e1) - ) -fixExprToHsExpr (F.EIte p e0 e1) = noLoc - (HsIf NoExt - Nothing - (fixExprToHsExpr p) - (fixExprToHsExpr e0) - (fixExprToHsExpr e1) - ) +fixExprToHsExpr :: S.HashSet F.Symbol -> F.Expr -> LHsExpr GhcPs +fixExprToHsExpr env (F.ECon c) = constantToHsExpr c +fixExprToHsExpr env (F.EVar x) = nlHsVar (symbolToRdrName env x) +fixExprToHsExpr env (F.EApp e0 e1) = + mkHsApp (fixExprToHsExpr env e0) (fixExprToHsExpr env e1) +fixExprToHsExpr env (F.ENeg e) = + mkHsApp (nlHsVar (nameRdrName negateName)) (fixExprToHsExpr env e) + +fixExprToHsExpr env (F.EBin bop e0 e1) = mkHsApp + (mkHsApp (bopToHsExpr bop) (fixExprToHsExpr env e0)) + (fixExprToHsExpr env e1) +fixExprToHsExpr env (F.EIte p e0 e1) = nlHsIf (fixExprToHsExpr env p) + (fixExprToHsExpr env e0) + (fixExprToHsExpr env e1) + -- FIXME: convert sort to HsType -fixExprToHsExpr (F.ECst e0 _ ) = fixExprToHsExpr e0 -fixExprToHsExpr (F.PAnd [] ) = nlHsVar true_RDR -fixExprToHsExpr (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr e) es - where f x acc = mkHsApp (mkHsApp (nlHsVar and_RDR) (fixExprToHsExpr x)) acc -fixExprToHsExpr (F.POr es) = noLoc - (HsApp - NoExt - (noLoc (HsVar NoExt (noLoc (varQual_RDR dATA_FOLDABLE (fsLit "or"))))) - (noLoc (ExplicitList NoExt Nothing (fixExprToHsExpr <$> es))) - ) -fixExprToHsExpr (F.PNot e) = - noLoc (HsApp NoExt (noLoc (HsVar NoExt (noLoc not_RDR))) (fixExprToHsExpr e)) -fixExprToHsExpr (F.PAtom brel e0 e1) = noLoc - (HsApp NoExt - (noLoc (HsApp NoExt (brelToHsExpr brel) (fixExprToHsExpr e0))) - (fixExprToHsExpr e1) - ) -fixExprToHsExpr (F.PImp e0 e1) = noLoc - (HsApp - NoExt - (noLoc - (HsApp NoExt - (noLoc (HsVar NoExt (noLoc (mkVarUnqual (mkFastString "==>"))))) - (fixExprToHsExpr e0) - ) - ) - (fixExprToHsExpr e1) +fixExprToHsExpr env (F.ECst e0 _ ) = fixExprToHsExpr env e0 +-- fixExprToHsExpr env (F.PAnd [] ) = nlHsVar true_RDR +fixExprToHsExpr env (F.PAnd [] ) = nlHsVar true_RDR +fixExprToHsExpr env (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr env e) es + where + f x acc = mkHsApp (mkHsApp (nlHsVar and_RDR) (fixExprToHsExpr env x)) acc + +-- This would work in the latest commit +-- fixExprToHsExpr env (F.PAnd es ) = mkHsApp +-- (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "and"))) +-- (nlList $ fixExprToHsExpr env <$> es) +fixExprToHsExpr env (F.POr es) = mkHsApp + (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "or"))) + (nlList $ fixExprToHsExpr env <$> es) +fixExprToHsExpr env (F.PNot e) = + mkHsApp (nlHsVar not_RDR) (fixExprToHsExpr env e) +fixExprToHsExpr env (F.PAtom brel e0 e1) = mkHsApp + (mkHsApp (brelToHsExpr brel) (fixExprToHsExpr env e0)) + (fixExprToHsExpr env e1) +fixExprToHsExpr env (F.PImp e0 e1) = mkHsApp + (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "==>"))) (fixExprToHsExpr env e0) ) -fixExprToHsExpr e = + (fixExprToHsExpr env e1) + +fixExprToHsExpr env e = todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e) constantToHsExpr :: F.Constant -> LHsExpr GhcPs @@ -533,9 +534,8 @@ brelToHsExpr brel = noLoc (HsVar NoExt (noLoc (f brel))) f F.Ne = mkVarUnqual (mkFastString "/=") f _ = impossible Nothing "brelToExpr: Unsupported operation" - -symbolToRdrName :: NameSpace -> F.Symbol -> RdrName -symbolToRdrName ns x +symbolToRdrNameNs :: NameSpace -> F.Symbol -> RdrName +symbolToRdrNameNs ns x | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s)) | otherwise = mkQual ns @@ -543,6 +543,23 @@ symbolToRdrName ns x where (modName, s) = GM.splitModuleName x +varSymbolToRdrName :: F.Symbol -> RdrName +varSymbolToRdrName = symbolToRdrNameNs varName + + +-- don't use this function... +symbolToRdrName :: S.HashSet F.Symbol -> F.Symbol -> RdrName +symbolToRdrName env x + | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s)) + | otherwise = mkQual + ns + (mkFastString (F.symbolString modName), mkFastString (F.symbolString s)) + where + (modName, s) = GM.splitModuleName x + ns | not (S.member x env), Just (c, _) <- F.unconsSym s, isUpper c = dataName + | otherwise = varName + + specTypeToLHsType :: SpecType -> LHsType GhcPs -- surprised that the type application is necessary specTypeToLHsType = @@ -561,21 +578,14 @@ specTypeToLHsType = where notExprArg (RExprArg _) = False notExprArg _ = True - RAllEF _ _ (_, t) -> t - RExF _ _ (_, t) -> t - RAppTyF (_, t) (RExprArg _, _ ) _ -> t - RAppTyF (_, t) (_ , t') _ -> nlHsAppTy t t' - RRTyF _ _ _ (_, t) -> t - RHoleF _ -> noLoc $ HsWildCardTy NoExt + RAllEF _ (_, tin) (_, tout) -> nlHsFunTy tin tout + RExF _ (_, tin) (_, tout) -> nlHsFunTy tin tout + -- impossible + RAppTyF _ (RExprArg _, _) _ -> + impossible Nothing "RExprArg should not appear here" + RAppTyF (_, t) (_, t') _ -> nlHsAppTy t t' + -- YL: todo.. + RRTyF _ _ _ (_, t) -> t + RHoleF _ -> noLoc $ HsWildCardTy NoExt RExprArgF _ -> todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg" - - - - - --- toType (RApp (RTyCon {rtc_tc = c}) ts _ _) --- = TyConApp c (toType <$> filter notExprArg ts) --- where --- notExprArg (RExprArg _) = False --- notExprArg _ = True From 049c1a1b0fec384707bfcdde8bf0612dfc8fc395 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 8 Feb 2020 17:30:27 -0500 Subject: [PATCH 05/38] clean up Bare.hs --- src/Language/Haskell/Liquid/Bare.hs | 183 ++-------------------------- 1 file changed, 13 insertions(+), 170 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 36d436f760..1d557a7cd9 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -130,143 +130,6 @@ ghcSpecEnv sp = fromListSEnv binds vSort = Bare.varSortedReft emb rSort = rTypeSortedReft emb --- witness of the isomorphism between elaboration binders and safe text --- toHaskellBinder :: F.Symbol -> F.Symbol --- toHaskellBinder = F.symbol . ('_':) . fmap --- (\x -> case x of --- '$' -> '_' --- '#' -> '_' --- _ -> x) . F.symbolString - --- toGhcExpr :: F.Expr -> String --- toGhcExpr e = --- paren $ case e of --- F.ECon (F.I c) -> show c --- F.ECon (F.R c) -> show c --- -- F.ECon (F.L _ _) -> todo Nothing "Don't know how to handle F.ECon (F.L _ _)" --- F.EVar x -> F.symbolString x --- F.EApp e0 e1 -> toGhcExpr e0 ++ toGhcExpr e1 --- F.ENeg e0 -> "-" ++ toGhcExpr e0 --- F.EBin bop e0 e1 -> bopToExpr bop ++ toGhcExpr e0 ++ toGhcExpr e1 --- F.EIte p e0 e1 -> "if" ++ toGhcExpr p ++ "then" ++ toGhcExpr e0 ++ "else" ++ toGhcExpr e1 --- F.ECst e0 _ -> toGhcExpr e0 --- F.PAnd es -> "and" ++ bracket (L.intercalate "," $ toGhcExpr <$> es ) --- F.POr es -> "or" ++ bracket (L.intercalate "," $ toGhcExpr <$> es) --- F.PNot e -> "not" ++ toGhcExpr e --- F.PImp e0 e1 -> "(==>)" ++ toGhcExpr e0 ++ toGhcExpr e1 --- F.PAtom brel e0 e1 -> brelToExpr brel ++ toGhcExpr e0 ++ toGhcExpr e1 --- _ -> todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e) --- where paren x = "(" ++ x ++ ")" --- bracket x = "["++ x ++ "]" --- bopToExpr :: F.Bop -> String --- bopToExpr bop = case bop of --- F.Plus -> "(+)" --- F.Minus -> "(-)" --- F.Times -> "(*)" --- F.Div -> "(/)" --- F.Mod -> "mod" --- F.RTimes -> "(*)" --- F.RDiv -> "(/)" --- brelToExpr :: F.Brel -> String --- brelToExpr brel = case brel of --- Eq -> "(==)" --- Ne -> "(/=)" --- Gt -> "(>)" --- Lt -> "(<)" --- Ge -> "(>=)" --- Le -> "(<=)" --- _ -> impossible Nothing "brelToExpr: Unsupported operation" - --- -- FROM double [int, semigroup a] TO semigroup a => int -> double --- buildTypeAnn :: String -> [SpecType] -> String --- buildTypeAnn vvTy = L.foldl' f (paren ("(->)"++ paren vvTy ++"(Bool)")) --- where f :: String -> SpecType -> String --- f res ty --- | isClassType ty = paren $ paren (GM.showPpr $ toType ty) ++ "=>" ++ res --- | otherwise = paren $ "(->)" ++ paren (GM.showPpr $ toType ty) ++ res --- paren x = "(" ++ x ++ ")" - --- -- FROM (vv, x + y) [x,y] TO \(y)(x)(vv)->((+)(x)(y)) --- buildExpr :: F.Reft -> [F.Symbol] -> String --- buildExpr (F.Reft (vv, toGhcExpr -> e)) = --- let vv' = if F.isDummy vv then "_" else F.symbolString vv --- in paren . (++) "\\" . L.foldl' f (paren vv' ++ "->" ++ e) --- where paren x = "(" ++ x ++ ")" --- f res binder = paren (F.symbolString binder) ++ res - --- elaborateSpecType :: [(F.Symbol,SpecType)] -- binders come in reverse order --- -> (Ghc.CoreExpr -> Expr) --- -> SpecType --- -> Ghc.Ghc (SpecType, [F.Symbol]) -- binders for dictionaries --- -- should have returned Maybe [F.Symbol] --- elaborateSpecType bts coreToLogic t = --- case F.notracepp ("elaborateSpecType: " ++ F.showpp bts) t of --- RVar (RTV tv) (MkUReft reft@(F.Reft(vv,_oldE)) p) -> do --- elaborateReft (reft, GM.showPpr tv) (pure (t, [])) --- (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv,ee)) p), bs')) --- RFun bind tin tout ureft@(MkUReft reft@(F.Reft(vv,_oldE)) p) -> do --- let bts' = (bind,tin):bts --- (eTin, bs') <- elaborateSpecType bts' coreToLogic tin --- (eTout, bs'') <- elaborateSpecType bts' coreToLogic tout --- -- eTin and eTout might have different dictionary names --- -- need to do a substitution to make the reference to dictionaries consistent --- -- if isClassType eTin --- elaborateReft (reft, GM.showPpr $ toType t) (pure (RFun bind eTin eTout ureft, bs')) (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv,ee)) p), bs)) --- RImpF bind tin tout ureft@(MkUReft reft@(F.Reft(vv,_oldE)) p) -> do --- let bts' = (bind,tin):bts --- (eTin, bs') <- elaborateSpecType bts' coreToLogic tin --- (eTout, bs'') <- elaborateSpecType bts' coreToLogic tout --- -- eTin and eTout might have different dictionary names --- -- need to do a substitution to make the reference to dictionaries consistent --- elaborateReft (reft, GM.showPpr $ toType t) (pure (RImpF bind eTin eTout ureft, bs')) --- (\bs' ee -> pure (RFun bind eTin eTout (MkUReft (F.Reft (vv,ee)) p), bs)) --- -- support for RankNTypes/ref --- RAllT (RTVar tv ty) tout ref -> do --- (eTout, bts') <- elaborateSpecType bts coreToLogic tout --- pure (RAllT (RTVar tv ty) eTout ref, bts') --- RAllP pvbind tout -> do --- (eTout, bts') <- elaborateSpecType bts coreToLogic tout --- pure (RAllP pvbind eTout, bts') --- -- pargs not handled for now --- -- RApp tycon args pargs reft --- RApp tycon args pargs ureft@(MkUReft reft@(F.Reft(vv,_)) p) --- | isClass tycon -> --- pure (t, []) --- | otherwise -> --- elaborateReft (reft, GM.showPpr $ toType t) (pure (RApp tycon args pargs ureft, bs)) --- (\bs' ee -> pure (RApp tycon args pargs (MkUReft (F.Reft (vv,ee)) p), bs')) - --- _ -> --- todo Nothing ("Not sure how to elaborate " ++ F.showpp t) --- where elaborateReft :: (F.Reft, String) -> Ghc.Ghc a -> ([F.Symbol] -> F.Expr -> Ghc.Ghc a) -> Ghc.Ghc a --- elaborateReft (reft, vvTy) trivial nonTrivialCont = --- if isTrivial reft --- then trivial --- else do --- let query = buildQuery reft id vvTy --- liftIO $ putStrLn query --- mbExpr <- GM.elaborateExprInst query --- case mbExpr of --- Nothing -> panic Nothing ("Ghc is unable to elaborate the expression: " ++ query) --- Just (coreToLogic -> eeWithLams) -> do --- let (bs', ee) = grabLams ([], eeWithLams) --- nonTrivialCont bs' ee --- bs = [b | (b,t) <- bts, not (isClassType t)] --- ts = snd <$> bts --- buildQuery reft f vvTy = buildExprAnn (buildExpr reft bs) (buildTypeAnn (f vvTy) ts) --- buildExprAnn e ann = e ++ "::" ++ ann --- grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr) --- grabLams (bs, F.ELam (b,_) e) = grabLams (b:bs, e) --- grabLams bse = bse --- isTrivial :: F.Reft -> Bool --- isTrivial (F.Reft (_,ee)) = (L.null . F.syms) ee - - - - - - - ------------------------------------------------------------------------------------- -- | @makeGhcSpec0@ slurps up all the relevant information needed to generate -- constraints for a target module and packages them into a @GhcSpec@ @@ -277,42 +140,11 @@ ghcSpecEnv sp = fromListSEnv binds makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- makeGhcSpec0 cfg src lmap mspecs = do - -- liftIO $ mapM_ (putStrLn . F.showpp) (val.snd<$>gsTySigs sig) - -- liftIO $ mapM_ (mapReftM (\(MkUReft (F.Reft (vv,r)) _) -> putStrLn$(F.symbolSafeString vv ++ ":" ++ toGhcExpr r))) (val.snd<$> gsTySigs sig) - -- let sigs = val.mapsnd <$> - -- [(x,y) | (x,y) <- gsTySigs sig, ("VerifiedMonad" `L.isPrefixOf` GM.showPpr x )] :: [SpecType] - -- let sigs = val.snd <$> gsTySigs sig - sigs' <- forM - [(x,y) | (x,y) <- gsTySigs sig] $ \(x,locSpec) -> do - locSpec' <- traverse (elaborateSpecType (pure ()) coreToLg) locSpec - pure (x, fst <$> locSpec') - - -- liftIO $ mapM_ (mapReftM (\(MkUReft (F.Reft (vv,r)) _) -> putStrLn$(F.symbolSafeString vv ++ ":" ++ show r))) (val.snd <$> sigs') - - - -- elaboratedSigs <- mapM (elaborateSpecType (pure ()) coreToLg) sigs - -- liftIO $ putStrLn "Before:" - -- liftIO $ putStrLn $ F.showpp sigs' - -- liftIO $ putStrLn "After:" - -- liftIO $ putStrLn $ F.showpp sigs - - -- liftIO $ putStrLn "[DUMPING toType]" - -- liftIO $ mapM_ (putStrLn . GM.showPpr . Ghc.typeToLHsType) (toType <$> sigs) - -- liftIO $ putStrLn "[DUMPING toType DONE]" - -- mapM_ (liftIO . putStrLn . F.showpp <=< elaborateSpecType [] coreToLg) sigs - - -- e <- Mb.fromJust <$> GM.elaborateExprInst "1 + 1 :: Int" - -- liftIO $ putStrLn (GM.showPpr e) - -- hscEnv <- Ghc.getSession - -- e' <- liftIO $ ANF.anormalizeExpr cfg hscEnv (GM.tracePpr "OHQO" e) - - -- e <- Rec.transformRecSingleExpr. Mb.fromJust <$> GM.elaborateExprInst "let x = 10 in x" - -- liftIO . print $ CoreToLogic.runToLogic embs lmap dm (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e') - -- liftIO $ putStrLn "" + elaboratedSig <- elaborateSig sig pure $ SP { gsConfig = cfg , gsImps = makeImports mspecs - , gsSig = addReflSigs refl sig {gsTySigs = sigs'} + , gsSig = addReflSigs refl elaboratedSig , gsRefl = refl , gsLaws = laws , gsData = sData @@ -332,6 +164,17 @@ makeGhcSpec0 cfg src lmap mspecs = do (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e) of Left _ -> impossible Nothing "can't reach here" Right e -> e + + elaborateSig si = do + tySigs <- forM (gsTySigs si) $ \(x, t) -> do + t' <- traverse (elaborateSpecType (pure ()) coreToLg) t + pure (x, fst <$> t') + -- things like len breaks the code + -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do + -- t' <- traverse (elaborateSpecType (pure ()) coreToLg) t + -- pure (x, fst <$> t') + pure si {gsTySigs = tySigs-- , gsAsmSigs = asmSigs + } dm = Bare.tcDataConMap tycEnv myRTE = myRTEnv src env sigEnv rtEnv qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs From 275b01d4aec6eb5b308c15f2b5a9515eb7753a9f Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 8 Feb 2020 19:20:22 -0500 Subject: [PATCH 06/38] add class but does not unify --- src/Language/Haskell/Liquid/Bare.hs | 104 +++++++++++++++++- src/Language/Haskell/Liquid/Bare/Axiom.hs | 6 +- src/Language/Haskell/Liquid/Bare/Check.hs | 2 +- src/Language/Haskell/Liquid/Bare/DataType.hs | 90 ++++++++++++++- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 4 +- src/Language/Haskell/Liquid/GHC/Misc.hs | 20 ++++ .../Haskell/Liquid/Transforms/CoreToLogic.hs | 34 +++--- src/Language/Haskell/Liquid/Types/RefType.hs | 2 +- 8 files changed, 227 insertions(+), 35 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 1d557a7cd9..24ce96e45c 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -139,7 +139,7 @@ ghcSpecEnv sp = fromListSEnv binds ------------------------------------------------------------------------------------- makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- -makeGhcSpec0 cfg src lmap mspecs = do +makeGhcSpec0 cfg src lmap mspecsNoClass = do elaboratedSig <- elaborateSig sig pure $ SP { gsConfig = cfg @@ -197,11 +197,105 @@ makeGhcSpec0 cfg src lmap mspecs = do lSpec0 = makeLiftedSpec0 cfg src embs lmap mySpec0 embs = makeEmbeds src env ((name, mySpec0) : M.toList iSpecs0) -- extract name and specs - env = Bare.makeEnv cfg src lmap mspecs - (mySpec0, iSpecs0) = splitSpecs name mspecs + env = Bare.makeEnv cfg src lmap mspecsNoClass + mspecs = M.toList $ M.insert name mySpec0 iSpecs0 + mySpec0 = compileClasses src env (name, mySpec0NoClass) (M.toList iSpecs0) + (mySpec0NoClass, iSpecs0) = splitSpecs name mspecsNoClass -- check barespecs name = F.notracepp ("ALL-SPECS" ++ zzz) $ giTargetMod src - zzz = F.showpp (fst <$> mspecs) + zzz = F.showpp (fst <$> mspecsNoClass) + + + +compileClasses :: GhcSrc -> Bare.Env -> (ModName, Ms.BareSpec) + -> [(ModName, Ms.BareSpec)] -> Ms.BareSpec +compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec + where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList methods-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs + } + clsDecls = Bare.makeClassDataDecl' (M.toList refinedMethods) + + -- class methods + (refinedMethods, sigs') = foldr grabClassSig (mempty, mempty) (sigs spec) + + grabClassSig :: (F.LocSymbol, ty) -> + (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) -> + (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) + grabClassSig sig@(lsym, ref) (refs, sigs') = + case clsOp of + Nothing -> (refs, sig:sigs') + Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs') + where clsOp = do + var <- Bare.maybeResolveSym env name "grabClassSig" lsym + cls <- Ghc.isClassOpId_maybe var + pure (cls, (var, ref)) + + merge sig v = case v of + Nothing -> Just [sig] + Just vs -> Just (sig:vs) + + -- instance methods + methods = F.tracepp "methods" [ F.symbol <$> GM.locNamedThing x | + (d, e) <- concatMap unRec (giCbs src) + , F.tracepp (F.showpp (F.symbol d)) (Ghc.isDFunId d) + , cls <- Mb.maybeToList $ L.lookup d instClss + , cls `elem` refinedClasses + , x <- freeVars mempty e + -- YL: Hack + , not (isPrefixOfSym "$claw" (GM.simplesymbol x)) + , GM.isMethod x + ] + + -- refinedMethodSigs :: [(F.LocSymbol, F.Located BareType)] + -- refinedMethodSigs = concatMap refineInstance insts + + -- refineInstance :: Ghc.ClsInst -> [(F.LocSymbol, F.Located BareType)] + -- refineInstance inst + -- | L.null is_tvs + -- = [(Mb.fromJust $ M.lookup (GM.dropModuleNamesAndUnique $ F.symbol methodId) clsMethodInst, plugType <$> ty) | (methodId, ty) <- methods] + -- | otherwise + -- = todo Nothing "instances with parameters are not supported" + -- where is_tvs = Ghc.is_tvs inst -- forall tvs. + -- is_tys = Ghc.is_tys inst -- Int + -- is_cls = Ghc.is_cls inst + + -- -- hack. doesn't work when we have module name at the front + -- plugType :: BareType -> BareType + -- plugType = F.substa (\s -> Mb.fromMaybe s (F.val <$> M.lookup s clsMethodInst)) . subts (zip (GM.dropModuleNamesAndUnique . F.symbol <$> Ghc.classTyVars is_cls) (bareOfType <$> is_tys :: [BareType])) + + -- methods + -- | Just ms <- M.lookup is_cls refinedMethods + -- = ms + -- | otherwise + -- = impossible Nothing "invariant violated" + -- instMethods = F.tracepp "instMethods" [ F.symbol <$> GM.locNamedThing x | + -- (d, e) <- concatMap unRec (giCbs src) + -- , d == Ghc.is_dfun inst + -- , x <- freeVars mempty e + -- , GM.isMethod x + -- ] + -- -- mappend -> $cmappend#a1ox + -- clsMethodInst :: M.HashMap F.Symbol F.LocSymbol + -- clsMethodInst = M.fromList + -- [((F.dropSym 2 . GM.dropModuleNamesAndUnique . F.val) m, m) | m <- instMethods] + + insts :: [Ghc.ClsInst] + insts = mconcat . Mb.maybeToList . gsCls $ src + + instClss :: [(Ghc.DFunId, Ghc.Class)] + instClss = fmap (\inst -> (GM.tracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ Ghc.is_dfun inst, Ghc.is_cls inst)) $ + insts + + refinedClasses :: [Ghc.Class] + refinedClasses = Mb.mapMaybe resolveClassMaybe clsDecls ++ + concatMap (Mb.mapMaybe resolveClassMaybe.dataDecls.snd) rest + + resolveClassMaybe :: DataDecl -> Maybe Ghc.Class + resolveClassMaybe d = Bare.maybeResolveSym env name "resolveClassMaybe" + (dataNameSymbol.tycName $ d) >>= + Ghc.tyConClass_maybe + unRec (Ghc.Rec xes) = xes + unRec (Ghc.NonRec x e) = [(x,e)] + splitSpecs :: ModName -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs) splitSpecs name specs = (mySpec, iSpecm) @@ -724,7 +818,7 @@ makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> GhcSpecData ------------------------------------------------------------------------------------------ makeSpecData src env sigEnv measEnv sig specs = SpData - { gsCtors = -- F.notracepp "GS-CTORS" + { gsCtors = F.notracepp "GS-CTORS" [ (x, tt) | (x, t) <- Bare.meDataCons measEnv , let tt = Bare.plugHoles sigEnv name (Bare.LqTV x) t diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs index c415eb568e..b47ab496a3 100644 --- a/src/Language/Haskell/Liquid/Bare/Axiom.hs +++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs @@ -54,9 +54,9 @@ getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr) -findVarDefType cbs sigs x = case findVarDef (val x) cbs of - Just (v, e) -> if Ghc.isExportedId v - then (x, val <$> lookup v sigs, v, e) +findVarDefType cbs sigs x = case findVarDefMethod (val x) cbs of + Just (v, e) -> if Ghc.isExportedId v || isMethod (F.symbol x) + then (F.notracepp "FIND-VAR-DEF-NAME" $ x, F.notracepp "FIND-VAR-DEF" $ val <$> lookup v sigs, v, e) else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v) Nothing -> Ex.throw $ mkError x "Cannot lift haskell function" diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs index c69b983495..92951fc553 100644 --- a/src/Language/Haskell/Liquid/Bare/Check.hs +++ b/src/Language/Haskell/Liquid/Bare/Check.hs @@ -309,7 +309,7 @@ checkTerminationExpr emb env (v, Loc l _ t, les) xts = concatMap mkClass $ zip (ty_binds trep) (ty_args trep) trep = toRTypeRep t - mkClass (_, RApp c ts _ _) | isClass c = classBinds emb (rRCls c ts) + mkClass (_, RApp c ts _ _) | isEmbeddedDict c = classBinds emb (rRCls c ts) mkClass (x, t) = [(x, rSort t)] rSort = rTypeSortedReft emb diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 65d2625093..bfd63597be 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -16,7 +16,11 @@ module Language.Haskell.Liquid.Bare.DataType , makeRecordSelectorSigs , meetDataConSpec -- , makeTyConEmbeds - + + -- * Type Classes + , makeClassDataDecl + , makeClassDataDecl' + ) where import Prelude hiding (error) @@ -30,7 +34,8 @@ import qualified Control.Exception as Ex import qualified Data.List as L import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import qualified Data.Maybe as Mb +import qualified Data.Maybe as Mb +import Control.Arrow ((***)) -- import qualified Language.Fixpoint.Types.Visitor as V import qualified Language.Fixpoint.Types as F @@ -350,7 +355,7 @@ muSort c n = V.mapSort tx meetDataConSpec :: F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP] -> [(Ghc.Var, SpecType)] -------------------------------------------------------------------------------- -meetDataConSpec emb xts dcs = -- F.notracepp "meetDataConSpec" $ +meetDataConSpec emb xts dcs = F.notracepp "meetDataConSpec" $ M.toList $ snd <$> L.foldl' upd dcm0 xts where dcm0 = M.fromList (dataConSpec' dcs) @@ -380,6 +385,77 @@ makeConTypes env (name, spec) dcs = Ms.dataDecls spec vdcs = Ms.dvariance spec +makeClassDataDecl :: Bare.Env -> (ModName, Ms.BareSpec) -> [DataDecl] +makeClassDataDecl env (m, spec) = classDeclToDataDecl env m <$> Ms.classes spec + +makeClassDataDecl' :: [(Ghc.Class, [(Ghc.Id, LocBareType)])] -> [DataDecl] +makeClassDataDecl' = fmap (uncurry classDeclToDataDecl') + +classDeclToDataDecl' :: Ghc.Class -> [(Ghc.Id, LocBareType)] -> DataDecl +classDeclToDataDecl' cls refinedIds = F.tracepp "classDeclToDataDecl" $ DataDecl + { tycName = DnName (F.symbol <$> GM.locNamedThing cls) + , tycTyVars = tyVars + , tycPVars = [] + , tycDCons = [dctor] + , tycSrcPos = F.loc . GM.locNamedThing $ cls + , tycSFun = Nothing + , tycPropTy = Nothing + , tycKind = DataUser} + -- YL: assume the class constraint is at the very front.. + where dctor = DataCtor + { dcName = F.dummyLoc $ F.symbol classDc + -- YL: same as class tyvars?? + , dcTyVars = tyVars + -- YL: what is theta? + , dcTheta = [] + , dcFields = fields + , dcResult = Nothing + } + + tyVars = F.symbol <$> Ghc.classTyVars cls + + fields = fmap attachRef classIds + attachRef sid + | Just ref <- L.lookup sid refinedIds + = (F.symbol sid, RT.subts tyVarSubst (F.val ref)) + | otherwise + = (F.symbol sid, RT.bareOfType . dropPred . Ghc.varType $ sid) + + tyVarSubst = [(GM.dropModuleUnique v, v) | v <- tyVars] + + dropPred :: Ghc.Type -> Ghc.Type + dropPred (Ghc.ForAllTy _ (Ghc.FunTy _ τ')) = τ' + dropPred (Ghc.ForAllTy _ (Ghc.ForAllTy _ _)) = todo Nothing "multi-parameter type-class not supported" + dropPred _ = impossible Nothing "classDeclToDataDecl': assumption was wrong" + + -- YL: what is the type of superclass-dictionary selectors? + classIds = Ghc.classAllSelIds cls + classDc = Ghc.classDataCon cls + + + +classDeclToDataDecl :: Bare.Env -> ModName -> RClass LocBareType -> DataDecl +classDeclToDataDecl env m rcls = DataDecl + { tycName = DnName (btc_tc . rcName $ rcls) + , tycTyVars = as + , tycPVars = [] + , tycDCons = [dctor] + , tycSrcPos = F.loc . btc_tc . rcName $ rcls + , tycSFun = Nothing + , tycPropTy = Nothing + , tycKind = DataUser} + -- YL : fix it + where Just classTc = (Bare.maybeResolveSym env m "makeClassDataDecl" . btc_tc . rcName $ rcls) >>= Ghc.tyConClass_maybe + classDc = Ghc.classDataCon classTc + as = F.symbol <$> rcTyVars rcls + dctor = DataCtor + { dcName = F.dummyLoc $ F.symbol classDc + , dcTyVars = as + , dcTheta = [] + , dcFields = (F.val *** F.val) <$> rcMethods rcls + , dcResult = Nothing} + + -- | 'canonizeDecls ds' returns a subset of 'ds' with duplicates, e.g. arising -- due to automatic lifting (via 'makeHaskellDataDecls'). We require that the -- lifted versions appear LATER in the input list, and always use those @@ -659,16 +735,18 @@ makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne where makeOne (Loc l l' dcp) - | null fls -- no field labels + | (null fls && Mb.isNothing maybe_cls) -- no field labels || any (isFunTy . snd) args && not (higherOrderFlag env) -- OR function-valued fields || dcpIsGadt dcp -- OR GADT style datcon = [] | otherwise - = [ (v, t) | (Just v, t) <- zip fs ts ] + = [ (v, F.tracepp "selectorSig" t) | (Just v, t) <- zip fs ts ] where + maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc) dc = dcpCon dcp fls = Ghc.dataConFieldLabels dc - fs = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls + fs = Bare.lookupGhcNamedVar env name <$> + Mb.maybe (fmap Ghc.flSelector fls) (fmap Ghc.getName . Ghc.classAllSelIds) maybe_cls ts :: [ LocSpecType ] ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) [] [] [(z, res, mempty)] diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 06f51ede6a..ea5394ab7d 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -223,7 +223,7 @@ canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs) renameDictBinder [] _ = id renameDictBinder _ [] = id renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl - where tbl = F.tracepp "TBL" $ M.fromList (zip ds canonicalDs) + where tbl = F.notracepp "TBL" $ M.fromList (zip ds canonicalDs) elaborateSpecType @@ -233,7 +233,7 @@ elaborateSpecType -> Ghc (SpecType, [F.Symbol]) -- binders for dictionaries -- should have returned Maybe [F.Symbol] elaborateSpecType partialTp coreToLogic t = - case F.tracepp "elaborateSpecType" t of + case F.notracepp "elaborateSpecType" t of RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do elaborateReft (reft, t) diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 8b3163a05d..57e3050979 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -606,6 +606,9 @@ instance Hashable TyCon where instance Hashable DataCon where hashWithSalt = uniqueHash +instance Hashable Class where + hashWithSalt = uniqueHash + instance Fixpoint Var where toFix = pprDoc @@ -792,6 +795,23 @@ ignoreCoreBinds vs cbs go (Rec xes) = [Rec (filter ((`notElem` vs) . fst) xes)] +findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr) +findVarDefMethod x cbs = + case rcbs of + (NonRec v def : _ ) -> Just (v, def) + (Rec [(v, def)] : _ ) -> Just (v, def) + _ -> Nothing + where + rcbs = if isMethod x then mCbs else xCbs + xCbs = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb ] + mCbs = [ cb | cb <- concatMap unRec cbs, x `elem` methodSymbols cb] + unRec (Rec xes) = [NonRec x es | (x,es) <- xes] + unRec nonRec = [nonRec] + + +methodSymbols :: CoreBind -> [Symbol] +methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders + findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr) findVarDef x cbs = case xCbs of (NonRec v def : _ ) -> Just (v, def) diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs index c09ac19796..9a63113250 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -247,7 +247,7 @@ coreToFun :: LocSymbol -> Var -> C.CoreExpr -> LogicM ([Var], Either Expr Expr) coreToFun _ _v e = go [] $ normalize e where go acc (C.Lam x e) | isTyVar x = go acc e - go acc (C.Lam x e) | isErasable x = go acc e + go acc (C.Lam x e) | GM.isEmbeddedDictVar x = go acc e go acc (C.Lam x e) = go (x:acc) e go acc (C.Tick _ e) = go acc e go acc e = (reverse acc,) . Right <$> coreToLg e @@ -478,7 +478,7 @@ splitArgs e = (f, reverse es) (f, es) = go e go (C.App (C.Var i) e) | ignoreVar i = go e - go (C.App f (C.Var v)) | isErasable v = go f + go (C.App f (C.Var v)) | GM.isEmbeddedDictVar v = go f go (C.App f e) = (f', e:es) where (f', es) = go f go f = (f, []) @@ -536,19 +536,19 @@ isBangInteger [(C.DataAlt s, _, _), (C.DataAlt jp,_,_), (C.DataAlt jn,_,_)] && symbol jn == "GHC.Integer.Type.Jn#" isBangInteger _ = False -isErasable :: Id -> Bool -isErasable v = F.tracepp msg $ False -- isGhcSplId v && not (isDCId v) - where - msg = "isErasable: " ++ GM.showPpr (v, Var.idDetails v) +-- isErasable :: Id -> Bool +-- isErasable v = F.tracepp msg $ False -- isGhcSplId v && not (isDCId v) +-- where +-- msg = "isErasable: " ++ GM.showPpr (v, Var.idDetails v) -isGhcSplId :: Id -> Bool -isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v) +-- isGhcSplId :: Id -> Bool +-- isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v) -isDCId :: Id -> Bool -isDCId v = case Var.idDetails v of - DataConWorkId _ -> True - DataConWrapId _ -> True - _ -> False +-- isDCId :: Id -> Bool +-- isDCId v = case Var.idDetails v of +-- DataConWorkId _ -> True +-- DataConWrapId _ -> True +-- _ -> False isANF :: Id -> Bool isANF v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v) @@ -573,7 +573,7 @@ instance Simplify C.CoreExpr where = e simplify (C.App e (C.Type _)) = simplify e - simplify (C.App e (C.Var dict)) | isErasable dict + simplify (C.App e (C.Var dict)) | GM.isEmbeddedDictVar dict = simplify e simplify (C.App (C.Lam x e) _) | isDead x = simplify e @@ -581,13 +581,13 @@ instance Simplify C.CoreExpr where = C.App (simplify e1) (simplify e2) simplify (C.Lam x e) | isTyVar x = simplify e - simplify (C.Lam x e) | isErasable x + simplify (C.Lam x e) | GM.isEmbeddedDictVar x = simplify e simplify (C.Lam x e) = C.Lam x (simplify e) - simplify (C.Let (C.NonRec x _) e) | isErasable x + simplify (C.Let (C.NonRec x _) e) | GM.isEmbeddedDictVar x = simplify e - simplify (C.Let (C.Rec xes) e) | all (isErasable . fst) xes + simplify (C.Let (C.Rec xes) e) | all (GM.isEmbeddedDictVar . fst) xes = simplify e simplify (C.Let xes e) = C.Let (simplify xes) (simplify e) diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs index 99f0a458a2..1173b4d00a 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -1260,7 +1260,7 @@ instance SubsTy Symbol Symbol (BRType r) where subt su (RAppTy t1 t2 r) = RAppTy (subt su t1) (subt su t2) r subt su (RRTy e r o t) = RRTy [(x, subt su p) | (x,p) <- e] r o (subt su t) subt _ (RHole r) = RHole r - + instance SubsTy Symbol Symbol (RTProp BTyCon BTyVar r) where subt su (RProp e t) = RProp [(x, subt su xt) | (x,xt) <- e] (subt su t) From 1597fbc69cfa1dc88aea76bd42272907948f92c0 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 9 Feb 2020 15:07:35 -0500 Subject: [PATCH 07/38] add SemigroupOp.hs example. clean up tracepp --- src/Language/Haskell/Liquid/Bare.hs | 6 ++--- src/Language/Haskell/Liquid/Bare/Axiom.hs | 2 +- src/Language/Haskell/Liquid/Bare/DataType.hs | 6 ++--- src/Language/Haskell/Liquid/Bare/Measure.hs | 2 +- src/Language/Haskell/Liquid/Bare/Misc.hs | 2 +- .../Haskell/Liquid/Constraint/Generate.hs | 2 +- .../Haskell/Liquid/Constraint/ToFixpoint.hs | 11 -------- src/Language/Haskell/Liquid/Types/RefType.hs | 2 +- tests/refined-classes/SemigroupOp.hs | 27 +++++++++++++++++++ 9 files changed, 38 insertions(+), 22 deletions(-) create mode 100644 tests/refined-classes/SemigroupOp.hs diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 24ce96e45c..964770279e 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -234,9 +234,9 @@ compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec Just vs -> Just (sig:vs) -- instance methods - methods = F.tracepp "methods" [ F.symbol <$> GM.locNamedThing x | + methods = F.notracepp "methods" [ F.symbol <$> GM.locNamedThing x | (d, e) <- concatMap unRec (giCbs src) - , F.tracepp (F.showpp (F.symbol d)) (Ghc.isDFunId d) + , F.notracepp (F.showpp (F.symbol d)) (Ghc.isDFunId d) , cls <- Mb.maybeToList $ L.lookup d instClss , cls `elem` refinedClasses , x <- freeVars mempty e @@ -282,7 +282,7 @@ compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec insts = mconcat . Mb.maybeToList . gsCls $ src instClss :: [(Ghc.DFunId, Ghc.Class)] - instClss = fmap (\inst -> (GM.tracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ Ghc.is_dfun inst, Ghc.is_cls inst)) $ + instClss = fmap (\inst -> (GM.notracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ Ghc.is_dfun inst, Ghc.is_cls inst)) $ insts refinedClasses :: [Ghc.Class] diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs index b47ab496a3..117902c1d2 100644 --- a/src/Language/Haskell/Liquid/Bare/Axiom.hs +++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs @@ -106,7 +106,7 @@ rTypeSortExp tce = typeSort tce . Ghc.expandTypeSynonyms . toType grabBody :: Ghc.Type -> Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr) grabBody (Ghc.ForAllTy _ t) e = grabBody t e -grabBody (Ghc.FunTy tx t) e | Ghc.isClassPred tx +grabBody (Ghc.FunTy tx t) e | isEmbeddedDictType tx = grabBody t e grabBody (Ghc.FunTy _ t) (Ghc.Lam x e) = (x:xs, e') where (xs, e') = grabBody t e diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index bfd63597be..de13d0f6a8 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -605,12 +605,12 @@ ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataCo } where c' = Bare.lookupGhcDataCon env name "ofBDataCtor" c - ts' = F.notracepp "OHQO" $ Bare.ofBareType env name l (Just ps) <$> ts + ts' = F.notracepp "ofBDataCtorts'" $ Bare.ofBareType env name l (Just ps) <$> ts res' = Bare.ofBareType env name l (Just ps) <$> res t0' = dataConResultTy c' αs t0 res' _cfg = getConfig env (yts, ot) = -- F.notracepp ("dataConTys: " ++ F.showpp (c, αs)) $ - F.notracepp "OHQO2" $ qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') + F.notracepp "ofBDataCtoryts" $ qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') zts = zipWith (normalizeField c') [1..] (reverse yts) usedTvs = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts')) cs = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ] @@ -740,7 +740,7 @@ makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne || dcpIsGadt dcp -- OR GADT style datcon = [] | otherwise - = [ (v, F.tracepp "selectorSig" t) | (Just v, t) <- zip fs ts ] + = [ (v, F.notracepp "selectorSig" t) | (Just v, t) <- zip fs ts ] where maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc) dc = dcpCon dcp diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs index 13d8bf8a5d..b10077b420 100644 --- a/src/Language/Haskell/Liquid/Bare/Measure.hs +++ b/src/Language/Haskell/Liquid/Bare/Measure.hs @@ -79,7 +79,7 @@ makeUnSorted t defs ta = go $ Ghc.expandTypeSynonyms t go (Ghc.ForAllTy _ t) = go t - go (Ghc.FunTy p t) | Ghc.isClassPred p = go t + go (Ghc.FunTy p t) | GM.isEmbeddedDictType p = go t go (Ghc.FunTy t _) = t go t = t -- this should never happen! diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs index 6939fd76f9..05f5c8fbf9 100644 --- a/src/Language/Haskell/Liquid/Bare/Misc.hs +++ b/src/Language/Haskell/Liquid/Bare/Misc.hs @@ -96,7 +96,7 @@ mapTyVars :: Type -> SpecType -> StateT MapTyVarST (Either Error) () mapTyVars t (RImpF _ _ t' _) = mapTyVars t t' mapTyVars (FunTy τ τ') t - | isClassPred τ + | isEmbeddedDictType τ = mapTyVars τ' t mapTyVars (FunTy τ τ') (RFun _ t t' _) = mapTyVars τ t >> mapTyVars τ' t' diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index 239d3f4f3b..f648d0147b 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -1382,7 +1382,7 @@ funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr -- reflectefd functions funExpr γ (Var v) | M.member v $ aenv γ - = F.EVar <$> (M.lookup v $ aenv γ) + = F.notracepp "funExpr" $F.EVar <$> (M.lookup v $ aenv γ) -- local function arguments funExpr γ (Var v) | S.member v (fargs γ) || GM.isDataConId v diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs index e507a9a7df..2332419074 100644 --- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -85,17 +85,6 @@ makeAxiomEnvironment info xts fcs cfg = getConfig info sp = giSpec info -_isClassOrDict :: Id -> Bool -_isClassOrDict x = F.notracepp ("isClassOrDict: " ++ F.showpp x) - $ (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x)) - -hasClassArg :: Id -> Bool -hasClassArg x = F.notracepp msg $ (GM.isDataConId x && any Ghc.isClassPred (t:ts)) - where - msg = "hasClassArg: " ++ showpp (x, t:ts) - (ts, t) = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x - - doExpand :: GhcSpec -> Config -> F.SubC Cinfo -> Bool doExpand sp cfg sub = Config.allowGlobalPLE cfg || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub)) diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs index 1173b4d00a..37579167bc 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -1679,7 +1679,7 @@ grabArgs τs τ = reverse (τ:τs) isNonValueTy :: Type -> Bool -isNonValueTy t = {- Ghc.isPredTy -} isClassPred t || isEqPred t +isNonValueTy t = GM.isEmbeddedDictType t expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r)) diff --git a/tests/refined-classes/SemigroupOp.hs b/tests/refined-classes/SemigroupOp.hs new file mode 100644 index 0000000000..4915bafedf --- /dev/null +++ b/tests/refined-classes/SemigroupOp.hs @@ -0,0 +1,27 @@ +{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--extensionality" @-} +{-@ LIQUID "--ple" @-} +module SemigroupOp where + +class YYSemigroup a where + ymappend :: a -> a -> a + {-@ lawAssociative :: v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} + lawAssociative :: a -> a -> a -> () + +data Op a = Op a + +{-@ reflect mappendOp @-} +mappendOp :: (YYSemigroup a) => Op a -> Op a -> Op a +mappendOp (Op x) (Op y) = Op (ymappend y x) + +{-@ lawAssociativeOp :: YYSemigroup a => v:Op a -> v':Op a -> v'':Op a -> {mappendOp (mappendOp v v') v'' == mappendOp v (mappendOp v' v'') }@-} +lawAssociativeOp :: YYSemigroup a => Op a -> Op a -> Op a -> () +lawAssociativeOp (Op x) (Op y) (Op z) = lawAssociative z y x + +{-@ mylawAssociative :: YYSemigroup a => v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} +mylawAssociative :: YYSemigroup a => a -> a -> a -> () +mylawAssociative x y z = lawAssociative x y z + +instance (YYSemigroup a) => YYSemigroup (Op a) where + ymappend = mappendOp + lawAssociative x y z = lawAssociativeOp x y z From 20e8c04abd832272915d01be271e36186004843c Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 13 Feb 2020 14:10:26 -0500 Subject: [PATCH 08/38] add subclass (constraint generation failed) --- src/Language/Haskell/Liquid/Bare.hs | 145 ++++++++++++------ src/Language/Haskell/Liquid/Bare/Axiom.hs | 2 +- src/Language/Haskell/Liquid/Bare/DataType.hs | 136 ++++++++++++++-- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 66 +++++--- .../Haskell/Liquid/Constraint/Generate.hs | 6 +- src/Language/Haskell/Liquid/GHC/Misc.hs | 25 ++- src/Language/Haskell/Liquid/Measure.hs | 4 +- src/Language/Haskell/Liquid/Types/PredType.hs | 22 ++- tests/refined-classes/SemigroupOp.hs | 49 ++++++ tests/refined-classes/Subclass.hs | 27 ++++ 10 files changed, 385 insertions(+), 97 deletions(-) create mode 100644 tests/refined-classes/Subclass.hs diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 964770279e..c6fb3c0945 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -24,8 +24,6 @@ module Language.Haskell.Liquid.Bare ( import Prelude hiding (error) import Control.Monad (unless) import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.IO.Class (liftIO) import qualified Control.Exception as Ex import qualified Data.Binary as B import qualified Data.Maybe as Mb @@ -58,7 +56,6 @@ import qualified Language.Haskell.Liquid.Bare.Class as Bare import qualified Language.Haskell.Liquid.Bare.Check as Bare import qualified Language.Haskell.Liquid.Bare.Laws as Bare import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic -import qualified Language.Haskell.Liquid.Transforms.ANF as ANF import Control.Arrow (second) -------------------------------------------------------------------------------- @@ -140,7 +137,22 @@ ghcSpecEnv sp = fromListSEnv binds makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- makeGhcSpec0 cfg src lmap mspecsNoClass = do + tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg + let lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 + mySpec = mySpec2 <> lSpec1 + specs = M.insert name mySpec iSpecs2 + measEnv <- makeMeasEnv coreToLg env tycEnv sigEnv specs + let myRTE = myRTEnv src env sigEnv rtEnv + qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs + sData = makeSpecData src env sigEnv measEnv sig specs + refl = makeSpecRefl cfg src measEnv specs env name sig tycEnv + laws = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs + sig = makeSpecSig cfg name specs env sigEnv tycEnv measEnv (giCbs src) + -- liftIO $ putStrLn "Before" + -- liftIO $ putStrLn$ F.showpp (gsTySigs sig) + -- liftIO $ putStrLn "After" elaboratedSig <- elaborateSig sig + -- liftIO $ putStrLn$ F.showpp (gsTySigs elaboratedSig) pure $ SP { gsConfig = cfg , gsImps = makeImports mspecs @@ -160,36 +172,35 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do } where -- build up spec components - coreToLg e = case CoreToLogic.runToLogic embs lmap dm - (\x -> todo Nothing ("ctl not working " ++ x)) (CoreToLogic.coreToLogic e) - of Left _ -> impossible Nothing "can't reach here" - Right e -> e + coreToLg e = + case CoreToLogic.runToLogic + embs + lmap + dm + (\x -> todo Nothing ("ctl not working " ++ x)) + (CoreToLogic.coreToLogic e) of + Left _ -> impossible Nothing "can't reach here" + Right e -> e elaborateSig si = do - tySigs <- forM (gsTySigs si) $ \(x, t) -> do - t' <- traverse (elaborateSpecType (pure ()) coreToLg) t - pure (x, fst <$> t') + tySigs <- + forM (gsTySigs si) $ \(x, t) -> do + t' <- traverse (elaborateSpecType coreToLg) t + pure (x, fst <$> t') -- things like len breaks the code -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do -- t' <- traverse (elaborateSpecType (pure ()) coreToLg) t -- pure (x, fst <$> t') - pure si {gsTySigs = tySigs-- , gsAsmSigs = asmSigs - } - dm = Bare.tcDataConMap tycEnv - myRTE = myRTEnv src env sigEnv rtEnv - qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs - sData = makeSpecData src env sigEnv measEnv sig specs - refl = makeSpecRefl cfg src measEnv specs env name sig tycEnv - laws = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs - sig = makeSpecSig cfg name specs env sigEnv tycEnv measEnv (giCbs src) - measEnv = makeMeasEnv env tycEnv sigEnv specs + pure + si + { gsTySigs = tySigs -- , gsAsmSigs = asmSigs + } + + dm = Bare.tcDataConMap tycEnv0 -- build up environments - specs = M.insert name mySpec iSpecs2 - mySpec = mySpec2 <> lSpec1 - lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 sigEnv = makeSigEnv embs tyi (gsExports src) rtEnv - tyi = Bare.tcTyConMap tycEnv - tycEnv = makeTycEnv cfg name env embs mySpec2 iSpecs2 + tyi = Bare.tcTyConMap tycEnv0 + (tycEnv0, datacons) = makeTycEnv0 cfg name env embs mySpec2 iSpecs2 mySpec2 = Bare.qualifyExpand env name rtEnv l [] mySpec1 where l = F.dummyPos "expand-mySpec2" iSpecs2 = Bare.qualifyExpand env name rtEnv l [] iSpecs0 where l = F.dummyPos "expand-iSpecs2" rtEnv = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap @@ -210,7 +221,8 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do compileClasses :: GhcSrc -> Bare.Env -> (ModName, Ms.BareSpec) -> [(ModName, Ms.BareSpec)] -> Ms.BareSpec compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec - where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList methods-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs + where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList (-- F.dummyLoc (F.symbol ("$fMyFunctorMyId" :: String)): + methods)-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs } clsDecls = Bare.makeClassDataDecl' (M.toList refinedMethods) @@ -603,7 +615,7 @@ makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = SpSig where dicts = Bare.makeSpecDictionaries env sigEnv specs mySpec = M.lookupDefault mempty name specs - asmSigs = Bare.tcSelVars tycEnv + asmSigs = (F.notracepp "tcSelVars" $ Bare.tcSelVars tycEnv ) ++ makeAsmSigs env sigEnv name specs ++ [ (x,t) | (_, x, t) <- concat $ map snd (Bare.meCLaws measEnv)] tySigs = strengthenSigs . concat $ @@ -821,8 +833,9 @@ makeSpecData src env sigEnv measEnv sig specs = SpData { gsCtors = F.notracepp "GS-CTORS" [ (x, tt) | (x, t) <- Bare.meDataCons measEnv - , let tt = Bare.plugHoles sigEnv name (Bare.LqTV x) t - ] + , let tt = id t -- Bare.plugHoles sigEnv name (Bare.LqTV x) + ] + , gsMeas = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ] , gsMeasures = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2) , gsInvariants = Misc.nubHashOn (F.loc . snd) invs @@ -932,20 +945,21 @@ makeSpecName env tycEnv measEnv name = SpNames -- REBARE: formerly, makeGhcCHOP1 ------------------------------------------------------------------------------------------- -makeTycEnv :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs - -> Bare.TycEnv +makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs + -> (Bare.TycEnv, [Located DataConP]) ------------------------------------------------------------------------------------------- -makeTycEnv cfg myName env embs mySpec iSpecs = Bare.TycEnv +makeTycEnv0 cfg myName env embs mySpec iSpecs = (Bare.TycEnv { tcTyCons = tycons - , tcDataCons = val <$> datacons - , tcSelMeasures = dcSelectors - , tcSelVars = recSelectors + , tcDataCons = mempty + , tcSelMeasures = dcSelectors + , tcSelVars = mempty + -- , tcSelVars = recSelectors , tcTyConMap = tyi , tcAdts = adts , tcDataConMap = dm , tcEmbs = embs , tcName = myName - } + }, datacons) where (tcDds, dcs) = Misc.concatUnzip $ Bare.makeConTypes env <$> specs specs = (myName, mySpec) : M.toList iSpecs @@ -954,14 +968,37 @@ makeTycEnv cfg myName env embs mySpec iSpecs = Bare.TycEnv -- tycons = F.notracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons -- datacons = Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.notracepp "DATACONS" $ concat dcs) wiredDataCons) tycons = tcs ++ knownWiredTyCons env myName - datacons = Bare.makePluggedDataCon embs tyi <$> (concat dcs ++ knownWiredDataCons env myName) + datacons = F.notracepp "makeTycEnv: datacons" $ Bare.makePluggedDataCon embs tyi <$> (concat dcs ++ knownWiredDataCons env myName) tds = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds] adts = Bare.makeDataDecls cfg embs myName tds datacons dm = Bare.dataConMap adts dcSelectors = concatMap (Bare.makeMeasureSelectors cfg dm) datacons - recSelectors = Bare.makeRecordSelectorSigs env myName datacons + -- recSelectors = Bare.makeRecordSelectorSigs env myName datacons fiTcs = gsFiTcs (Bare.reSrc env) - + + +makeTycEnv1 :: + ModName + -> Bare.Env + -> (Bare.TycEnv, [Located DataConP]) + -> (Ghc.CoreExpr -> F.Expr) + -> Ghc.Ghc Bare.TycEnv +makeTycEnv1 myName env (tycEnv, datacons) coreToLg = do + -- fst for selector generation, snd for dataconsig generation + lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg) + let recSelectors = Bare.makeRecordSelectorSigs env myName (dcs ++ (fmap . fmap) snd lclassdcs) + pure $ + tycEnv {Bare.tcSelVars = recSelectors, Bare.tcDataCons = F.val <$> ((fmap . fmap) fst lclassdcs ++ dcs )} + where + (classdcs, dcs) = + L.partition + (Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon . F.val) + datacons + + + + + knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP] knownWiredDataCons env name = filter isKnown wiredDataCons where @@ -975,17 +1012,23 @@ knownWiredTyCons env name = filter isKnown wiredTyCons -- REBARE: formerly, makeGhcCHOP2 ------------------------------------------------------------------------------------------- -makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Bare.MeasEnv +makeMeasEnv :: (Ghc.CoreExpr -> F.Expr) -> Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Ghc.Ghc Bare.MeasEnv ------------------------------------------------------------------------------------------- -makeMeasEnv env tycEnv sigEnv specs = Bare.MeasEnv - { meMeasureSpec = measures - , meClassSyms = cms' - , meSyms = ms' - , meDataCons = cs' - , meClasses = cls - , meMethods = mts ++ dms - , meCLaws = laws - } +makeMeasEnv coreToLg env tycEnv sigEnv specs = do + -- datacons' <- forM datacons $ \dc -> + -- if Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon $ dc + -- then Bare.elaborateClassDcp coreToLg dc + -- else pure dc + let cs' = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec embs cs (datacons ++ cls)] + pure $ Bare.MeasEnv + { meMeasureSpec = measures + , meClassSyms = cms' + , meSyms = ms' + , meDataCons = cs' + , meClasses = cls + , meMethods = mts ++ dms + , meCLaws = laws + } where measures = mconcat (Ms.mkMSpec' dcSelectors : (Bare.makeMeasureSpec env sigEnv name <$> M.toList specs)) (cs, ms) = Bare.makeMeasureSpec' measures @@ -993,12 +1036,12 @@ makeMeasEnv env tycEnv sigEnv specs = Bare.MeasEnv cms' = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ] ms' = [ (F.val lx, F.atLoc lx t) | (lx, t) <- ms , Mb.isNothing (lookup (val lx) cms') ] - cs' = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec embs cs (datacons ++ cls)] + txRefs v t = Bare.txRefSort tyi embs (const t <$> GM.locNamedThing v) -- unpacking the environment tyi = Bare.tcTyConMap tycEnv dcSelectors = Bare.tcSelMeasures tycEnv - datacons = Bare.tcDataCons tycEnv + datacons = F.notracepp "tcDataCons" $ Bare.tcDataCons tycEnv embs = Bare.tcEmbs tycEnv name = Bare.tcName tycEnv dms = Bare.makeDefaultMethods env mts diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs index 117902c1d2..b44fea92aa 100644 --- a/src/Language/Haskell/Liquid/Bare/Axiom.hs +++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs @@ -55,7 +55,7 @@ getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr) findVarDefType cbs sigs x = case findVarDefMethod (val x) cbs of - Just (v, e) -> if Ghc.isExportedId v || isMethod (F.symbol x) + Just (v, e) -> if Ghc.isExportedId v || isMethod (F.symbol x) || isDictionary (F.symbol x) then (F.notracepp "FIND-VAR-DEF-NAME" $ x, F.notracepp "FIND-VAR-DEF" $ val <$> lookup v sigs, v, e) else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v) Nothing -> Ex.throw $ mkError x "Cannot lift haskell function" diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index de13d0f6a8..ccc5ac9cbe 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Liquid.Bare.DataType ( dataConMap @@ -20,6 +21,8 @@ module Language.Haskell.Liquid.Bare.DataType -- * Type Classes , makeClassDataDecl , makeClassDataDecl' + , elaborateClassDcp + , stripDataConPPred ) where @@ -36,6 +39,7 @@ import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.Maybe as Mb import Control.Arrow ((***)) +import Control.Monad -- import qualified Language.Fixpoint.Types.Visitor as V import qualified Language.Fixpoint.Types as F @@ -52,7 +56,8 @@ import Language.Haskell.Liquid.WiredIn import qualified Language.Haskell.Liquid.Measure as Ms import qualified Language.Haskell.Liquid.Bare.Types as Bare -import qualified Language.Haskell.Liquid.Bare.Resolve as Bare +import qualified Language.Haskell.Liquid.Bare.Resolve as Bare +import Language.Haskell.Liquid.Bare.Elaborate -- import qualified Language.Haskell.Liquid.Bare.Misc as GM -- import Language.Haskell.Liquid.Bare.Env @@ -356,7 +361,7 @@ meetDataConSpec :: F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP] -> [(Ghc.Var, SpecType)] -------------------------------------------------------------------------------- meetDataConSpec emb xts dcs = F.notracepp "meetDataConSpec" $ - M.toList $ snd <$> L.foldl' upd dcm0 xts + M.toList $ snd <$> L.foldl' upd dcm0 (F.notracepp "meetDataConSpec xts" xts) where dcm0 = M.fromList (dataConSpec' dcs) upd dcm (x, t) = M.insert x (Ghc.getSrcSpan x, tx') dcm @@ -419,14 +424,15 @@ classDeclToDataDecl' cls refinedIds = F.tracepp "classDeclToDataDecl" $ DataDecl | Just ref <- L.lookup sid refinedIds = (F.symbol sid, RT.subts tyVarSubst (F.val ref)) | otherwise - = (F.symbol sid, RT.bareOfType . dropPred . Ghc.varType $ sid) + = (F.symbol sid, RT.bareOfType . dropTheta . Ghc.varType $ sid) tyVarSubst = [(GM.dropModuleUnique v, v) | v <- tyVars] - dropPred :: Ghc.Type -> Ghc.Type - dropPred (Ghc.ForAllTy _ (Ghc.FunTy _ τ')) = τ' - dropPred (Ghc.ForAllTy _ (Ghc.ForAllTy _ _)) = todo Nothing "multi-parameter type-class not supported" - dropPred _ = impossible Nothing "classDeclToDataDecl': assumption was wrong" + dropTheta :: Ghc.Type -> Ghc.Type + dropTheta = GM.notracePpr "Dropping pred" . Misc.thd3 . GM.splitThetaTy + -- dropTheta (Ghc.ForAllTy _ (Ghc.FunTy _ τ')) = τ' + -- dropTheta (Ghc.ForAllTy _ (Ghc.ForAllTy _ _)) = todo Nothing "multi-parameter type-class not supported" + -- dropTheta _ = impossible Nothing "classDeclToDataDecl': assumption was wrong" -- YL: what is the type of superclass-dictionary selectors? classIds = Ghc.classAllSelIds cls @@ -455,6 +461,102 @@ classDeclToDataDecl env m rcls = DataDecl , dcFields = (F.val *** F.val) <$> rcMethods rcls , dcResult = Nothing} +-- makeClassDataConP :: Bare.Env +-- -> (Ghc.Class, [(Ghc.Id, LocBareType)], [Ghc.ClsInst]) +-- -> DataConP +-- makeClassDataConP env (cls, sigs, insts) = _ +-- where +-- -- YL: This function is partial. Fails when the class is a newtype +-- Just name = Ghc.nameModule_maybe (Ghc.getName cls) +-- c' = Ghc.classDataCon cls +-- -- resolved field signatures. need to automatically generate the missing ones +-- ts' = Bare.ofBareType env _modulename _loc_beg Nothing <$> _ts +-- -- result type +-- t0' = RT.ofType $ Ghc.dataConOrigResTy c' +-- _cfg = getConfig env +-- -- don't need this step +-- -- (yts, ot) = qualifyDataCtor (not isGadt) name dLoc (zip ) +-- dLoc = F.Loc _loc_beg _loc_end + +elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> DataConP -> Ghc.Ghc (DataConP , DataConP) +elaborateClassDcp coreToLg dcp = do + t' <- forM fts $ elaborateSpecType coreToLg + let ts' = F.tracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> (fst <$> t') + pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = zip xs (fst <$> t')}) + where + resTy = dcpTyRes dcp + dc = dcpCon dcp + tvars = + F.notracepp "tvars" $ (\x -> (makeRTVar x, mempty)) <$> dcpFreeTyVars dcp + -- check if the names are qualified + (xs, ts) = F.notracepp "elaborateClassDcpxts" $ unzip (dcpTyArgs dcp) + fts = fullTy <$> ts + -- turns forall a b. (a -> b) -> f a -> f b into + -- forall f. Functor f => forall a b. (a -> b) -> f a -> f b + stripPred :: SpecType -> SpecType + stripPred t = mkUnivs tvs pvs tres + where (tvs, pvs, _, tres) = bkUnivClass t + fullTy :: SpecType -> SpecType + fullTy t = + F.notracepp "fullTy" $ + mkArrow tvars [] [] [(F.symbol dc, F.notracepp "resTy" resTy, mempty)] t + +substClassOpBinding :: + F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr +substClassOpBinding tcbind dc methods e = F.notracepp "substClassOpBinding" $ go e + where + go :: F.Expr -> F.Expr + go (F.EApp e0 e1) + | F.EVar x <- F.notracepp "e0" e0 + , F.EVar y <- F.notracepp "e1" e1 + , F.notracepp "tcbindeq" $ y == tcbind + , S.member x methods + -- Before: Functor.fmap ($p1Applicative $dFunctor) + -- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative) + = F.EVar (x `F.suffixSymbol` dc) + | otherwise + = F.EApp (go e0) (go e1) + go (F.ENeg e) = F.ENeg (go e) + go (F.EBin bop e0 e1) = F.EBin bop (go e0) (go e1) + go (F.EIte e0 e1 e2) = F.EIte (go e0) (go e1) (go e2) + go (F.ECst e0 s) = F.ECst (go e0) s + go (F.ELam (x, t) body) = F.ELam (x, t) (go body) + go (F.PAnd es) = F.PAnd (go <$> es) + go (F.POr es) = F.POr (go <$> es) + go (F.PNot e) = F.PNot (go e) + go (F.PImp e0 e1) = F.PImp (go e0) (go e1) + go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1) + go e = F.notracepp "LEAF" e + +-- fmap f x == ap ... into +-- fmap ($p1Selector $dMyFunctor) f x == (ap $dMyFunctor) f x +-- fmap $p1Selector##MyFunctor f x = ap##MyFunctor f x +elaborateMethod :: + F.Symbol + -> S.HashSet F.Symbol + -> SpecType + -> SpecType +elaborateMethod dc methods t = + let tcbind = grabtcbind t in + mapExprReft (\_ -> substClassOpBinding (F.notracepp "tcbind" tcbind) dc methods) t + where + grabtcbind :: SpecType -> F.Symbol + grabtcbind t = + F.notracepp "grabtcbind" $ + case Misc.fst3 . Misc.snd3 . bkArrow . Misc.thd3 $ (F.notracepp "univ broken" $ bkUniv t) of + tcbind:_ -> tcbind + [] -> + impossible + Nothing + ("elaborateMethod: inserted dictionary binder disappeared:" ++ F.showpp t) + + +stripDataConPPred :: DataConP -> DataConP +stripDataConPPred dcp = dcp {dcpTyArgs = fmap (\(x,t) -> (x, stripPred t)) yts} + where stripPred :: SpecType -> SpecType + stripPred t = mkUnivs tvs pvs tres + where (tvs, pvs, _, tres) = bkUnivClass t + yts = dcpTyArgs dcp -- | 'canonizeDecls ds' returns a subset of 'ds' with duplicates, e.g. arising -- due to automatic lifting (via 'makeHaskellDataDecls'). We require that the @@ -549,7 +651,7 @@ ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invar | not (checkDataDecl tc' dd) = uError err | otherwise - = ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts') + = ((name, tcp, Just (dd { tycDCons = cts }, pd)), F.notracepp "ofBDataDecl" $ Loc lc lc' <$> cts') where πs = Bare.ofBPVar env name pos <$> ps tc' = getDnTyCon env name tc @@ -607,14 +709,14 @@ ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataCo c' = Bare.lookupGhcDataCon env name "ofBDataCtor" c ts' = F.notracepp "ofBDataCtorts'" $ Bare.ofBareType env name l (Just ps) <$> ts res' = Bare.ofBareType env name l (Just ps) <$> res - t0' = dataConResultTy c' αs t0 res' - _cfg = getConfig env + t0' = F.notracepp "ofBDataCtort0'" $ dataConResultTy c' αs t0 res' + _cfg = getConfig env (yts, ot) = -- F.notracepp ("dataConTys: " ++ F.showpp (c, αs)) $ F.notracepp "ofBDataCtoryts" $ qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0') - zts = zipWith (normalizeField c') [1..] (reverse yts) + zts = F.notracepp "zts" $ zipWith (normalizeField c') [1..] (reverse yts) usedTvs = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts')) cs = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ] - (xs, ts) = unzip xts + (xs, ts) = F.notracepp "ofBDataCtorxts" $ unzip xts t0 = case RT.famInstTyConType tc of Nothing -> F.notracepp "dataConResult-3: " $ RT.gApp tc αs πs Just ty -> RT.ofType ty @@ -735,7 +837,10 @@ makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne where makeOne (Loc l l' dcp) - | (null fls && Mb.isNothing maybe_cls) -- no field labels + | Just cls <- maybe_cls + = let cfs = Ghc.classAllSelIds cls in + [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)] + | null fls -- no field labels || any (isFunTy . snd) args && not (higherOrderFlag env) -- OR function-valued fields || dcpIsGadt dcp -- OR GADT style datcon = [] @@ -745,8 +850,7 @@ makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc) dc = dcpCon dcp fls = Ghc.dataConFieldLabels dc - fs = Bare.lookupGhcNamedVar env name <$> - Mb.maybe (fmap Ghc.flSelector fls) (fmap Ghc.getName . Ghc.classAllSelIds) maybe_cls + fs = Bare.lookupGhcNamedVar env name <$> fmap Ghc.flSelector fls ts :: [ LocSpecType ] ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) [] [] [(z, res, mempty)] @@ -759,7 +863,7 @@ makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne su = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ] args = dcpTyArgs dcp - z = F.notracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel" + z = F.tracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel" res = dropPreds (dcpTyRes dcp) -- FIXME: this is clearly imprecise, but the preds in the DataConP seem diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index ea5394ab7d..fd7a0456b3 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -26,6 +26,7 @@ import Data.Functor.Foldable import Data.Char ( isUpper ) import GHC import OccName +import Var (varType) import FastString import CoreSyn import PrelNames @@ -225,15 +226,20 @@ canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs) renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl where tbl = F.notracepp "TBL" $ M.fromList (zip ds canonicalDs) - elaborateSpecType + :: (CoreExpr -> F.Expr) + -> SpecType + -> Ghc (SpecType, [F.Symbol]) +elaborateSpecType = elaborateSpecType' $ pure () + +elaborateSpecType' :: PartialSpecType -> (CoreExpr -> F.Expr) -> SpecType -> Ghc (SpecType, [F.Symbol]) -- binders for dictionaries -- should have returned Maybe [F.Symbol] -elaborateSpecType partialTp coreToLogic t = - case F.notracepp "elaborateSpecType" t of +elaborateSpecType' partialTp coreToLogic t = + case F.notracepp "elaborateSpecType'" t of RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do elaborateReft (reft, t) @@ -246,8 +252,8 @@ elaborateSpecType partialTp coreToLogic t = let partialFunTp = Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType partialTp coreToLogic tin - (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + (eTin , bs ) <- elaborateSpecType' partialTp coreToLogic tin + (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic tout let buildRFunContTrivial | isClassType tin, dictBinder : bs0' <- bs' = do let (eToutRenamed, canonicalBinders) = @@ -300,8 +306,8 @@ elaborateSpecType partialTp coreToLogic t = let partialFunTp = Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType partialTp' coreToLogic tin - (eTout, bs') <- elaborateSpecType partialTp' coreToLogic tout + (eTin , bs ) <- elaborateSpecType' partialTp' coreToLogic tin + (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic tout let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTout, bs') @@ -321,7 +327,7 @@ elaborateSpecType partialTp coreToLogic t = ) -- support for RankNTypes/ref RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do - (eTout, bs) <- elaborateSpecType + (eTout, bs) <- elaborateSpecType' (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft)) coreToLogic tout @@ -339,7 +345,7 @@ elaborateSpecType partialTp coreToLogic t = -- pure (RAllT (RTVar tv ty) eTout ref, bts') -- todo: might as well print an error message? RAllP pvbind tout -> do - (eTout, bts') <- elaborateSpecType + (eTout, bts') <- elaborateSpecType' (partialTp >> Free (RAllPF pvbind (pure ()))) coreToLogic tout @@ -355,8 +361,8 @@ elaborateSpecType partialTp coreToLogic t = pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') ) RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do - (eArg, bs ) <- elaborateSpecType partialTp coreToLogic arg - (eRes, bs') <- elaborateSpecType partialTp coreToLogic res + (eArg, bs ) <- elaborateSpecType' partialTp coreToLogic arg + (eRes, bs') <- elaborateSpecType' partialTp coreToLogic res let (eResRenamed, canonicalBinders) = canonicalizeDictBinder bs (eRes, bs') elaborateReft @@ -372,13 +378,13 @@ elaborateSpecType partialTp coreToLogic t = ) -- todo: Existential support RAllE bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType' partialTp coreToLogic ty let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') pure (RAllE bind eAllarg eTyRenamed, canonicalBinders) REx bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType partialTp coreToLogic ty + (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic allarg + (eTy , bs') <- elaborateSpecType' partialTp coreToLogic ty let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') pure (REx bind eAllarg eTyRenamed, canonicalBinders) -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard @@ -437,7 +443,7 @@ elaborateSpecType partialTp coreToLogic t = "Oops, Ghc gave back more/less binders than I expected" ret <- nonTrivialCont dictbs - ( F.notracepp "nonTrivialContEE" + ( F.notracepp "nonTrivialContEE" . eliminateEta $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) ee ) -- (GM.dropModuleUnique <$> bs') pure (F.notracepp "result" ret) @@ -564,13 +570,15 @@ specTypeToLHsType :: SpecType -> LHsType GhcPs -- surprised that the type application is necessary specTypeToLHsType = flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case - RVarF (RTV tv) _ -> nlHsTyVar (getRdrName tv) + RVarF (RTV tv) _ -> nlHsTyVar (symbolToRdrNameNs tvName (F.symbol tv)) -- (getRdrName tv) RFunF _ (tin, tin') (_, tout) _ | isClassType tin -> noLoc $ HsQualTy NoExt (noLoc [tin']) tout | otherwise -> nlHsFunTy tin' tout RImpFF _ (_, tin) (_, tout) _ -> nlHsFunTy tin tout RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> - noLoc $ HsForAllTy NoExt (userHsTyVarBndrs noSrcSpan [getRdrName tv]) t + noLoc $ HsForAllTy NoExt (userHsTyVarBndrs noSrcSpan [-- getRdrName tv + (symbolToRdrNameNs tvName (F.symbol tv)) + ]) t RAllPF _ (_, ty) -> ty RAppF RTyCon { rtc_tc = tc } ts _ _ -> nlHsTyConApp (getRdrName tc) @@ -589,3 +597,25 @@ specTypeToLHsType = RHoleF _ -> noLoc $ HsWildCardTy NoExt RExprArgF _ -> todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg" + +-- the core expression returned by ghc might be eta-expanded +-- we need to do elimination so Pred doesn't contain lambda terms +eliminateEta :: F.Expr -> F.Expr +eliminateEta (F.EApp e0 e1) = F.EApp (eliminateEta e0) (eliminateEta e1) +eliminateEta (F.ENeg e) = F.ENeg (eliminateEta e) +eliminateEta (F.EBin bop e0 e1) = F.EBin bop (eliminateEta e0) (eliminateEta e1) +eliminateEta (F.EIte e0 e1 e2) = F.EIte (eliminateEta e0) (eliminateEta e1) (eliminateEta e2) +eliminateEta (F.ECst e0 s) = F.ECst (eliminateEta e0) s +eliminateEta (F.ELam (x, t) body) + | F.EApp e0 (F.EVar x') <- ebody + , x == x' && notElem x (F.syms e0) + = e0 + | otherwise + = F.ELam (x, t) ebody + where ebody = eliminateEta body +eliminateEta (F.PAnd es) = F.PAnd (eliminateEta <$> es) +eliminateEta (F.POr es) = F.POr (eliminateEta <$> es) +eliminateEta (F.PNot e) = F.PNot (eliminateEta e) +eliminateEta (F.PImp e0 e1) = F.PImp (eliminateEta e0) (eliminateEta e1) +eliminateEta (F.PAtom brel e0 e1) = F.PAtom brel (eliminateEta e0) (eliminateEta e1) +eliminateEta e = e diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index f648d0147b..2b7e2ec33b 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -678,7 +678,7 @@ cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ) = addHole x t γ cconsE' γ e t - = do te <- consE γ e + = do te <- consE γ (GM.tracePpr "cconsE'" e) te' <- instantiatePreds γ e te >>= addPost γ addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e) @@ -765,7 +765,7 @@ instantiatePreds :: CGEnv -> SpecType -> CG SpecType instantiatePreds γ e (RAllP π t) - = do r <- freshPredRef γ e π + = do r <- F.tracepp "instantiatePreds" <$> freshPredRef γ e π instantiatePreds γ e $ replacePreds "consE" t [(π, r)] instantiatePreds _ _ t0 @@ -805,7 +805,7 @@ consE γ e -- [NOTE: PLE-OPT] We *disable* refined instantiation for -- reflected functions inside proofs. consE γ (Var x) - = do t <- varRefType γ x + = do t <- F.tracepp "varRefType" <$> varRefType γ (GM.tracePpr "consEVar" x) addLocA (Just x) (getLocation γ) (varAnn γ x t) return t diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 57e3050979..5efeb6bc09 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -66,7 +66,7 @@ import TcRnDriver import RdrName -import Type (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind, tyConAppTyCon_maybe) +import Type (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind, tyConAppTyCon_maybe, splitForAllTys, coreView) import TyCoRep import Var import IdInfo @@ -802,12 +802,19 @@ findVarDefMethod x cbs = (Rec [(v, def)] : _ ) -> Just (v, def) _ -> Nothing where - rcbs = if isMethod x then mCbs else xCbs - xCbs = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb ] + rcbs | isMethod x = mCbs + | isDictionary x = dCbs + | otherwise = xCbs + xCbs = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb + ] mCbs = [ cb | cb <- concatMap unRec cbs, x `elem` methodSymbols cb] + dCbs = [ cb | cb <- concatMap unRec cbs, x `elem` dictionarySymbols cb] unRec (Rec xes) = [NonRec x es | (x,es) <- xes] unRec nonRec = [nonRec] +dictionarySymbols :: CoreBind -> [Symbol] +dictionarySymbols = filter isDictionary . map (dropModuleNames . symbol) . binders + methodSymbols :: CoreBind -> [Symbol] methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders @@ -972,3 +979,15 @@ elabRnExpr hsc_env mode rdr_expr = TM_Inst -> (True, NoRestrictions, id) TM_NoInst -> (False, NoRestrictions, id) TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +splitThetaTy :: Type -> ([TyVar], [Type], Type) +splitThetaTy ty = (tvs, clss, res') + where (tvs, res) = splitForAllTys ty + (clss, res') = splitFunClsTys res + +splitFunClsTys :: Type -> ([Type], Type) +splitFunClsTys ty = split [] ty ty + where + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args _ (FunTy arg res) | isPredType arg = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs index 1dbe95df88..cedf5dace9 100644 --- a/src/Language/Haskell/Liquid/Measure.hs +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -300,14 +300,14 @@ stitchArgs sp dc allXs allTs ++ zipWith g xs (ofType <$> ts) | otherwise = panicFieldNumMismatch sp dc nXs nTs where - (pts, ts) = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ isPredTy t) allTs + (pts, ts) = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ isEmbeddedDictType t) allTs (_ , xs) = L.partition (coArg . snd) allXs nXs = length xs nTs = length ts g (x, Just t) _ = (x, t, mempty) g (x, _) t = (x, t, mempty) coArg Nothing = False - coArg (Just t) = isPredTy . toType $ t + coArg (Just t) = isEmbeddedDictType . toType $ t panicFieldNumMismatch :: (PPrint a, PPrint a1, PPrint a3) => SrcSpan -> a3 -> a1 -> a -> a2 diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs index 01f212d2db..c5da887cd9 100644 --- a/src/Language/Haskell/Liquid/Types/PredType.hs +++ b/src/Language/Haskell/Liquid/Types/PredType.hs @@ -40,6 +40,7 @@ import Var import Language.Haskell.Liquid.GHC.TypeRep import Data.Hashable import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import qualified Data.Maybe as Mb import qualified Data.List as L -- (foldl', partition) -- import Data.List (nub) @@ -170,15 +171,24 @@ strengthenRType wkT wrT = maybe wkT (strengthen wkT) (stripRTypeBase wrT) dcWrapSpecType :: DataCon -> DataConP -> SpecType dcWrapSpecType dc (DataConP _ _ vs ps cs yts rt _ _ _) - = {- F.notracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -} + = F.notracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ mkArrow makeVars' ps [] ts' rt' where + isCls = Ghc.isClassTyCon $ Ghc.dataConTyCon dc (xs, ts) = unzip (reverse yts) mkDSym z = (F.symbol z) `F.suffixSymbol` (F.symbol dc) ys = mkDSym <$> xs tx _ [] [] [] = [] - tx su (x:xs) (y:ys) (t:ts) = (y, F.subst (F.mkSubst su) t, mempty) - : tx ((x, F.EVar y):su) xs ys ts + -- NOTE THAT xs and xs' have the same type!!! + -- I renamed them to avoid shadowing but if you modify this + -- code keep that in mind + tx su (x:xs') (y:ys) (t:ts) = ( y + -- special case for class + , if isCls + then t + else F.subst (F.mkSubst su) t + , mempty) + : tx ((x, F.EVar y):su) xs' ys ts tx _ _ _ _ = panic Nothing "PredType.dataConPSpecType.tx called on invalid inputs" yts' = tx [] xs ys ts ts' = map ("" , , mempty) cs ++ yts' @@ -187,6 +197,12 @@ dcWrapSpecType dc (DataConP _ _ vs ps cs yts rt _ _ _) makeVars = zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTys $ dataConRepType dc) makeVars' = zip makeVars (repeat mempty) + -- typeclass yts contains predicates (Semigroup => , Functor => ...) + -- stripPred :: SpecType -> SpecType + -- stripPred t = mkUnivs tvs pvs tres + -- where (tvs, pvs, _, tres) = bkUnivClass t + + instance PPrint TyConP where pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc) <+> ppComm k (tcpFreeTyVarsTy tc) diff --git a/tests/refined-classes/SemigroupOp.hs b/tests/refined-classes/SemigroupOp.hs index 4915bafedf..bc6a6d503f 100644 --- a/tests/refined-classes/SemigroupOp.hs +++ b/tests/refined-classes/SemigroupOp.hs @@ -1,9 +1,57 @@ +{-# LANGUAGE RankNTypes #-} {-@ LIQUID "--reflection" @-} {-@ LIQUID "--extensionality" @-} {-@ LIQUID "--ple" @-} module SemigroupOp where + +{-@ reflect myid @-} +myid :: a -> a +myid x = x + +class MyFunctor f where + {-@ myfmap :: forall a b.(a -> b) -> f a -> f b @-} + myfmap :: (a -> b) -> f a -> f b + {-@ myfmapProp :: forall a. x:f a -> {myfmap myid x == myid x}@-} + myfmapProp :: f a -> () + +{-@ data MyId a = MyId a @-} +data MyId a = MyId a + +{-@ reflect cmyfmap @-} +cmyfmap :: (a -> b) -> MyId a -> MyId b +cmyfmap f (MyId a) = MyId (f a) + +{-@ myfmap2 :: MyFunctor g => f:(a -> b) -> x:g a -> {vv: g b | fmap f x = fmap g } @-} +myfmap2 :: MyFunctor g => (a -> b) -> g a -> g b +myfmap2 = myfmap + + +-- $fMyFunctor :: MyFunctor MyId +instance MyFunctor MyId where + myfmap f (MyId a) = MyId (f a) + myfmapProp (MyId a) = () + +{-@ reflect myConst @-} +myConst :: a -> b -> a +myConst x _ = x + + +k :: a -> b -> b +k _ y = y + +-- yes this would fail +{-@ replaceProp :: MyFunctor f => x:a -> y:f b -> z:f c -> {myfmap (myConst x) y == myfmap (myConst x) z} @-} +replaceProp :: MyFunctor f => a -> f b -> f c -> () +replaceProp x _ _ = () + + +-- {-@ msame :: f:(a -> b) -> x:MyId a -> {myfmap f x == cmyfmap f x} @-} +-- msame :: (a -> b) -> MyId a -> () +-- msame x y = cmyfmap x y `k` myfmap x y `k` () + class YYSemigroup a where + univ :: b -> a -> () ymappend :: a -> a -> a {-@ lawAssociative :: v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} lawAssociative :: a -> a -> a -> () @@ -23,5 +71,6 @@ mylawAssociative :: YYSemigroup a => a -> a -> a -> () mylawAssociative x y z = lawAssociative x y z instance (YYSemigroup a) => YYSemigroup (Op a) where + univ _ _ = () ymappend = mappendOp lawAssociative x y z = lawAssociativeOp x y z diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs new file mode 100644 index 0000000000..a4811375ba --- /dev/null +++ b/tests/refined-classes/Subclass.hs @@ -0,0 +1,27 @@ +{-@ LIQUID "--reflection" @-} +module Subclass where + + +class MyFunctor f where + {-@ myfmap :: forall a b. (a -> b) -> f a -> f b @-} + myfmap :: (a -> b) -> f a -> f b + +{-@ reflect myid @-} +myid :: a -> a +myid x = x + +class MyFunctor f => MyApplicative f where + {-@ mypure :: forall a. a -> f a @-} + mypure :: a -> f a + {-@ myap :: forall a b. f (a -> b) -> f a -> f b @-} + myap :: f (a -> b) -> f a -> f b + {-@ myprop :: forall a b. x:f a -> f:(a -> b) -> {myfmap f x == myap (mypure f) x} @-} + myprop :: f a -> (a -> b) -> () + + +{-@ data MyId a = MyId a @-} +data MyId a = MyId a + +instance MyFunctor MyId where + myfmap f (MyId i) = MyId (f i) + From 8a3fd40d197b907956c093ba4813cc0f6215d3b5 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 16 Feb 2020 16:21:39 -0500 Subject: [PATCH 09/38] fix stripPred --- src/Language/Haskell/Liquid/Bare/DataType.hs | 2 +- tests/refined-classes/Subclass.hs | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index ccc5ac9cbe..048d9e784b 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -494,7 +494,7 @@ elaborateClassDcp coreToLg dcp = do -- turns forall a b. (a -> b) -> f a -> f b into -- forall f. Functor f => forall a b. (a -> b) -> f a -> f b stripPred :: SpecType -> SpecType - stripPred t = mkUnivs tvs pvs tres + stripPred t = tres where (tvs, pvs, _, tres) = bkUnivClass t fullTy :: SpecType -> SpecType fullTy t = diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs index a4811375ba..f36bf1728d 100644 --- a/tests/refined-classes/Subclass.hs +++ b/tests/refined-classes/Subclass.hs @@ -1,4 +1,5 @@ {-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple" @-} module Subclass where @@ -25,3 +26,7 @@ data MyId a = MyId a instance MyFunctor MyId where myfmap f (MyId i) = MyId (f i) +instance MyApplicative MyId where + mypure = MyId + myap (MyId f) (MyId a) = MyId (f a) + myprop _ _ = () From 5eaf518eedfd7ffacbfd1add61e378a63e5efcb1 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 16 Feb 2020 17:01:31 -0500 Subject: [PATCH 10/38] add dictionary reflection; add ($>) to prevent Functor from becoming a newtype --- src/Language/Haskell/Liquid/Bare.hs | 18 ++++++++++++------ src/Language/Haskell/Liquid/GHC/Misc.hs | 2 +- tests/refined-classes/Subclass.hs | 4 +++- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index a4a239e9c3..ab69784725 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -221,8 +221,7 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do compileClasses :: GhcSrc -> Bare.Env -> (ModName, Ms.BareSpec) -> [(ModName, Ms.BareSpec)] -> Ms.BareSpec compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec - where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList (-- F.dummyLoc (F.symbol ("$fMyFunctorMyId" :: String)): - methods)-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs + where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList (fmap (fmap GM.dropModuleNames.GM.namedLocSymbol.fst) instClss ++ methods)-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs } clsDecls = Bare.makeClassDataDecl' (M.toList refinedMethods) @@ -250,10 +249,10 @@ compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec (d, e) <- concatMap unRec (giCbs src) , F.notracepp (F.showpp (F.symbol d)) (Ghc.isDFunId d) , cls <- Mb.maybeToList $ L.lookup d instClss - , cls `elem` refinedClasses + -- , cls `elem` refinedClasses , x <- freeVars mempty e -- YL: Hack - , not (isPrefixOfSym "$claw" (GM.simplesymbol x)) + -- , not (isPrefixOfSym "$claw" (GM.simplesymbol x)) , GM.isMethod x ] @@ -294,8 +293,15 @@ compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec insts = mconcat . Mb.maybeToList . gsCls $ src instClss :: [(Ghc.DFunId, Ghc.Class)] - instClss = fmap (\inst -> (GM.notracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ Ghc.is_dfun inst, Ghc.is_cls inst)) $ - insts + instClss = + filter ((`elem` refinedClasses) . snd) $ + fmap + (\inst -> + ( GM.notracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ + Ghc.is_dfun inst + , Ghc.is_cls inst)) $ + insts + refinedClasses :: [Ghc.Class] refinedClasses = Mb.mapMaybe resolveClassMaybe clsDecls ++ diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 5efeb6bc09..fd7e009854 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -803,7 +803,7 @@ findVarDefMethod x cbs = _ -> Nothing where rcbs | isMethod x = mCbs - | isDictionary x = dCbs + | isDictionary (dropModuleNames x) = dCbs | otherwise = xCbs xCbs = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb ] diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs index f36bf1728d..06be0f23fd 100644 --- a/tests/refined-classes/Subclass.hs +++ b/tests/refined-classes/Subclass.hs @@ -2,10 +2,11 @@ {-@ LIQUID "--ple" @-} module Subclass where - class MyFunctor f where {-@ myfmap :: forall a b. (a -> b) -> f a -> f b @-} myfmap :: (a -> b) -> f a -> f b + {-@ (<$) :: forall a b. a -> f b -> f a @-} + (<$) :: a -> f b -> f a {-@ reflect myid @-} myid :: a -> a @@ -25,6 +26,7 @@ data MyId a = MyId a instance MyFunctor MyId where myfmap f (MyId i) = MyId (f i) + x <$ (MyId _) = MyId x instance MyApplicative MyId where mypure = MyId From b1c55372db38550164aaf19251aba72244d47810 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 16 Feb 2020 17:12:54 -0500 Subject: [PATCH 11/38] add Maybe to Subclass.hs --- tests/refined-classes/Subclass.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs index 06be0f23fd..a0222f8c86 100644 --- a/tests/refined-classes/Subclass.hs +++ b/tests/refined-classes/Subclass.hs @@ -32,3 +32,18 @@ instance MyApplicative MyId where mypure = MyId myap (MyId f) (MyId a) = MyId (f a) myprop _ _ = () + +data Optional a = None | Has a + +instance MyFunctor Optional where + myfmap _ None = None + myfmap f (Has x) = Has (f x) + _ <$ None = None + x <$ (Has _) = Has x + +instance MyApplicative Optional where + mypure = Has + myap None _ = None + myap _ None = None + myap (Has f) (Has x) = Has (f x) + myprop _ _ = () From d793061277c25ce319942dd557b4537f18ba2f11 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 16 Feb 2020 22:12:53 -0500 Subject: [PATCH 12/38] add PIff embedding. add accidentally deleted save bspec --- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 3 +++ src/Language/Haskell/Liquid/GHC/Interface.hs | 4 ++++ src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs | 2 ++ tests/refined-classes/Subclass.hs | 5 +++++ 4 files changed, 14 insertions(+) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index fd7a0456b3..c82e187f3b 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -495,6 +495,9 @@ fixExprToHsExpr env (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr env e) es fixExprToHsExpr env (F.POr es) = mkHsApp (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "or"))) (nlList $ fixExprToHsExpr env <$> es) +fixExprToHsExpr env (F.PIff e0 e1) = + mkHsApp (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0)) + (fixExprToHsExpr env e1) fixExprToHsExpr env (F.PNot e) = mkHsApp (nlHsVar not_RDR) (fixExprToHsExpr env e) fixExprToHsExpr env (F.PAtom brel e0 e1) = mkHsApp diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index ee1cb69443..6e918795df 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -446,6 +446,9 @@ processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = d void $ execStmt "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}" execOptions + void $ execStmt + "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}" + execOptions void $ execStmt "let {infix 4 ==; _ == _ = undefined}" execOptions @@ -456,6 +459,7 @@ processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = d "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}" execOptions ghcSpec <- makeGhcSpec cfg ghcSrc logicMap bareSpecs + _ <- liftIO $ saveLiftedSpec ghcSrc ghcSpec return $ GI ghcSrc ghcSpec --------------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs index 3e65778796..36ad09900e 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -384,6 +384,8 @@ toPredApp p = go . Misc.mapFst opSym . splitArgs $ p = PAnd <$> mapM coreToLg [e1, e2] | f == symbol ("==>" :: String) = PImp <$> coreToLg e1 <*> coreToLg e2 + | f == symbol ("<=>" :: String) + = PIff <$> coreToLg e1 <*> coreToLg e2 go (Just f, [es]) | f == symbol ("or" :: String) = POr . deList <$> coreToLg es diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs index a0222f8c86..e90ae04dc7 100644 --- a/tests/refined-classes/Subclass.hs +++ b/tests/refined-classes/Subclass.hs @@ -47,3 +47,8 @@ instance MyApplicative Optional where myap _ None = None myap (Has f) (Has x) = Has (f x) myprop _ _ = () + + +{-@ impl :: x:Bool -> y:Bool -> {v:Bool | v <=> (x => y)} @-} +impl :: Bool -> Bool -> Bool +impl a b = if a then b else True From 08f4b8e814b3e67e27518435a071df22e8d43a94 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 17 Feb 2020 17:54:35 -0500 Subject: [PATCH 13/38] save progress because it would expensive to lose.. --- src/Language/Haskell/Liquid/Bare.hs | 248 ++++++++++-------- src/Language/Haskell/Liquid/Bare/Class.hs | 3 +- src/Language/Haskell/Liquid/Bare/DataType.hs | 2 +- src/Language/Haskell/Liquid/GHC/API.hs | 3 +- src/Language/Haskell/Liquid/Types/PredType.hs | 6 - tests/refined-classes/SemigroupOp.hs | 47 ---- tests/refined-classes/Subclass.hs | 10 +- 7 files changed, 152 insertions(+), 167 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index ab69784725..d8633fc6a2 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE OverloadedStrings #-} -- | This module contains the functions that convert /from/ descriptions of @@ -141,18 +141,16 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do let lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 mySpec = mySpec2 <> lSpec1 specs = M.insert name mySpec iSpecs2 - measEnv <- makeMeasEnv coreToLg env tycEnv sigEnv specs + measEnv <- makeMeasEnv env tycEnv sigEnv specs let myRTE = myRTEnv src env sigEnv rtEnv qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs sData = makeSpecData src env sigEnv measEnv sig specs refl = makeSpecRefl cfg src measEnv specs env name sig tycEnv laws = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs sig = makeSpecSig cfg name specs env sigEnv tycEnv measEnv (giCbs src) - -- liftIO $ putStrLn "Before" - -- liftIO $ putStrLn$ F.showpp (gsTySigs sig) - -- liftIO $ putStrLn "After" - elaboratedSig <- elaborateSig sig - -- liftIO $ putStrLn$ F.showpp (gsTySigs elaboratedSig) + auxSig <- makeClassAuxTypes (fmap fst.elaborateSpecType coreToLg) datacons instMethods + elaboratedSig <- elaborateSig sig auxSig + pure $ SP { gsConfig = cfg , gsImps = makeImports mspecs @@ -163,7 +161,8 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do , gsQual = qual , gsName = makeSpecName env tycEnv measEnv name , gsVars = makeSpecVars cfg src mySpec env measEnv - , gsTerm = makeSpecTerm cfg mySpec env name + , gsTerm = makeSpecTerm cfg mySpec env name + -- YL: shoudl I add the sigs here? , gsLSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1 { impSigs = makeImports mspecs, expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ], @@ -182,7 +181,7 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do Left _ -> impossible Nothing "can't reach here" Right e -> e - elaborateSig si = do + elaborateSig si auxsig = do tySigs <- forM (gsTySigs si) $ \(x, t) -> do t' <- traverse (elaborateSpecType coreToLg) t @@ -193,7 +192,7 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do -- pure (x, fst <$> t') pure si - { gsTySigs = tySigs -- , gsAsmSigs = asmSigs + { gsTySigs = F.tracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig -- , gsAsmSigs = asmSigs } dm = Bare.tcDataConMap tycEnv0 @@ -210,109 +209,142 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do -- extract name and specs env = Bare.makeEnv cfg src lmap mspecsNoClass mspecs = M.toList $ M.insert name mySpec0 iSpecs0 - mySpec0 = compileClasses src env (name, mySpec0NoClass) (M.toList iSpecs0) + (mySpec0, instMethods) = compileClasses src env (name, mySpec0NoClass) (M.toList iSpecs0) (mySpec0NoClass, iSpecs0) = splitSpecs name mspecsNoClass -- check barespecs name = F.notracepp ("ALL-SPECS" ++ zzz) $ giTargetMod src zzz = F.showpp (fst <$> mspecsNoClass) +makeClassAuxTypes :: + (SpecType -> Ghc.Ghc SpecType) + -> [F.Located DataConP] + -> [(Ghc.ClsInst, [Ghc.Var])] + -> Ghc.Ghc [(Ghc.Var, LocSpecType)] +makeClassAuxTypes elab dcps xs = Misc.concatMapM (makeClassAuxTypesOne elab) dcpInstMethods + where + dcpInstMethods = do + dcp <- dcps + (inst, methods) <- xs + let dc = dcpCon . F.val $ dcp + -- YL: only works for non-newtype class + dc' = Ghc.classDataCon $ Ghc.is_cls inst + guard $ dc == dc' + pure (dcp, inst, methods) - -compileClasses :: GhcSrc -> Bare.Env -> (ModName, Ms.BareSpec) - -> [(ModName, Ms.BareSpec)] -> Ms.BareSpec -compileClasses src env (name, spec) rest = spec {sigs = sigs'} <> clsSpec - where clsSpec = mempty {dataDecls = clsDecls, reflects = S.fromList (fmap (fmap GM.dropModuleNames.GM.namedLocSymbol.fst) instClss ++ methods)-- , sigs = F.tracepp "refinedMethodSigs" refinedMethodSigs - } - clsDecls = Bare.makeClassDataDecl' (M.toList refinedMethods) - + +makeClassAuxTypesOne :: + (SpecType -> Ghc.Ghc SpecType) + -> (F.Located DataConP, Ghc.ClsInst, [Ghc.Var]) + -> Ghc.Ghc [(Ghc.Var, LocSpecType)] +makeClassAuxTypesOne elab (ldcp, inst, methods) = + forM methods $ \method -> do + let headlessSig = + case L.lookup (mkSymbol method) yts of + Nothing -> + impossible Nothing "makeClassAuxTypesOne : not reachable?" + Just sig -> sig + fullSig = + mkArrow + (zip isRTvs (repeat mempty)) + [] + [] + [(F.dummySymbol, pty, mempty) | pty <- isPredSpecTys] . + subst (zip clsTvs isSpecTys) $ + headlessSig + elaboratedSig <- elab fullSig + let retSig = _substAuxMethod elaboratedSig + pure (method, F.dummyLoc retSig) + + -- is used as a shorthand for instance, following the convention of the Ghc api + where + (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst + isSpecTys = ofType <$> isTys + isPredSpecTys = ofType <$> isPredTys + isRTvs = makeRTVar . rTyVar <$> isTvs + dcp = F.val ldcp + yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] + mkSymbol x = F.dropSym 2 $ GM.simplesymbol x + -- res = dcpTyRes dcp + clsTvs = F.tracepp "clsTvs" $ dcpFreeTyVars dcp + -- copy/pasted from Bare/Class.hs + subst [] t = t + subst ((a, ta):su) t = subsTyVar_meet' (a, ta) (subst su t) + + + +compileClasses :: + GhcSrc + -> Bare.Env + -> (ModName, Ms.BareSpec) + -> [(ModName, Ms.BareSpec)] + -> (Ms.BareSpec, [(Ghc.ClsInst, [Ghc.Var])]) +compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, instmethods) + where + clsSpec = + mempty + { dataDecls = clsDecls + , reflects = + F.tracepp "reflects " $ + S.fromList + (fmap + (fmap GM.dropModuleNames . + GM.namedLocSymbol . Ghc.instanceDFunId . fst) + instClss ++ + methods) + } + clsDecls = Bare.makeClassDataDecl' (M.toList refinedMethods) -- class methods - (refinedMethods, sigs') = foldr grabClassSig (mempty, mempty) (sigs spec) - - grabClassSig :: (F.LocSymbol, ty) -> - (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) -> - (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) - grabClassSig sig@(lsym, ref) (refs, sigs') = - case clsOp of - Nothing -> (refs, sig:sigs') - Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs') - where clsOp = do - var <- Bare.maybeResolveSym env name "grabClassSig" lsym - cls <- Ghc.isClassOpId_maybe var - pure (cls, (var, ref)) - - merge sig v = case v of - Nothing -> Just [sig] - Just vs -> Just (sig:vs) - + (refinedMethods, sigs') = foldr grabClassSig (mempty, mempty) (sigs spec) + grabClassSig :: + (F.LocSymbol, ty) + -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) + -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)]) + grabClassSig sig@(lsym, ref) (refs, sigs') = + case clsOp of + Nothing -> (refs, sig : sigs') + Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs') + where + clsOp = do + var <- Bare.maybeResolveSym env name "grabClassSig" lsym + cls <- Ghc.isClassOpId_maybe var + pure (cls, (var, ref)) + merge sig v = + case v of + Nothing -> Just [sig] + Just vs -> Just (sig : vs) + methods = [GM.namedLocSymbol x | (_, xs) <- instmethods, x <- xs] -- instance methods - methods = F.notracepp "methods" [ F.symbol <$> GM.locNamedThing x | - (d, e) <- concatMap unRec (giCbs src) - , F.notracepp (F.showpp (F.symbol d)) (Ghc.isDFunId d) - , cls <- Mb.maybeToList $ L.lookup d instClss - -- , cls `elem` refinedClasses - , x <- freeVars mempty e - -- YL: Hack - -- , not (isPrefixOfSym "$claw" (GM.simplesymbol x)) - , GM.isMethod x - ] - - -- refinedMethodSigs :: [(F.LocSymbol, F.Located BareType)] - -- refinedMethodSigs = concatMap refineInstance insts - - -- refineInstance :: Ghc.ClsInst -> [(F.LocSymbol, F.Located BareType)] - -- refineInstance inst - -- | L.null is_tvs - -- = [(Mb.fromJust $ M.lookup (GM.dropModuleNamesAndUnique $ F.symbol methodId) clsMethodInst, plugType <$> ty) | (methodId, ty) <- methods] - -- | otherwise - -- = todo Nothing "instances with parameters are not supported" - -- where is_tvs = Ghc.is_tvs inst -- forall tvs. - -- is_tys = Ghc.is_tys inst -- Int - -- is_cls = Ghc.is_cls inst - - -- -- hack. doesn't work when we have module name at the front - -- plugType :: BareType -> BareType - -- plugType = F.substa (\s -> Mb.fromMaybe s (F.val <$> M.lookup s clsMethodInst)) . subts (zip (GM.dropModuleNamesAndUnique . F.symbol <$> Ghc.classTyVars is_cls) (bareOfType <$> is_tys :: [BareType])) - - -- methods - -- | Just ms <- M.lookup is_cls refinedMethods - -- = ms - -- | otherwise - -- = impossible Nothing "invariant violated" - -- instMethods = F.tracepp "instMethods" [ F.symbol <$> GM.locNamedThing x | - -- (d, e) <- concatMap unRec (giCbs src) - -- , d == Ghc.is_dfun inst - -- , x <- freeVars mempty e - -- , GM.isMethod x - -- ] - -- -- mappend -> $cmappend#a1ox - -- clsMethodInst :: M.HashMap F.Symbol F.LocSymbol - -- clsMethodInst = M.fromList - -- [((F.dropSym 2 . GM.dropModuleNamesAndUnique . F.val) m, m) | m <- instMethods] - - insts :: [Ghc.ClsInst] - insts = mconcat . Mb.maybeToList . gsCls $ src - - instClss :: [(Ghc.DFunId, Ghc.Class)] - instClss = - filter ((`elem` refinedClasses) . snd) $ - fmap - (\inst -> - ( GM.notracePpr ("inst variables" ++ (GM.showPpr $ Ghc.is_tvs inst)) $ - Ghc.is_dfun inst - , Ghc.is_cls inst)) $ - insts - - - refinedClasses :: [Ghc.Class] - refinedClasses = Mb.mapMaybe resolveClassMaybe clsDecls ++ - concatMap (Mb.mapMaybe resolveClassMaybe.dataDecls.snd) rest - - resolveClassMaybe :: DataDecl -> Maybe Ghc.Class - resolveClassMaybe d = Bare.maybeResolveSym env name "resolveClassMaybe" - (dataNameSymbol.tycName $ d) >>= - Ghc.tyConClass_maybe - unRec (Ghc.Rec xes) = xes - unRec (Ghc.NonRec x e) = [(x,e)] + instmethods :: [(Ghc.ClsInst, [Ghc.Var])] + instmethods = + [ (inst, ms) + | (inst, _) <- instClss + , (_, e) <- + Mb.maybeToList + (GM.findVarDefMethod + (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst) + (giCbs src)) + , let ms = filter GM.isMethod (freeVars mempty e) + ] + instClss :: [(Ghc.ClsInst, Ghc.Class)] + instClss = + [ (inst, cls) + | inst <- mconcat . Mb.maybeToList . gsCls $ src + , Ghc.moduleName (Ghc.nameModule (Ghc.getName inst)) == getModName name + , let cls = Ghc.is_cls inst + , cls `elem` refinedClasses + ] + refinedClasses :: [Ghc.Class] + refinedClasses = + Mb.mapMaybe resolveClassMaybe clsDecls ++ + concatMap (Mb.mapMaybe resolveClassMaybe . dataDecls . snd) rest + resolveClassMaybe :: DataDecl -> Maybe Ghc.Class + resolveClassMaybe d = + Bare.maybeResolveSym + env + name + "resolveClassMaybe" + (dataNameSymbol . tycName $ d) >>= + Ghc.tyConClass_maybe splitSpecs :: ModName -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs) @@ -324,7 +356,7 @@ splitSpecs name specs = (mySpec, iSpecm) makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)] -makeImports specs = concatMap (expSigs . snd) specs' +makeImports specs = F.tracepp "imported" $ concatMap (expSigs . snd) specs' where specs' = filter (isSrcImport . fst) specs @@ -1021,9 +1053,9 @@ knownWiredTyCons env name = filter isKnown wiredTyCons -- REBARE: formerly, makeGhcCHOP2 ------------------------------------------------------------------------------------------- -makeMeasEnv :: (Ghc.CoreExpr -> F.Expr) -> Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Ghc.Ghc Bare.MeasEnv +makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Ghc.Ghc Bare.MeasEnv ------------------------------------------------------------------------------------------- -makeMeasEnv coreToLg env tycEnv sigEnv specs = do +makeMeasEnv env tycEnv sigEnv specs = do -- datacons' <- forM datacons $ \dc -> -- if Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon $ dc -- then Bare.elaborateClassDcp coreToLg dc diff --git a/src/Language/Haskell/Liquid/Bare/Class.hs b/src/Language/Haskell/Liquid/Bare/Class.hs index 4138037373..c19f064dc2 100644 --- a/src/Language/Haskell/Liquid/Bare/Class.hs +++ b/src/Language/Haskell/Liquid/Bare/Class.hs @@ -114,7 +114,6 @@ addCC x zz@(Loc l l' st0) addForall _ t = t - splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var]) splitDictionary = go [] [] where @@ -273,4 +272,4 @@ lookupDefaultVar env name v = Mb.maybeToList where dmSym = F.atLoc v (GM.qualifySymbol mSym dnSym) dnSym = F.mappendSym "$dm" nSym - (mSym, nSym) = GM.splitModuleName (F.symbol v) \ No newline at end of file + (mSym, nSym) = GM.splitModuleName (F.symbol v) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 048d9e784b..8d3a3753ae 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -429,7 +429,7 @@ classDeclToDataDecl' cls refinedIds = F.tracepp "classDeclToDataDecl" $ DataDecl tyVarSubst = [(GM.dropModuleUnique v, v) | v <- tyVars] dropTheta :: Ghc.Type -> Ghc.Type - dropTheta = GM.notracePpr "Dropping pred" . Misc.thd3 . GM.splitThetaTy + dropTheta = GM.notracePpr "Dropping pred" . Misc.thd3 . Ghc.tcSplitMethodTy -- dropTheta (Ghc.ForAllTy _ (Ghc.FunTy _ τ')) = τ' -- dropTheta (Ghc.ForAllTy _ (Ghc.ForAllTy _ _)) = todo Nothing "multi-parameter type-class not supported" -- dropTheta _ = impossible Nothing "classDeclToDataDecl': assumption was wrong" diff --git a/src/Language/Haskell/Liquid/GHC/API.hs b/src/Language/Haskell/Liquid/GHC/API.hs index 1dc5068f4f..1fd99e9351 100644 --- a/src/Language/Haskell/Liquid/GHC/API.hs +++ b/src/Language/Haskell/Liquid/GHC/API.hs @@ -19,7 +19,8 @@ import Class as Ghc import Unique as Ghc import RdrName as Ghc import SrcLoc as Ghc -import Name as Ghc hiding (varName) +import Name as Ghc hiding (varName) +import TcType as Ghc (tcSplitMethodTy, tcSplitAppTys) -- import TyCon as Ghc diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs index c5da887cd9..4ae4ae68fb 100644 --- a/src/Language/Haskell/Liquid/Types/PredType.hs +++ b/src/Language/Haskell/Liquid/Types/PredType.hs @@ -197,12 +197,6 @@ dcWrapSpecType dc (DataConP _ _ vs ps cs yts rt _ _ _) makeVars = zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTys $ dataConRepType dc) makeVars' = zip makeVars (repeat mempty) - -- typeclass yts contains predicates (Semigroup => , Functor => ...) - -- stripPred :: SpecType -> SpecType - -- stripPred t = mkUnivs tvs pvs tres - -- where (tvs, pvs, _, tres) = bkUnivClass t - - instance PPrint TyConP where pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc) <+> ppComm k (tcpFreeTyVarsTy tc) diff --git a/tests/refined-classes/SemigroupOp.hs b/tests/refined-classes/SemigroupOp.hs index bc6a6d503f..2ae4b6e349 100644 --- a/tests/refined-classes/SemigroupOp.hs +++ b/tests/refined-classes/SemigroupOp.hs @@ -5,53 +5,7 @@ module SemigroupOp where -{-@ reflect myid @-} -myid :: a -> a -myid x = x - -class MyFunctor f where - {-@ myfmap :: forall a b.(a -> b) -> f a -> f b @-} - myfmap :: (a -> b) -> f a -> f b - {-@ myfmapProp :: forall a. x:f a -> {myfmap myid x == myid x}@-} - myfmapProp :: f a -> () - -{-@ data MyId a = MyId a @-} -data MyId a = MyId a - -{-@ reflect cmyfmap @-} -cmyfmap :: (a -> b) -> MyId a -> MyId b -cmyfmap f (MyId a) = MyId (f a) - -{-@ myfmap2 :: MyFunctor g => f:(a -> b) -> x:g a -> {vv: g b | fmap f x = fmap g } @-} -myfmap2 :: MyFunctor g => (a -> b) -> g a -> g b -myfmap2 = myfmap - - --- $fMyFunctor :: MyFunctor MyId -instance MyFunctor MyId where - myfmap f (MyId a) = MyId (f a) - myfmapProp (MyId a) = () - -{-@ reflect myConst @-} -myConst :: a -> b -> a -myConst x _ = x - - -k :: a -> b -> b -k _ y = y - --- yes this would fail -{-@ replaceProp :: MyFunctor f => x:a -> y:f b -> z:f c -> {myfmap (myConst x) y == myfmap (myConst x) z} @-} -replaceProp :: MyFunctor f => a -> f b -> f c -> () -replaceProp x _ _ = () - - --- {-@ msame :: f:(a -> b) -> x:MyId a -> {myfmap f x == cmyfmap f x} @-} --- msame :: (a -> b) -> MyId a -> () --- msame x y = cmyfmap x y `k` myfmap x y `k` () - class YYSemigroup a where - univ :: b -> a -> () ymappend :: a -> a -> a {-@ lawAssociative :: v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} lawAssociative :: a -> a -> a -> () @@ -71,6 +25,5 @@ mylawAssociative :: YYSemigroup a => a -> a -> a -> () mylawAssociative x y z = lawAssociative x y z instance (YYSemigroup a) => YYSemigroup (Op a) where - univ _ _ = () ymappend = mappendOp lawAssociative x y z = lawAssociativeOp x y z diff --git a/tests/refined-classes/Subclass.hs b/tests/refined-classes/Subclass.hs index e90ae04dc7..3947816af1 100644 --- a/tests/refined-classes/Subclass.hs +++ b/tests/refined-classes/Subclass.hs @@ -5,7 +5,6 @@ module Subclass where class MyFunctor f where {-@ myfmap :: forall a b. (a -> b) -> f a -> f b @-} myfmap :: (a -> b) -> f a -> f b - {-@ (<$) :: forall a b. a -> f b -> f a @-} (<$) :: a -> f b -> f a {-@ reflect myid @-} @@ -48,7 +47,14 @@ instance MyApplicative Optional where myap (Has f) (Has x) = Has (f x) myprop _ _ = () - {-@ impl :: x:Bool -> y:Bool -> {v:Bool | v <=> (x => y)} @-} impl :: Bool -> Bool -> Bool impl a b = if a then b else True + +{-@ reflect ffmap @-} +ffmap :: MyFunctor f => (a -> b) -> f a -> f b +ffmap = myfmap + +{-@ trivial :: MyFunctor f => f:(a -> b) -> x:f a -> {myfmap f x == ffmap f x} @-} +trivial :: MyFunctor f => (a -> b) -> f a -> () +trivial _ _ = () From 28667066692b6e3c3822f81b05b21b50b6a29499 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 17 Feb 2020 19:00:13 -0500 Subject: [PATCH 14/38] add refinement generation but does not work --- src/Language/Haskell/Liquid/Bare.hs | 35 ++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index d8633fc6a2..64c13f438e 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -192,7 +192,7 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do -- pure (x, fst <$> t') pure si - { gsTySigs = F.tracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig -- , gsAsmSigs = asmSigs + { gsTySigs = F.notracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig -- , gsAsmSigs = asmSigs } dm = Bare.tcDataConMap tycEnv0 @@ -252,16 +252,21 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = subst (zip clsTvs isSpecTys) $ headlessSig elaboratedSig <- elab fullSig - let retSig = _substAuxMethod elaboratedSig - pure (method, F.dummyLoc retSig) + let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) elaboratedSig + pure (method, F.dummyLoc (F.tracepp "retSig" retSig)) -- is used as a shorthand for instance, following the convention of the Ghc api where + -- (Monoid.mappend -> $cmappend##Int, ...) + methodsSet = M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) + dfunSym = F.symbol $ Ghc.instanceDFunId inst (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst isSpecTys = ofType <$> isTys isPredSpecTys = ofType <$> isPredTys isRTvs = makeRTVar . rTyVar <$> isTvs dcp = F.val ldcp + -- Monoid.mappend, ... + clsMethods = Ghc.classAllSelIds (Ghc.is_cls inst) yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] mkSymbol x = F.dropSym 2 $ GM.simplesymbol x -- res = dcpTyRes dcp @@ -270,6 +275,30 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = subst [] t = t subst ((a, ta):su) t = subsTyVar_meet' (a, ta) (subst su t) +substAuxMethod :: F.Symbol -> M.HashMap F.Symbol F.Symbol -> F.Expr -> F.Expr +substAuxMethod dfun methods e = F.tracepp "substAuxMethod" $ go e + where go :: F.Expr -> F.Expr + go (F.EApp e0 e1) + | F.EVar x <- F.notracepp "e0" e0 + , (F.EVar dfun_mb, args) <- splitEApp e1 + , dfun_mb == dfun + , Just method <- M.lookup x methods + -- Before: Functor.fmap ($p1Applicative $dFunctor) + -- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative) + = eApps (F.EVar method) args + | otherwise + = F.EApp (go e0) (go e1) + go (F.ENeg e) = F.ENeg (go e) + go (F.EBin bop e0 e1) = F.EBin bop (go e0) (go e1) + go (F.EIte e0 e1 e2) = F.EIte (go e0) (go e1) (go e2) + go (F.ECst e0 s) = F.ECst (go e0) s + go (F.ELam (x, t) body) = F.ELam (x, t) (go body) + go (F.PAnd es) = F.PAnd (go <$> es) + go (F.POr es) = F.POr (go <$> es) + go (F.PNot e) = F.PNot (go e) + go (F.PImp e0 e1) = F.PImp (go e0) (go e1) + go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1) + go e = F.notracepp "LEAF" e compileClasses :: From 9768942fa1e250daeba1eb6364ab6a0722fa75b2 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 18 Feb 2020 21:10:13 -0500 Subject: [PATCH 15/38] refinement for method works (except for nat) --- src/Language/Haskell/Liquid/Bare.hs | 42 +++++++------- .../Haskell/Liquid/Constraint/Generate.hs | 6 +- tests/refined-classes/SemigroupOp.hs | 56 ++++++++++++++----- 3 files changed, 68 insertions(+), 36 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 64c13f438e..103545507d 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -141,15 +141,16 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do let lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 mySpec = mySpec2 <> lSpec1 specs = M.insert name mySpec iSpecs2 - measEnv <- makeMeasEnv env tycEnv sigEnv specs - let myRTE = myRTEnv src env sigEnv rtEnv - qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs - sData = makeSpecData src env sigEnv measEnv sig specs - refl = makeSpecRefl cfg src measEnv specs env name sig tycEnv - laws = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs + measEnv = makeMeasEnv env tycEnv sigEnv specs sig = makeSpecSig cfg name specs env sigEnv tycEnv measEnv (giCbs src) auxSig <- makeClassAuxTypes (fmap fst.elaborateSpecType coreToLg) datacons instMethods elaboratedSig <- elaborateSig sig auxSig + let myRTE = myRTEnv src env sigEnv rtEnv + qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs + sData = makeSpecData src env sigEnv measEnv elaboratedSig specs + -- YL: fix + refl = makeSpecRefl cfg src measEnv specs env name elaboratedSig tycEnv + laws = makeSpecLaws env sigEnv (gsTySigs elaboratedSig ++ gsAsmSigs elaboratedSig) measEnv specs pure $ SP { gsConfig = cfg @@ -163,8 +164,8 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do , gsVars = makeSpecVars cfg src mySpec env measEnv , gsTerm = makeSpecTerm cfg mySpec env name -- YL: shoudl I add the sigs here? - , gsLSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1 { - impSigs = makeImports mspecs, + , gsLSpec = makeLiftedSpec src env refl sData elaboratedSig qual myRTE lSpec1 { + impSigs = F.tracepp "makeImports" $ makeImports mspecs, expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ], dataDecls = dataDecls mySpec2 } @@ -253,7 +254,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = headlessSig elaboratedSig <- elab fullSig let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) elaboratedSig - pure (method, F.dummyLoc (F.tracepp "retSig" retSig)) + pure (method, F.dummyLoc retSig) -- is used as a shorthand for instance, following the convention of the Ghc api where @@ -266,7 +267,8 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = isRTvs = makeRTVar . rTyVar <$> isTvs dcp = F.val ldcp -- Monoid.mappend, ... - clsMethods = Ghc.classAllSelIds (Ghc.is_cls inst) + clsMethods = -- filter (\x -> GM.dropModuleNames (F.symbol x) `notElem` method) $ + Ghc.classAllSelIds (Ghc.is_cls inst) yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] mkSymbol x = F.dropSym 2 $ GM.simplesymbol x -- res = dcpTyRes dcp @@ -276,7 +278,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = subst ((a, ta):su) t = subsTyVar_meet' (a, ta) (subst su t) substAuxMethod :: F.Symbol -> M.HashMap F.Symbol F.Symbol -> F.Expr -> F.Expr -substAuxMethod dfun methods e = F.tracepp "substAuxMethod" $ go e +substAuxMethod dfun methods e = F.notracepp "substAuxMethod" $ go e where go :: F.Expr -> F.Expr go (F.EApp e0 e1) | F.EVar x <- F.notracepp "e0" e0 @@ -352,7 +354,7 @@ compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, inst (GM.findVarDefMethod (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst) (giCbs src)) - , let ms = filter GM.isMethod (freeVars mempty e) + , let ms = filter (\x -> GM.isMethod x) (GM.tracePpr "Free Vars" $ freeVars mempty e) ] instClss :: [(Ghc.ClsInst, Ghc.Class)] instClss = @@ -385,7 +387,7 @@ splitSpecs name specs = (mySpec, iSpecm) makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)] -makeImports specs = F.tracepp "imported" $ concatMap (expSigs . snd) specs' +makeImports specs = concatMap (expSigs . snd) specs' where specs' = filter (isSrcImport . fst) specs @@ -621,10 +623,10 @@ makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ------------------------------------------------------------------------------------------ makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl { gsLogicMap = lmap - , gsAutoInst = makeAutoInst env name mySpec + , gsAutoInst = F.tracepp "autoInst" $ makeAutoInst env name mySpec , gsImpAxioms = concatMap (Ms.axeqs . snd) (M.toList specs) - , gsMyAxioms = F.notracepp "gsMyAxioms" myAxioms - , gsReflects = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects) + , gsMyAxioms = F.tracepp "gsMyAxioms" myAxioms + , gsReflects = F.tracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects) , gsHAxioms = F.notracepp "gsHAxioms" xtes , gsWiredReft = wReflects } @@ -1082,15 +1084,15 @@ knownWiredTyCons env name = filter isKnown wiredTyCons -- REBARE: formerly, makeGhcCHOP2 ------------------------------------------------------------------------------------------- -makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Ghc.Ghc Bare.MeasEnv +makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Bare.MeasEnv ------------------------------------------------------------------------------------------- -makeMeasEnv env tycEnv sigEnv specs = do +makeMeasEnv env tycEnv sigEnv specs = -- datacons' <- forM datacons $ \dc -> -- if Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon $ dc -- then Bare.elaborateClassDcp coreToLg dc -- else pure dc - let cs' = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec embs cs (datacons ++ cls)] - pure $ Bare.MeasEnv + let cs' = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec embs cs (datacons ++ cls)] in + Bare.MeasEnv { meMeasureSpec = measures , meClassSyms = cms' , meSyms = ms' diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index 2b7e2ec33b..f648d0147b 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -678,7 +678,7 @@ cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ) = addHole x t γ cconsE' γ e t - = do te <- consE γ (GM.tracePpr "cconsE'" e) + = do te <- consE γ e te' <- instantiatePreds γ e te >>= addPost γ addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e) @@ -765,7 +765,7 @@ instantiatePreds :: CGEnv -> SpecType -> CG SpecType instantiatePreds γ e (RAllP π t) - = do r <- F.tracepp "instantiatePreds" <$> freshPredRef γ e π + = do r <- freshPredRef γ e π instantiatePreds γ e $ replacePreds "consE" t [(π, r)] instantiatePreds _ _ t0 @@ -805,7 +805,7 @@ consE γ e -- [NOTE: PLE-OPT] We *disable* refined instantiation for -- reflected functions inside proofs. consE γ (Var x) - = do t <- F.tracepp "varRefType" <$> varRefType γ (GM.tracePpr "consEVar" x) + = do t <- varRefType γ x addLocA (Just x) (getLocation γ) (varAnn γ x t) return t diff --git a/tests/refined-classes/SemigroupOp.hs b/tests/refined-classes/SemigroupOp.hs index 2ae4b6e349..fd1af8803d 100644 --- a/tests/refined-classes/SemigroupOp.hs +++ b/tests/refined-classes/SemigroupOp.hs @@ -3,27 +3,57 @@ {-@ LIQUID "--extensionality" @-} {-@ LIQUID "--ple" @-} module SemigroupOp where - +import ProofCombinators class YYSemigroup a where ymappend :: a -> a -> a {-@ lawAssociative :: v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} lawAssociative :: a -> a -> a -> () -data Op a = Op a +data PNat = Z | S PNat + -{-@ reflect mappendOp @-} -mappendOp :: (YYSemigroup a) => Op a -> Op a -> Op a -mappendOp (Op x) (Op y) = Op (ymappend y x) -{-@ lawAssociativeOp :: YYSemigroup a => v:Op a -> v':Op a -> v'':Op a -> {mappendOp (mappendOp v v') v'' == mappendOp v (mappendOp v' v'') }@-} -lawAssociativeOp :: YYSemigroup a => Op a -> Op a -> Op a -> () -lawAssociativeOp (Op x) (Op y) (Op z) = lawAssociative z y x +-- instance YYSemigroup PNat where +-- ymappend _ _ = Z +-- lawAssociative _ _ _ = () -{-@ mylawAssociative :: YYSemigroup a => v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} -mylawAssociative :: YYSemigroup a => a -> a -> a -> () -mylawAssociative x y z = lawAssociative x y z +-- instance YYSemigroup PNat where +-- ymappend Z n = n +-- -- S (ymappend d m n) == S ($cmappend m n) +-- ymappend (S m) n = S (ymappend m n) +-- -- lawAssociative m n p = undefined +-- lawAssociative Z m n = ymappend Z (ymappend m n) `k` +-- ymappend m n `k` +-- ymappend (ymappend Z m) n `k` +-- () +-- lawAssociative (S p) m n = ymappend (S p) (ymappend m n) `k` +-- S (ymappend p (ymappend m n)) `k` +-- lawAssociative p m n `k` +-- S (ymappend (ymappend p m) n) `k` +-- ymappend (S (ymappend p m) ) n `k` +-- ymappend (ymappend (S p) m ) n `k` +-- () + + +data Op a = Op a + +k :: a -> b -> b +k _ y = y instance (YYSemigroup a) => YYSemigroup (Op a) where - ymappend = mappendOp - lawAssociative x y z = lawAssociativeOp x y z + ymappend (Op x) (Op y) = Op (ymappend y x) + lawAssociative (Op x) (Op y) (Op z) = lawAssociative z y x `k` (1 =>= 3) `cast` () + +-- -- {-@ reflect mappendOp @-} +-- -- mappendOp :: (YYSemigroup a) => Op a -> Op a -> Op a +-- -- mappendOp (Op x) (Op y) = Op (ymappend y x) + +-- -- {-@ lawAssociativeOp :: YYSemigroup a => v:Op a -> v':Op a -> v'':Op a -> {mappendOp (mappendOp v v') v'' == mappendOp v (mappendOp v' v'') }@-} +-- -- lawAssociativeOp :: YYSemigroup a => Op a -> Op a -> Op a -> () +-- -- lawAssociativeOp (Op x) (Op y) (Op z) = lawAssociative z y x + +-- {-@ mylawAssociative :: YYSemigroup a => v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} +-- mylawAssociative :: YYSemigroup a => a -> a -> a -> () +-- mylawAssociative = lawAssociative + From af0cfae10f392a75feeff2dc6b4d4d682444f14c Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 19 Feb 2020 13:37:05 -0500 Subject: [PATCH 16/38] add inlineaux pass but tcsplitdfunty panics --- liquidhaskell.cabal | 1 + src/Language/Haskell/Liquid/Transforms/ANF.hs | 4 + .../Haskell/Liquid/Transforms/InlineAux.hs | 100 ++++++++++++++++++ 3 files changed, 105 insertions(+) create mode 100644 src/Language/Haskell/Liquid/Transforms/InlineAux.hs diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index 978eb91aa3..17d8837399 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -124,6 +124,7 @@ library Language.Haskell.Liquid.Transforms.ANF Language.Haskell.Liquid.Transforms.CoreToLogic Language.Haskell.Liquid.Transforms.Rec + Language.Haskell.Liquid.Transforms.InlineAux Language.Haskell.Liquid.Transforms.RefSplit Language.Haskell.Liquid.Transforms.Rewrite Language.Haskell.Liquid.Transforms.Simplify diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index c644e65494..d1adca6751 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -41,6 +41,7 @@ import Language.Haskell.Liquid.UX.Config as UX import qualified Language.Haskell.Liquid.Misc as Misc import Language.Haskell.Liquid.GHC.Misc as GM import Language.Haskell.Liquid.Transforms.Rec +import Language.Haskell.Liquid.Transforms.InlineAux import Language.Haskell.Liquid.Transforms.Rewrite import Language.Haskell.Liquid.Types.Errors @@ -60,6 +61,8 @@ anormalize cfg hscEnv modGuts = do whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" putStrLn $ GM.showCBs untidy (mg_binds modGuts) + putStrLn "***************************** AUX CoreBinds ***************************" + putStrLn $ GM.showCBs untidy aux_cbs putStrLn "***************************** REC CoreBinds ***************************" putStrLn $ GM.showCBs untidy orig_cbs putStrLn "***************************** RWR CoreBinds ***************************" @@ -70,6 +73,7 @@ anormalize cfg hscEnv modGuts = do act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs γ0 = emptyAnfEnv cfg rwr_cbs = rewriteBinds cfg orig_cbs + aux_cbs = inlineAux $ mg_binds modGuts orig_cbs = transformRecExpr $ mg_binds modGuts untidy = UX.untidyCore cfg diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs new file mode 100644 index 0000000000..084a082aca --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -0,0 +1,100 @@ +module Language.Haskell.Liquid.Transforms.InlineAux + ( inlineAux + ) +where + +import CoreSyn +import Control.Arrow ( second ) +import qualified Language.Haskell.Liquid.GHC.Misc + as GM +import Class ( classAllSelIds ) +import Id +import CoreFVs ( exprFreeVarsList ) +import InstEnv +import TcType ( tcSplitDFunHead ) +import GhcPlugins ( isDFunId + , OccName + , occNameString + , getOccName + , mkCoreApps + ) +import qualified Data.HashMap.Strict as M + +-- Issue: mappend (S n) m = S (mappend n m) +-- in core: +-- $cmappend_Nat (S n) m = S (mappend $fMonoid_Nat n m) +-- $fMonoid_nat = C:Monoid $cmappend_nat $cmempty +-- note that now there's mutual dependence between $cmappend_Nat and $fMonoid_nat +-- to address this problem, we do the substitution: mappend $Monoid_Nat -> $cmappend_Nat + + +inlineAux :: CoreProgram -> CoreProgram +inlineAux cbs = map f cbs + where + f :: CoreBind -> CoreBind + f all@(NonRec x e) + | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux = NonRec + x + (inlineAuxExpr dfunId methodToAux e) + | otherwise = all + f (Rec bs) = Rec (fmap g bs) + where + g all@(x, e) + | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux + = (x, inlineAuxExpr dfunId methodToAux e) + | otherwise + = all + auxToMethodToAux = mconcat $ fmap (uncurry dfunIdSubst) (grepDFunIds cbs) + + + +-- grab the dictionaries +grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)] +grepDFunIds = GM.tracePpr "grepDFunIds" . filter (isDFunId . fst) . flattenBinds + +isClassOpAuxOccName :: OccName -> Bool +isClassOpAuxOccName occ = case occNameString occ of + '$' : 'c' : _ -> True + _ -> False + +isClassOpAuxOf :: Id -> Id -> Bool +isClassOpAuxOf aux method = case occNameString $ getOccName aux of + '$' : 'c' : rest -> rest == occNameString (getOccName method) + _ -> False + +dfunIdSubst :: DFunId -> CoreExpr -> M.HashMap Id (Id, M.HashMap Id Id) +dfunIdSubst dfunId e = M.fromList $ zip auxIds (repeat (dfunId, methodToAux)) + where + methodToAux = M.fromList + [ GM.tracePpr "methodToAux" (m, aux) | m <- methods, aux <- auxIds, aux `isClassOpAuxOf` m ] + (cls, _) = GM.tracePpr "splitdfun" $ tcSplitDFunHead (idType (GM.tracePpr "dfunId" dfunId)) + auxIds = filter (isClassOpAuxOccName . getOccName) (exprFreeVarsList e) + methods = classAllSelIds cls + +inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr +inlineAuxExpr dfunId methodToAux = go + where + go :: CoreExpr -> CoreExpr + go (App e arg) + | Var m <- e + , Just aux <- M.lookup m methodToAux + , (Var x, args) <- collectArgs arg + , x == dfunId + = mkCoreApps (Var aux) args + | otherwise + = App (go e) (go arg) + go (Lam b body ) = Lam b (go body) + go (Let b e ) = Let (mapBnd go b) (go e) + go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts) + go (Cast e c ) = Cast (go e) c + go (Tick t e ) = Tick t (go e) + go e = e + + +-- modified from Rec.hs +mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b +mapBnd f (NonRec b e) = NonRec b (f e) +mapBnd f (Rec bs ) = Rec (map (second f) bs) + +mapAlt :: (Expr b -> Expr b) -> (t, t1, Expr b) -> (t, t1, Expr b) +mapAlt f (d, bs, e) = (d, bs, f e) From 9bce07022a2e74ce777940f72875982d51a6c71a Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 19 Feb 2020 14:24:30 -0500 Subject: [PATCH 17/38] fix inlineaux substitution --- .../Haskell/Liquid/Transforms/InlineAux.hs | 38 +++++++++++-------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index 084a082aca..365351b190 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -11,7 +11,7 @@ import Class ( classAllSelIds ) import Id import CoreFVs ( exprFreeVarsList ) import InstEnv -import TcType ( tcSplitDFunHead ) +import TcType ( tcSplitDFunTy ) import GhcPlugins ( isDFunId , OccName , occNameString @@ -50,7 +50,7 @@ inlineAux cbs = map f cbs -- grab the dictionaries grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)] -grepDFunIds = GM.tracePpr "grepDFunIds" . filter (isDFunId . fst) . flattenBinds +grepDFunIds = filter (isDFunId . fst) . flattenBinds isClassOpAuxOccName :: OccName -> Bool isClassOpAuxOccName occ = case occNameString occ of @@ -66,29 +66,37 @@ dfunIdSubst :: DFunId -> CoreExpr -> M.HashMap Id (Id, M.HashMap Id Id) dfunIdSubst dfunId e = M.fromList $ zip auxIds (repeat (dfunId, methodToAux)) where methodToAux = M.fromList - [ GM.tracePpr "methodToAux" (m, aux) | m <- methods, aux <- auxIds, aux `isClassOpAuxOf` m ] - (cls, _) = GM.tracePpr "splitdfun" $ tcSplitDFunHead (idType (GM.tracePpr "dfunId" dfunId)) - auxIds = filter (isClassOpAuxOccName . getOccName) (exprFreeVarsList e) - methods = classAllSelIds cls + [ (m, aux) | m <- methods, aux <- auxIds, aux `isClassOpAuxOf` m ] + (_, _, cls, _) = tcSplitDFunTy (idType dfunId) + auxIds = filter (isClassOpAuxOccName . getOccName) (exprFreeVarsList e) + methods = classAllSelIds cls inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr inlineAuxExpr dfunId methodToAux = go where go :: CoreExpr -> CoreExpr - go (App e arg) - | Var m <- e - , Just aux <- M.lookup m methodToAux - , (Var x, args) <- collectArgs arg - , x == dfunId - = mkCoreApps (Var aux) args - | otherwise - = App (go e) (go arg) + -- go (App e arg) + -- | Var m <- e + -- , Just aux <- M.lookup m methodToAux + -- , (Var x, args, _) <- GM.tracePpr "collecting" $ collectArgs arg + -- , x == dfunId + -- = mkCoreApps (Var aux) args + -- | otherwise + -- = App (go e) (go arg) go (Lam b body ) = Lam b (go body) go (Let b e ) = Let (mapBnd go b) (go e) go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts) go (Cast e c ) = Cast (go e) c go (Tick t e ) = Tick t (go e) - go e = e + go e + | (Var m, args) <- collectArgs e + , Just aux <- M.lookup m methodToAux + , arg : argsNoTy <- dropWhile isTypeArg args + , (Var x, argargs) <- collectArgs arg + , x == dfunId + = mkCoreApps (Var aux) (argargs ++ argsNoTy) + go (App e0 e1) = App (go e0) (go e1) + go e = e -- modified from Rec.hs From 331f2bd25b413575dce3eb7600173367943a88c2 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 19 Feb 2020 14:24:56 -0500 Subject: [PATCH 18/38] forgot to add the pass --- src/Language/Haskell/Liquid/Transforms/ANF.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index d1adca6751..272df60d5a 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -72,7 +72,7 @@ anormalize cfg hscEnv modGuts = do err = panic Nothing "Oops, cannot A-Normalize GHC Core!" act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs γ0 = emptyAnfEnv cfg - rwr_cbs = rewriteBinds cfg orig_cbs + rwr_cbs = rewriteBinds cfg aux_cbs aux_cbs = inlineAux $ mg_binds modGuts orig_cbs = transformRecExpr $ mg_binds modGuts untidy = UX.untidyCore cfg From d3e09dc4931dc12e60737e4ce5c584a70eef0de1 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 19 Feb 2020 15:36:16 -0500 Subject: [PATCH 19/38] make recursive call n argsNoTy --- .../Haskell/Liquid/Transforms/InlineAux.hs | 20 ++----------------- 1 file changed, 2 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index 365351b190..b9cff792f3 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -6,7 +6,7 @@ where import CoreSyn import Control.Arrow ( second ) import qualified Language.Haskell.Liquid.GHC.Misc - as GM + ( ) import Class ( classAllSelIds ) import Id import CoreFVs ( exprFreeVarsList ) @@ -20,14 +20,6 @@ import GhcPlugins ( isDFunId ) import qualified Data.HashMap.Strict as M --- Issue: mappend (S n) m = S (mappend n m) --- in core: --- $cmappend_Nat (S n) m = S (mappend $fMonoid_Nat n m) --- $fMonoid_nat = C:Monoid $cmappend_nat $cmempty --- note that now there's mutual dependence between $cmappend_Nat and $fMonoid_nat --- to address this problem, we do the substitution: mappend $Monoid_Nat -> $cmappend_Nat - - inlineAux :: CoreProgram -> CoreProgram inlineAux cbs = map f cbs where @@ -75,14 +67,6 @@ inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr inlineAuxExpr dfunId methodToAux = go where go :: CoreExpr -> CoreExpr - -- go (App e arg) - -- | Var m <- e - -- , Just aux <- M.lookup m methodToAux - -- , (Var x, args, _) <- GM.tracePpr "collecting" $ collectArgs arg - -- , x == dfunId - -- = mkCoreApps (Var aux) args - -- | otherwise - -- = App (go e) (go arg) go (Lam b body ) = Lam b (go body) go (Let b e ) = Let (mapBnd go b) (go e) go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts) @@ -94,7 +78,7 @@ inlineAuxExpr dfunId methodToAux = go , arg : argsNoTy <- dropWhile isTypeArg args , (Var x, argargs) <- collectArgs arg , x == dfunId - = mkCoreApps (Var aux) (argargs ++ argsNoTy) + = mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy)) go (App e0 e1) = App (go e0) (go e1) go e = e From 39c20e13c961b41445a10971db9b0903665f14d0 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 19 Feb 2020 18:22:01 -0500 Subject: [PATCH 20/38] clean up and add failed sugared monoidassoc & desugared example --- src/Language/Haskell/Liquid/Bare.hs | 15 ++-- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 1 - src/Language/Haskell/Liquid/GHC/Misc.hs | 12 --- tests/refined-classes/SemigroupOp.hs | 82 +++++++++++-------- tests/refined-classes/SubclassMonoidDs.hs | 35 ++++++++ 5 files changed, 90 insertions(+), 55 deletions(-) create mode 100644 tests/refined-classes/SubclassMonoidDs.hs diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 103545507d..92e2e132bb 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -165,7 +165,7 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do , gsTerm = makeSpecTerm cfg mySpec env name -- YL: shoudl I add the sigs here? , gsLSpec = makeLiftedSpec src env refl sData elaboratedSig qual myRTE lSpec1 { - impSigs = F.tracepp "makeImports" $ makeImports mspecs, + impSigs = makeImports mspecs, expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ], dataDecls = dataDecls mySpec2 } @@ -259,7 +259,10 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = -- is used as a shorthand for instance, following the convention of the Ghc api where -- (Monoid.mappend -> $cmappend##Int, ...) + -- core rewriting mark2: do the same thing except they don't have to be symbols + -- YL: poorly written. use a comprehension instead of assuming methodsSet = M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) + -- core rewriting mark1: dfunId dfunSym = F.symbol $ Ghc.instanceDFunId inst (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst isSpecTys = ofType <$> isTys @@ -267,12 +270,12 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = isRTvs = makeRTVar . rTyVar <$> isTvs dcp = F.val ldcp -- Monoid.mappend, ... - clsMethods = -- filter (\x -> GM.dropModuleNames (F.symbol x) `notElem` method) $ + clsMethods = filter (\x -> GM.dropModuleNames (F.symbol x) `elem` fmap mkSymbol methods) $ Ghc.classAllSelIds (Ghc.is_cls inst) yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] mkSymbol x = F.dropSym 2 $ GM.simplesymbol x -- res = dcpTyRes dcp - clsTvs = F.tracepp "clsTvs" $ dcpFreeTyVars dcp + clsTvs = dcpFreeTyVars dcp -- copy/pasted from Bare/Class.hs subst [] t = t subst ((a, ta):su) t = subsTyVar_meet' (a, ta) (subst su t) @@ -623,10 +626,10 @@ makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ------------------------------------------------------------------------------------------ makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl { gsLogicMap = lmap - , gsAutoInst = F.tracepp "autoInst" $ makeAutoInst env name mySpec + , gsAutoInst = makeAutoInst env name mySpec , gsImpAxioms = concatMap (Ms.axeqs . snd) (M.toList specs) - , gsMyAxioms = F.tracepp "gsMyAxioms" myAxioms - , gsReflects = F.tracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects) + , gsMyAxioms = F.notracepp "gsMyAxioms" myAxioms + , gsReflects = lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects , gsHAxioms = F.notracepp "gsHAxioms" xtes , gsWiredReft = wReflects } diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index c82e187f3b..cf47b18b8d 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -26,7 +26,6 @@ import Data.Functor.Foldable import Data.Char ( isUpper ) import GHC import OccName -import Var (varType) import FastString import CoreSyn import PrelNames diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index fd7e009854..b018fd53cd 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -979,15 +979,3 @@ elabRnExpr hsc_env mode rdr_expr = TM_Inst -> (True, NoRestrictions, id) TM_NoInst -> (False, NoRestrictions, id) TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - -splitThetaTy :: Type -> ([TyVar], [Type], Type) -splitThetaTy ty = (tvs, clss, res') - where (tvs, res) = splitForAllTys ty - (clss, res') = splitFunClsTys res - -splitFunClsTys :: Type -> ([Type], Type) -splitFunClsTys ty = split [] ty ty - where - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy arg res) | isPredType arg = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) diff --git a/tests/refined-classes/SemigroupOp.hs b/tests/refined-classes/SemigroupOp.hs index fd1af8803d..a47b1302fe 100644 --- a/tests/refined-classes/SemigroupOp.hs +++ b/tests/refined-classes/SemigroupOp.hs @@ -1,59 +1,69 @@ {-# LANGUAGE RankNTypes #-} {-@ LIQUID "--reflection" @-} -{-@ LIQUID "--extensionality" @-} {-@ LIQUID "--ple" @-} module SemigroupOp where import ProofCombinators -class YYSemigroup a where +class MySemigroup a where ymappend :: a -> a -> a {-@ lawAssociative :: v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} lawAssociative :: a -> a -> a -> () +class (MySemigroup a) => MyMonoid a where + ymempty :: a + {-@ lawEmpty :: x:a -> {ymappend x ymempty == x && ymappend ymempty x == x} @-} + lawEmpty :: a -> () + + data PNat = Z | S PNat +instance MyMonoid PNat where + ymempty = Z + lawEmpty Z = () + lawEmpty (S m) = lawEmpty m --- instance YYSemigroup PNat where --- ymappend _ _ = Z --- lawAssociative _ _ _ = () +k :: a -> b -> b +k _ y = y --- instance YYSemigroup PNat where --- ymappend Z n = n --- -- S (ymappend d m n) == S ($cmappend m n) --- ymappend (S m) n = S (ymappend m n) --- -- lawAssociative m n p = undefined --- lawAssociative Z m n = ymappend Z (ymappend m n) `k` --- ymappend m n `k` --- ymappend (ymappend Z m) n `k` --- () --- lawAssociative (S p) m n = ymappend (S p) (ymappend m n) `k` --- S (ymappend p (ymappend m n)) `k` --- lawAssociative p m n `k` --- S (ymappend (ymappend p m) n) `k` --- ymappend (S (ymappend p m) ) n `k` --- ymappend (ymappend (S p) m ) n `k` --- () +-- does not typecheck +{-@ assocMonoid :: MyMonoid a => a:a -> b:a -> c:a -> {ymappend a (ymappend b c) == ymappend (ymappend a b) c} @-} +assocMonoid :: MyMonoid a => a -> a -> a -> () +assocMonoid a b c = lawAssociative a b c -data Op a = Op a +instance MySemigroup PNat where + ymappend Z n = n + ymappend (S m) n = S (ymappend m n) + lawAssociative Z m n = ymappend Z (ymappend m n) `k` + ymappend m n `k` + ymappend (ymappend Z m) n `k` + () + lawAssociative (S p) m n = ymappend (S p) (ymappend m n) `k` + S (ymappend p (ymappend m n)) `k` + lawAssociative p m n `k` + S (ymappend (ymappend p m) n) `k` + ymappend (S (ymappend p m) ) n `k` + ymappend (ymappend (S p) m ) n `k` + () -k :: a -> b -> b -k _ y = y +data MyList a = + MyNil + | MyCons a (MyList a) -instance (YYSemigroup a) => YYSemigroup (Op a) where - ymappend (Op x) (Op y) = Op (ymappend y x) - lawAssociative (Op x) (Op y) (Op z) = lawAssociative z y x `k` (1 =>= 3) `cast` () --- -- {-@ reflect mappendOp @-} --- -- mappendOp :: (YYSemigroup a) => Op a -> Op a -> Op a --- -- mappendOp (Op x) (Op y) = Op (ymappend y x) +instance MySemigroup (MyList a) where + ymappend MyNil t = t + ymappend (MyCons v l) t = MyCons v (ymappend l t) + + -- lawAssociativity x y z = assume (mymappend x (mymappend y z) == mymappend (mymappend x y) z) + lawAssociative MyNil _ _ = () + lawAssociative (MyCons x xs) y z = lawAssociative xs y z + +data Op a = Op a --- -- {-@ lawAssociativeOp :: YYSemigroup a => v:Op a -> v':Op a -> v'':Op a -> {mappendOp (mappendOp v v') v'' == mappendOp v (mappendOp v' v'') }@-} --- -- lawAssociativeOp :: YYSemigroup a => Op a -> Op a -> Op a -> () --- -- lawAssociativeOp (Op x) (Op y) (Op z) = lawAssociative z y x --- {-@ mylawAssociative :: YYSemigroup a => v:a -> v':a -> v'':a -> {ymappend (ymappend v v') v'' == ymappend v (ymappend v' v'')} @-} --- mylawAssociative :: YYSemigroup a => a -> a -> a -> () --- mylawAssociative = lawAssociative +instance (MySemigroup a) => MySemigroup (Op a) where + ymappend (Op x) (Op y) = Op (ymappend y x) + lawAssociative (Op x) (Op y) (Op z) = lawAssociative z y x `cast` () diff --git a/tests/refined-classes/SubclassMonoidDs.hs b/tests/refined-classes/SubclassMonoidDs.hs new file mode 100644 index 0000000000..1723cb734d --- /dev/null +++ b/tests/refined-classes/SubclassMonoidDs.hs @@ -0,0 +1,35 @@ +{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple" @-} +module SemigroupDs where + +import Prelude hiding (Semigroup, mappend) + + + +{-@ data MySemigroup a = CMySemigroup { + mappend :: a -> a -> a, + lawAssociative :: x:a -> y:a -> z:a -> {mappend x (mappend y z) == mappend (mappend x y) z} } @-} + +data MySemigroup a = CMySemigroup{ + mappend :: a -> a -> a, + lawAssociative :: a -> a -> a -> ()} + +{-@ data MyMonoid a = CMyMonoid { + p1MyMonoid :: MySemigroup a, + mempty :: a, + lawEmpty :: x:a -> {mappend p1MyMonoid x mempty == x && mappend p1MyMonoid mempty x == x}} +@-} + +data MyMonoid a = CMyMonoid { + p1MyMonoid :: MySemigroup a, + mempty :: a, + lawEmpty :: a -> () + } + +{-@ monoidAssoc :: dMyMonoid:MyMonoid a -> a:a -> b:a -> c:a -> + {mappend (p1MyMonoid dMyMonoid) (mappend (p1MyMonoid dMyMonoid) a b) c /= + mappend (p1MyMonoid dMyMonoid) a (mappend (p1MyMonoid dMyMonoid) b c)} @-} +monoidAssoc :: MyMonoid a -> a -> a -> a -> () +monoidAssoc dMyMonoid = + let dMySemigroup = p1MyMonoid dMyMonoid in + \a b c -> lawAssociative dMySemigroup a b c From b3f12195fcfa2349bb87c5cc6a49878808bbc0d3 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 21 Feb 2020 16:07:59 -0500 Subject: [PATCH 21/38] add termination check for dictionraies. break Rec --- src/Language/Haskell/Liquid/Bare.hs | 11 +++++------ src/Language/Haskell/Liquid/Bare/DataType.hs | 10 +++++++--- .../Haskell/Liquid/Constraint/Generate.hs | 2 +- src/Language/Haskell/Liquid/GHC/Interface.hs | 2 +- src/Language/Haskell/Liquid/Transforms/ANF.hs | 6 +++--- .../Haskell/Liquid/Transforms/InlineAux.hs | 16 +++++++++++----- 6 files changed, 28 insertions(+), 19 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 92e2e132bb..afd19a4e3d 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -138,7 +138,9 @@ makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc ------------------------------------------------------------------------------------- makeGhcSpec0 cfg src lmap mspecsNoClass = do tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg - let lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 + let tyi = Bare.tcTyConMap tycEnv + sigEnv = makeSigEnv embs tyi (gsExports src) rtEnv + lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 mySpec = mySpec2 <> lSpec1 specs = M.insert name mySpec iSpecs2 measEnv = makeMeasEnv env tycEnv sigEnv specs @@ -198,8 +200,6 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do dm = Bare.tcDataConMap tycEnv0 -- build up environments - sigEnv = makeSigEnv embs tyi (gsExports src) rtEnv - tyi = Bare.tcTyConMap tycEnv0 (tycEnv0, datacons) = makeTycEnv0 cfg name env embs mySpec2 iSpecs2 mySpec2 = Bare.qualifyExpand env name rtEnv l [] mySpec1 where l = F.dummyPos "expand-mySpec2" iSpecs2 = Bare.qualifyExpand env name rtEnv l [] iSpecs0 where l = F.dummyPos "expand-iSpecs2" @@ -305,7 +305,6 @@ substAuxMethod dfun methods e = F.notracepp "substAuxMethod" $ go e go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1) go e = F.notracepp "LEAF" e - compileClasses :: GhcSrc -> Bare.Env @@ -318,7 +317,7 @@ compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, inst mempty { dataDecls = clsDecls , reflects = - F.tracepp "reflects " $ + -- F.tracepp "reflects " $ S.fromList (fmap (fmap GM.dropModuleNames . @@ -357,7 +356,7 @@ compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, inst (GM.findVarDefMethod (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst) (giCbs src)) - , let ms = filter (\x -> GM.isMethod x) (GM.tracePpr "Free Vars" $ freeVars mempty e) + , let ms = filter GM.isMethod (freeVars mempty e) ] instClss :: [(Ghc.ClsInst, Ghc.Class)] instClss = diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 8d3a3753ae..fe1b191cd4 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -482,7 +482,7 @@ elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> DataConP -> Ghc.Ghc (DataConP , elaborateClassDcp coreToLg dcp = do t' <- forM fts $ elaborateSpecType coreToLg let ts' = F.tracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> (fst <$> t') - pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = zip xs (fst <$> t')}) + pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs (fst <$> t'))}) where resTy = dcpTyRes dcp dc = dcpCon dcp @@ -494,12 +494,16 @@ elaborateClassDcp coreToLg dcp = do -- turns forall a b. (a -> b) -> f a -> f b into -- forall f. Functor f => forall a b. (a -> b) -> f a -> f b stripPred :: SpecType -> SpecType - stripPred t = tres - where (tvs, pvs, _, tres) = bkUnivClass t + stripPred = Misc.fourth4 . bkUnivClass fullTy :: SpecType -> SpecType fullTy t = F.notracepp "fullTy" $ mkArrow tvars [] [] [(F.symbol dc, F.notracepp "resTy" resTy, mempty)] t + strengthenTy :: F.Symbol -> SpecType -> SpecType + strengthenTy x t = mkUnivs tvs pvs (RFun z cls (t' `RT.strengthen` mt) r) + where (tvs, pvs, (RFun z cls t' r)) = bkUniv t + vv = rTypeValueVar t' + mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z))) substClassOpBinding :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index f648d0147b..67f783164f 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -297,7 +297,7 @@ doTermCheck :: Config -> Bind Var -> CG Bool doTermCheck cfg bind = do lazyVs <- specLazy <$> get termVs <- specTmVars <$> get - let skip = any (\x -> S.member x lazyVs || GM.isInternal x) xs + let skip = any (\x -> S.member x lazyVs || GM.isEmbeddedDictVar x) xs let chk = not (structuralTerm cfg) || any (\x -> S.member x termVs) xs return $ chk && not skip where diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 6e918795df..9419473ab5 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -489,7 +489,7 @@ makeGhcSrc cfg file typechecked modSum = do , giTargetMod = ModName Target (moduleName (ms_mod modSum)) , giCbs = coreBinds , giImpVars = impVars - , giDefVars = dataCons ++ (letVars coreBinds) + , giDefVars = dataCons ++ letVars coreBinds , giUseVars = readVars coreBinds , giDerVars = S.fromList (derivedVars cfg modGuts) , gsExports = mgi_exports modGuts diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 272df60d5a..35fb4ab8a8 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -72,9 +72,9 @@ anormalize cfg hscEnv modGuts = do err = panic Nothing "Oops, cannot A-Normalize GHC Core!" act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs γ0 = emptyAnfEnv cfg - rwr_cbs = rewriteBinds cfg aux_cbs - aux_cbs = inlineAux $ mg_binds modGuts - orig_cbs = transformRecExpr $ mg_binds modGuts + rwr_cbs = rewriteBinds cfg orig_cbs + orig_cbs = transformRecExpr aux_cbs + aux_cbs = inlineAux (mg_module modGuts) $ mg_binds modGuts untidy = UX.untidyCore cfg {- diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index b9cff792f3..d37f4e2b15 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -5,8 +5,9 @@ where import CoreSyn import Control.Arrow ( second ) +import OccurAnal ( occurAnalysePgm ) import qualified Language.Haskell.Liquid.GHC.Misc - ( ) + as GM import Class ( classAllSelIds ) import Id import CoreFVs ( exprFreeVarsList ) @@ -14,14 +15,16 @@ import InstEnv import TcType ( tcSplitDFunTy ) import GhcPlugins ( isDFunId , OccName + , Module , occNameString , getOccName , mkCoreApps ) import qualified Data.HashMap.Strict as M +import CoreSubst -inlineAux :: CoreProgram -> CoreProgram -inlineAux cbs = map f cbs +inlineAux :: Module -> CoreProgram -> CoreProgram +inlineAux m cbs = occurAnalysePgm m (const True) (const False) [] (map f cbs) where f :: CoreBind -> CoreBind f all@(NonRec x e) @@ -64,10 +67,12 @@ dfunIdSubst dfunId e = M.fromList $ zip auxIds (repeat (dfunId, methodToAux)) methods = classAllSelIds cls inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr -inlineAuxExpr dfunId methodToAux = go +inlineAuxExpr dfunId methodToAux e = go e where go :: CoreExpr -> CoreExpr go (Lam b body ) = Lam b (go body) + -- go (Let b e) + -- | go (Let b e ) = Let (mapBnd go b) (go e) go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts) go (Cast e c ) = Cast (go e) c @@ -78,7 +83,8 @@ inlineAuxExpr dfunId methodToAux = go , arg : argsNoTy <- dropWhile isTypeArg args , (Var x, argargs) <- collectArgs arg , x == dfunId - = mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy)) + = GM.tracePpr ("inlining in" ++ GM.showPpr e) + $ mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy)) go (App e0 e1) = App (go e0) (go e1) go e = e From f8cc32a908729fc4f4e457ebaa44e1b2e69117df Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 21 Feb 2020 16:45:27 -0500 Subject: [PATCH 22/38] perform let $d = $f ... substitutiton --- .../Haskell/Liquid/Transforms/InlineAux.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index d37f4e2b15..6ffd9f2a50 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -4,6 +4,8 @@ module Language.Haskell.Liquid.Transforms.InlineAux where import CoreSyn +import qualified Outputable as O + ( empty ) import Control.Arrow ( second ) import OccurAnal ( occurAnalysePgm ) import qualified Language.Haskell.Liquid.GHC.Misc @@ -19,12 +21,13 @@ import GhcPlugins ( isDFunId , occNameString , getOccName , mkCoreApps + , isDictId ) import qualified Data.HashMap.Strict as M import CoreSubst inlineAux :: Module -> CoreProgram -> CoreProgram -inlineAux m cbs = occurAnalysePgm m (const True) (const False) [] (map f cbs) +inlineAux m cbs = occurAnalysePgm m (const False) (const False) [] (map f cbs) where f :: CoreBind -> CoreBind f all@(NonRec x e) @@ -70,10 +73,11 @@ inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr inlineAuxExpr dfunId methodToAux e = go e where go :: CoreExpr -> CoreExpr - go (Lam b body ) = Lam b (go body) - -- go (Let b e) - -- | - go (Let b e ) = Let (mapBnd go b) (go e) + go (Lam b body) = Lam b (go body) + go (Let b body) + | NonRec x e <- b, isDictId x = go + $ substExpr O.empty (extendIdSubst emptySubst x e) body + | otherwise = Let (mapBnd go b) (go body) go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts) go (Cast e c ) = Cast (go e) c go (Tick t e ) = Tick t (go e) From 9ccc8c5a064c6bcd2481556fdf701a9f58a96145 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 21 Feb 2020 17:27:53 -0500 Subject: [PATCH 23/38] fix makeClassAuxTypesOne unreachable --- src/Language/Haskell/Liquid/Bare.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index afd19a4e3d..5079e458cf 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -242,7 +242,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = let headlessSig = case L.lookup (mkSymbol method) yts of Nothing -> - impossible Nothing "makeClassAuxTypesOne : not reachable?" + impossible Nothing ("makeClassAuxTypesOne : not reachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts) Just sig -> sig fullSig = mkArrow @@ -273,7 +273,9 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = clsMethods = filter (\x -> GM.dropModuleNames (F.symbol x) `elem` fmap mkSymbol methods) $ Ghc.classAllSelIds (Ghc.is_cls inst) yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] - mkSymbol x = F.dropSym 2 $ GM.simplesymbol x + mkSymbol x + | Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x) + | otherwise = F.dropSym 2 $ GM.simplesymbol x -- res = dcpTyRes dcp clsTvs = dcpFreeTyVars dcp -- copy/pasted from Bare/Class.hs From 3f801869a73d673b4749daf9e41aa06a93688bd0 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 23 Feb 2020 12:41:40 -0500 Subject: [PATCH 24/38] add unfolding of dfuns --- src/Language/Haskell/Liquid/Bare.hs | 42 ++-- src/Language/Haskell/Liquid/Bare/DataType.hs | 10 +- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 195 +++++++++++++----- src/Language/Haskell/Liquid/GHC/API.hs | 1 + src/Language/Haskell/Liquid/Transforms/ANF.hs | 10 +- .../Haskell/Liquid/Transforms/InlineAux.hs | 21 +- 6 files changed, 209 insertions(+), 70 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 5079e458cf..f9c0d3fc36 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -137,7 +137,7 @@ ghcSpecEnv sp = fromListSEnv binds makeGhcSpec0 :: Config -> GhcSrc -> LogicMap -> [(ModName, Ms.BareSpec)] -> Ghc.Ghc GhcSpec ------------------------------------------------------------------------------------- makeGhcSpec0 cfg src lmap mspecsNoClass = do - tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg + tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg simplifier let tyi = Bare.tcTyConMap tycEnv sigEnv = makeSigEnv embs tyi (gsExports src) rtEnv lSpec1 = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 @@ -145,8 +145,8 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do specs = M.insert name mySpec iSpecs2 measEnv = makeMeasEnv env tycEnv sigEnv specs sig = makeSpecSig cfg name specs env sigEnv tycEnv measEnv (giCbs src) - auxSig <- makeClassAuxTypes (fmap fst.elaborateSpecType coreToLg) datacons instMethods - elaboratedSig <- elaborateSig sig auxSig + auxSig <- makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods + elaboratedSig <- elaborateSig sig (F.notracepp "auxSig" auxSig) let myRTE = myRTEnv src env sigEnv rtEnv qual = makeSpecQual cfg env tycEnv measEnv rtEnv specs sData = makeSpecData src env sigEnv measEnv elaboratedSig specs @@ -174,6 +174,8 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do } where -- build up spec components + simplifier :: Ghc.CoreExpr -> Ghc.Ghc Ghc.CoreExpr + simplifier = buildSimplifier (giCbs src) coreToLg e = case CoreToLogic.runToLogic embs @@ -186,9 +188,11 @@ makeGhcSpec0 cfg src lmap mspecsNoClass = do elaborateSig si auxsig = do tySigs <- - forM (gsTySigs si) $ \(x, t) -> do - t' <- traverse (elaborateSpecType coreToLg) t - pure (x, fst <$> t') + forM (gsTySigs si) $ \(x, t) -> + if Ghc.nameModule (Ghc.getName x) == Ghc.gHC_REAL then + pure (x, t) + else do t' <- traverse (elaborateSpecType coreToLg simplifier) t + pure (x, t') -- things like len breaks the code -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do -- t' <- traverse (elaborateSpecType (pure ()) coreToLg) t @@ -242,7 +246,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = let headlessSig = case L.lookup (mkSymbol method) yts of Nothing -> - impossible Nothing ("makeClassAuxTypesOne : not reachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts) + impossible Nothing ("makeClassAuxTypesOne : unreachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts) Just sig -> sig fullSig = mkArrow @@ -253,7 +257,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = subst (zip clsTvs isSpecTys) $ headlessSig elaboratedSig <- elab fullSig - let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) elaboratedSig + let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig) pure (method, F.dummyLoc retSig) -- is used as a shorthand for instance, following the convention of the Ghc api @@ -261,7 +265,7 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = -- (Monoid.mappend -> $cmappend##Int, ...) -- core rewriting mark2: do the same thing except they don't have to be symbols -- YL: poorly written. use a comprehension instead of assuming - methodsSet = M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) + methodsSet = F.tracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) -- core rewriting mark1: dfunId dfunSym = F.symbol $ Ghc.instanceDFunId inst (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst @@ -274,7 +278,8 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = Ghc.classAllSelIds (Ghc.is_cls inst) yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp] mkSymbol x - | Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x) + -- | "$cp" `F.isPrefixOfSym` F.symbol x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x) + | F.notracepp ("isDictonaryId:" ++ GM.showPpr x) $ Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x) | otherwise = F.dropSym 2 $ GM.simplesymbol x -- res = dcpTyRes dcp clsTvs = dcpFreeTyVars dcp @@ -319,7 +324,7 @@ compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, inst mempty { dataDecls = clsDecls , reflects = - -- F.tracepp "reflects " $ + F.notracepp "reflects " $ S.fromList (fmap (fmap GM.dropModuleNames . @@ -349,16 +354,22 @@ compileClasses src env (name, spec) rest = (spec {sigs = sigs'} <> clsSpec, inst Just vs -> Just (sig : vs) methods = [GM.namedLocSymbol x | (_, xs) <- instmethods, x <- xs] -- instance methods + + mkSymbol x + | Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x) + | otherwise = F.dropSym 2 $ GM.simplesymbol x + instmethods :: [(Ghc.ClsInst, [Ghc.Var])] instmethods = [ (inst, ms) - | (inst, _) <- instClss + | (inst, cls) <- instClss + , let selIds = GM.dropModuleNames . F.symbol <$> Ghc.classAllSelIds cls , (_, e) <- Mb.maybeToList (GM.findVarDefMethod (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst) (giCbs src)) - , let ms = filter GM.isMethod (freeVars mempty e) + , let ms = filter (\x -> GM.isMethod x && elem (mkSymbol x) selIds) (freeVars mempty e) ] instClss :: [(Ghc.ClsInst, Ghc.Class)] instClss = @@ -1058,10 +1069,11 @@ makeTycEnv1 :: -> Bare.Env -> (Bare.TycEnv, [Located DataConP]) -> (Ghc.CoreExpr -> F.Expr) + -> (Ghc.CoreExpr -> Ghc.Ghc Ghc.CoreExpr) -> Ghc.Ghc Bare.TycEnv -makeTycEnv1 myName env (tycEnv, datacons) coreToLg = do +makeTycEnv1 myName env (tycEnv, datacons) coreToLg simplifier = do -- fst for selector generation, snd for dataconsig generation - lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg) + lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg simplifier) let recSelectors = Bare.makeRecordSelectorSigs env myName (dcs ++ (fmap . fmap) snd lclassdcs) pure $ tycEnv {Bare.tcSelVars = recSelectors, Bare.tcDataCons = F.val <$> ((fmap . fmap) fst lclassdcs ++ dcs )} diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index fe1b191cd4..32bf8a8c8a 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -478,11 +478,11 @@ classDeclToDataDecl env m rcls = DataDecl -- -- (yts, ot) = qualifyDataCtor (not isGadt) name dLoc (zip ) -- dLoc = F.Loc _loc_beg _loc_end -elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> DataConP -> Ghc.Ghc (DataConP , DataConP) -elaborateClassDcp coreToLg dcp = do - t' <- forM fts $ elaborateSpecType coreToLg - let ts' = F.tracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> (fst <$> t') - pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs (fst <$> t'))}) +elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> (Ghc.CoreExpr -> Ghc.Ghc Ghc.CoreExpr) -> DataConP -> Ghc.Ghc (DataConP , DataConP) +elaborateClassDcp coreToLg simplifier dcp = do + t' <- forM fts $ elaborateSpecType coreToLg simplifier + let ts' = F.notracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> t' + pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs t')}) where resTy = dcpTyRes dcp dc = dcpCon dcp diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index cf47b18b8d..20bddc6175 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -9,12 +9,14 @@ module Language.Haskell.Liquid.Bare.Elaborate ( fixExprToHsExpr , elaborateSpecType + , buildSimplifier ) where import qualified Language.Fixpoint.Types as F import qualified Language.Haskell.Liquid.GHC.Misc as GM +import Language.Haskell.Liquid.Types.Visitors import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType ( ) @@ -25,10 +27,12 @@ import Control.Monad.Free import Data.Functor.Foldable import Data.Char ( isUpper ) import GHC +import GhcPlugins ( isDFunId ) import OccName import FastString import CoreSyn import PrelNames +import qualified Outputable as O import TysWiredIn ( boolTyCon , true_RDR ) @@ -37,6 +41,85 @@ import RdrName import BasicTypes import Data.Default ( def ) import qualified Data.Maybe as Mb +import CoreSubst hiding ( substExpr ) +import SimplCore +import CoreMonad +import CoreFVs ( exprFreeVarsList ) +import VarEnv ( lookupVarEnv + , lookupInScope + ) +import CoreUtils ( mkTick ) + +lookupIdSubstAll :: O.SDoc -> Subst -> Id -> CoreExpr +lookupIdSubstAll doc (Subst in_scope ids _ _) v + | Just e <- lookupVarEnv ids v = e + | Just v' <- lookupInScope in_scope v = Var v' + | otherwise = Var v + -- Vital! See Note [Extending the Subst] + -- | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v + -- $$ ppr in_scope) + +substExprAll :: O.SDoc -> Subst -> CoreExpr -> CoreExpr +substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr + + +subst_expr_all :: O.SDoc -> Subst -> CoreExpr -> CoreExpr +subst_expr_all doc subst expr = go expr + where + go (Var v) = lookupIdSubstAll (doc O.$$ O.text "subst_expr_all") subst v + go (Type ty ) = Type (substTy subst ty) + go (Coercion co ) = Coercion (substCo subst co) + go (Lit lit ) = Lit lit + go (App fun arg ) = App (go fun) (go arg) + go (Tick tickish e ) = mkTick (substTickish subst tickish) (go e) + go (Cast e co ) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (subst_expr_all doc subst' body) + where (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (subst_expr_all doc subst' body) + where (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) + bndr' + (substTy subst ty) + (map (go_alt subst') alts) + where (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr_all doc subst' rhs) + where (subst', bndrs') = substBndrs subst bndrs + + +substLet :: CoreExpr -> CoreExpr +substLet (Lam b body) = Lam b (substLet body) +substLet (Let b body) + | NonRec x e <- b = substLet + (substExprAll O.empty (extendIdSubst emptySubst x e) body) + | otherwise = Let b (substLet body) +substLet e = e + + +buildDictSubst :: CoreProgram -> Subst +buildDictSubst = cata f + where + f Nil = emptySubst + f (Cons b s) + | NonRec x e <- b, isDFunId x || isDictonaryId x = extendIdSubst s x e + | otherwise = s + +buildSimplifier :: CoreProgram -> CoreExpr -> Ghc CoreExpr +buildSimplifier cbs e = do + df <- getDynFlags + liftIO $ simplifyExpr df e' + where + -- fvs = fmap (\x -> (x, getUnique x, isLocalId x)) (freeVars mempty e) + dictSubst = buildDictSubst cbs + e' = substExprAll O.empty dictSubst e -- | Base functor of RType @@ -211,8 +294,6 @@ buildHsExpr res = para $ \case - - canonicalizeDictBinder :: F.Subable a => [F.Symbol] -> (a, [F.Symbol]) -> (a, [F.Symbol]) canonicalizeDictBinder [] (e', bs') = (e', bs') @@ -227,17 +308,25 @@ canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs) elaborateSpecType :: (CoreExpr -> F.Expr) + -> (CoreExpr -> Ghc CoreExpr) -> SpecType - -> Ghc (SpecType, [F.Symbol]) -elaborateSpecType = elaborateSpecType' $ pure () + -> Ghc SpecType +elaborateSpecType coreToLogic simplifier t = do + (t', xs) <- elaborateSpecType' (pure ()) coreToLogic simplifier t + case xs of + _ : _ -> panic + Nothing + "elaborateSpecType: invariant broken. substitution list for dictionary is not completely consumed" + _ -> pure t' elaborateSpecType' :: PartialSpecType - -> (CoreExpr -> F.Expr) + -> (CoreExpr -> F.Expr) -- core to logic + -> (CoreExpr -> Ghc CoreExpr) -> SpecType -> Ghc (SpecType, [F.Symbol]) -- binders for dictionaries -- should have returned Maybe [F.Symbol] -elaborateSpecType' partialTp coreToLogic t = +elaborateSpecType' partialTp coreToLogic simplify t = case F.notracepp "elaborateSpecType'" t of RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do elaborateReft @@ -251,8 +340,8 @@ elaborateSpecType' partialTp coreToLogic t = let partialFunTp = Free (RFunF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType' partialTp coreToLogic tin - (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic tout + (eTin , bs ) <- elaborateSpecType' partialTp coreToLogic simplify tin + (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic simplify tout let buildRFunContTrivial | isClassType tin, dictBinder : bs0' <- bs' = do let (eToutRenamed, canonicalBinders) = @@ -305,8 +394,8 @@ elaborateSpecType' partialTp coreToLogic t = let partialFunTp = Free (RImpFF bind (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType partialTp' = partialTp >> partialFunTp :: PartialSpecType - (eTin , bs ) <- elaborateSpecType' partialTp' coreToLogic tin - (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic tout + (eTin , bs ) <- elaborateSpecType' partialTp' coreToLogic simplify tin + (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic simplify tout let (eToutRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTout, bs') @@ -329,6 +418,7 @@ elaborateSpecType' partialTp coreToLogic t = (eTout, bs) <- elaborateSpecType' (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft)) coreToLogic + simplify tout elaborateReft (ref, RVar tv mempty) @@ -347,6 +437,7 @@ elaborateSpecType' partialTp coreToLogic t = (eTout, bts') <- elaborateSpecType' (partialTp >> Free (RAllPF pvbind (pure ()))) coreToLogic + simplify tout pure (RAllP pvbind eTout, bts') -- pargs not handled for now @@ -360,8 +451,8 @@ elaborateSpecType' partialTp coreToLogic t = pure (RApp tycon args pargs (MkUReft (F.Reft (vv, ee)) p), bs') ) RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do - (eArg, bs ) <- elaborateSpecType' partialTp coreToLogic arg - (eRes, bs') <- elaborateSpecType' partialTp coreToLogic res + (eArg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify arg + (eRes, bs') <- elaborateSpecType' partialTp coreToLogic simplify res let (eResRenamed, canonicalBinders) = canonicalizeDictBinder bs (eRes, bs') elaborateReft @@ -377,13 +468,13 @@ elaborateSpecType' partialTp coreToLogic t = ) -- todo: Existential support RAllE bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType' partialTp coreToLogic ty + (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg + (eTy , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') pure (RAllE bind eAllarg eTyRenamed, canonicalBinders) REx bind allarg ty -> do - (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic allarg - (eTy , bs') <- elaborateSpecType' partialTp coreToLogic ty + (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg + (eTy , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs') pure (REx bind eAllarg eTyRenamed, canonicalBinders) -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard @@ -425,25 +516,33 @@ elaborateSpecType' partialTp coreToLogic t = ( "Ghc is unable to elaborate the expression: " ++ GM.showPpr exprWithTySigs ++ "\n" - ++ GM.showPpr (GM.showSDoc <$> pprErrMsgBagWithLoc (snd msgs)) + ++ GM.showPpr + (GM.showSDoc $ O.hcat (pprErrMsgBagWithLoc (snd msgs))) ) Just eeWithLamsCore -> do + let (_, bs, ee) = GM.notracePpr "collectTyAndValBinders" + $ collectTyAndValBinders (substLet eeWithLamsCore) + ee' <- simplify ee let - eeWithLams = - coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore) - (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams) + eeFix = coreToLogic (GM.notracePpr "eeWithLamsCore" ee') + -- (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams) (dictbs, nondictbs) = - L.partition (F.isPrefixOfSym (F.symbol "$d")) bs' + L.partition (F.isPrefixOfSym (F.symbol "$d")) (fmap F.symbol bs) -- invariant: length nondictbs == length origBinders subst = if length nondictbs == length origBinders - then F.notracepp "SUBST" $ zip (L.reverse nondictbs) origBinders + then F.notracepp "SUBST" $ zip nondictbs origBinders else panic Nothing - "Oops, Ghc gave back more/less binders than I expected" + ( "Oops, Ghc gave back more/less binders than I expected:" + ++ F.showpp nondictbs + ++ " " + ++ F.showpp dictbs + ) ret <- nonTrivialCont - dictbs - ( F.notracepp "nonTrivialContEE" . eliminateEta - $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) ee + (L.reverse dictbs) + (F.notracepp "nonTrivialContEE" . eliminateEta $ F.substa + (\x -> Mb.fromMaybe x (L.lookup x subst)) + eeFix ) -- (GM.dropModuleUnique <$> bs') pure (F.notracepp "result" ret) -- (F.substa ) @@ -494,9 +593,10 @@ fixExprToHsExpr env (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr env e) es fixExprToHsExpr env (F.POr es) = mkHsApp (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "or"))) (nlList $ fixExprToHsExpr env <$> es) -fixExprToHsExpr env (F.PIff e0 e1) = - mkHsApp (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0)) - (fixExprToHsExpr env e1) +fixExprToHsExpr env (F.PIff e0 e1) = mkHsApp + (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0) + ) + (fixExprToHsExpr env e1) fixExprToHsExpr env (F.PNot e) = mkHsApp (nlHsVar not_RDR) (fixExprToHsExpr env e) fixExprToHsExpr env (F.PAtom brel e0 e1) = mkHsApp @@ -576,11 +676,14 @@ specTypeToLHsType = RFunF _ (tin, tin') (_, tout) _ | isClassType tin -> noLoc $ HsQualTy NoExt (noLoc [tin']) tout | otherwise -> nlHsFunTy tin' tout - RImpFF _ (_, tin) (_, tout) _ -> nlHsFunTy tin tout - RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> - noLoc $ HsForAllTy NoExt (userHsTyVarBndrs noSrcSpan [-- getRdrName tv - (symbolToRdrNameNs tvName (F.symbol tv)) - ]) t + RImpFF _ (_, tin) (_, tout) _ -> nlHsFunTy tin tout + RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> noLoc $ HsForAllTy + NoExt + (userHsTyVarBndrs noSrcSpan + [-- getRdrName tv + (symbolToRdrNameNs tvName (F.symbol tv))] + ) + t RAllPF _ (_, ty) -> ty RAppF RTyCon { rtc_tc = tc } ts _ _ -> nlHsTyConApp (getRdrName tc) @@ -604,20 +707,20 @@ specTypeToLHsType = -- we need to do elimination so Pred doesn't contain lambda terms eliminateEta :: F.Expr -> F.Expr eliminateEta (F.EApp e0 e1) = F.EApp (eliminateEta e0) (eliminateEta e1) -eliminateEta (F.ENeg e) = F.ENeg (eliminateEta e) -eliminateEta (F.EBin bop e0 e1) = F.EBin bop (eliminateEta e0) (eliminateEta e1) -eliminateEta (F.EIte e0 e1 e2) = F.EIte (eliminateEta e0) (eliminateEta e1) (eliminateEta e2) +eliminateEta (F.ENeg e ) = F.ENeg (eliminateEta e) +eliminateEta (F.EBin bop e0 e1) = + F.EBin bop (eliminateEta e0) (eliminateEta e1) +eliminateEta (F.EIte e0 e1 e2) = + F.EIte (eliminateEta e0) (eliminateEta e1) (eliminateEta e2) eliminateEta (F.ECst e0 s) = F.ECst (eliminateEta e0) s eliminateEta (F.ELam (x, t) body) - | F.EApp e0 (F.EVar x') <- ebody - , x == x' && notElem x (F.syms e0) - = e0 - | otherwise - = F.ELam (x, t) ebody + | F.EApp e0 (F.EVar x') <- ebody, x == x' && notElem x (F.syms e0) = e0 + | otherwise = F.ELam (x, t) ebody where ebody = eliminateEta body -eliminateEta (F.PAnd es) = F.PAnd (eliminateEta <$> es) -eliminateEta (F.POr es) = F.POr (eliminateEta <$> es) -eliminateEta (F.PNot e) = F.PNot (eliminateEta e) +eliminateEta (F.PAnd es ) = F.PAnd (eliminateEta <$> es) +eliminateEta (F.POr es ) = F.POr (eliminateEta <$> es) +eliminateEta (F.PNot e ) = F.PNot (eliminateEta e) eliminateEta (F.PImp e0 e1) = F.PImp (eliminateEta e0) (eliminateEta e1) -eliminateEta (F.PAtom brel e0 e1) = F.PAtom brel (eliminateEta e0) (eliminateEta e1) +eliminateEta (F.PAtom brel e0 e1) = + F.PAtom brel (eliminateEta e0) (eliminateEta e1) eliminateEta e = e diff --git a/src/Language/Haskell/Liquid/GHC/API.hs b/src/Language/Haskell/Liquid/GHC/API.hs index 1fd99e9351..4700e6ac90 100644 --- a/src/Language/Haskell/Liquid/GHC/API.hs +++ b/src/Language/Haskell/Liquid/GHC/API.hs @@ -3,6 +3,7 @@ module Language.Haskell.Liquid.GHC.API (module Ghc) where import GHC as Ghc +import PrelNames as Ghc (gHC_REAL) import ConLike as Ghc import Var as Ghc import Module as Ghc diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 35fb4ab8a8..792ad5ce96 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -50,7 +50,8 @@ import qualified Language.Haskell.Liquid.GHC.Resugar as Rs import Data.Maybe (fromMaybe) import Data.List (sortBy, (\\)) import Data.Function (on) -import qualified Text.Printf as Printf +import qualified Text.Printf as Printf +import SimplCore -------------------------------------------------------------------------------- -- | A-Normalize a module ------------------------------------------------------ @@ -58,6 +59,8 @@ import qualified Text.Printf as Printf anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind] -------------------------------------------------------------------------------- anormalize cfg hscEnv modGuts = do + rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} + whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" putStrLn $ GM.showCBs untidy (mg_binds modGuts) @@ -66,11 +69,12 @@ anormalize cfg hscEnv modGuts = do putStrLn "***************************** REC CoreBinds ***************************" putStrLn $ GM.showCBs untidy orig_cbs putStrLn "***************************** RWR CoreBinds ***************************" - putStrLn $ GM.showCBs untidy rwr_cbs + putStrLn $ GM.showCBs untidy rwr_simpl_cbs + let act = Misc.concatMapM (normalizeTopBind γ0) rwr_simpl_cbs (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act where err = panic Nothing "Oops, cannot A-Normalize GHC Core!" - act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs + γ0 = emptyAnfEnv cfg rwr_cbs = rewriteBinds cfg orig_cbs orig_cbs = transformRecExpr aux_cbs diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index 6ffd9f2a50..2546a4d755 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Language.Haskell.Liquid.Transforms.InlineAux ( inlineAux ) @@ -25,9 +27,15 @@ import GhcPlugins ( isDFunId ) import qualified Data.HashMap.Strict as M import CoreSubst +import GHC ( isDictonaryId ) +import SimplMonad +import Simplify +import Control.Monad.State + inlineAux :: Module -> CoreProgram -> CoreProgram -inlineAux m cbs = occurAnalysePgm m (const False) (const False) [] (map f cbs) +inlineAux m cbs = inlineDFun + $ occurAnalysePgm m (const False) (const False) [] (map f cbs) where f :: CoreBind -> CoreBind f all@(NonRec x e) @@ -45,6 +53,17 @@ inlineAux m cbs = occurAnalysePgm m (const False) (const False) [] (map f cbs) auxToMethodToAux = mconcat $ fmap (uncurry dfunIdSubst) (grepDFunIds cbs) +inlineDFun :: CoreProgram -> CoreProgram +inlineDFun = flip evalState emptySubst . mapM go + where + go orig@(NonRec x e) + | isDFunId x || isDictonaryId x = do + subst <- get + let e' = substExpr O.empty subst e + modify (\s -> extendIdSubst s x e') + pure (NonRec x e') + | otherwise = pure orig + go recs = pure recs -- grab the dictionaries grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)] From 87f1301d4b30b0b275acce2ab4acffa3854987b4 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 23 Feb 2020 16:34:23 -0500 Subject: [PATCH 25/38] switch to hashmap for substitution --- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 90 +++++++++---------- src/Language/Haskell/Liquid/GHC/Interface.hs | 5 +- 2 files changed, 48 insertions(+), 47 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 20bddc6175..2896e27de5 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -14,6 +14,7 @@ module Language.Haskell.Liquid.Bare.Elaborate where import qualified Language.Fixpoint.Types as F +import Control.Arrow import qualified Language.Haskell.Liquid.GHC.Misc as GM import Language.Haskell.Liquid.Types.Visitors @@ -27,7 +28,9 @@ import Control.Monad.Free import Data.Functor.Foldable import Data.Char ( isUpper ) import GHC -import GhcPlugins ( isDFunId ) +import GhcPlugins ( isDFunId + , gopt_set + ) import OccName import FastString import CoreSyn @@ -49,73 +52,73 @@ import VarEnv ( lookupVarEnv , lookupInScope ) import CoreUtils ( mkTick ) +import qualified Data.HashMap.Strict as M -lookupIdSubstAll :: O.SDoc -> Subst -> Id -> CoreExpr -lookupIdSubstAll doc (Subst in_scope ids _ _) v - | Just e <- lookupVarEnv ids v = e - | Just v' <- lookupInScope in_scope v = Var v' +lookupIdSubstAll :: O.SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr +lookupIdSubstAll doc env v + | Just e <- M.lookup v env = e | otherwise = Var v -- Vital! See Note [Extending the Subst] -- | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v -- $$ ppr in_scope) -substExprAll :: O.SDoc -> Subst -> CoreExpr -> CoreExpr +substExprAll :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr -subst_expr_all :: O.SDoc -> Subst -> CoreExpr -> CoreExpr +subst_expr_all :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr subst_expr_all doc subst expr = go expr where go (Var v) = lookupIdSubstAll (doc O.$$ O.text "subst_expr_all") subst v - go (Type ty ) = Type (substTy subst ty) - go (Coercion co ) = Coercion (substCo subst co) + go (Type ty ) = Type ty + go (Coercion co ) = Coercion co go (Lit lit ) = Lit lit go (App fun arg ) = App (go fun) (go arg) - go (Tick tickish e ) = mkTick (substTickish subst tickish) (go e) - go (Cast e co ) = Cast (go e) (substCo subst co) + go (Tick tickish e ) = Tick tickish (go e) + go (Cast e co ) = Cast (go e) co -- Do not optimise even identity coercions -- Reason: substitution applies to the LHS of RULES, and -- if you "optimise" an identity coercion, you may -- lose a binder. We optimise the LHS of rules at -- construction time - go (Lam bndr body) = Lam bndr' (subst_expr_all doc subst' body) - where (subst', bndr') = substBndr subst bndr + go (Lam bndr body) = Lam bndr (subst_expr_all doc subst body) - go (Let bind body) = Let bind' (subst_expr_all doc subst' body) - where (subst', bind') = substBind subst bind + go (Let bind body) = Let (mapBnd go bind) (subst_expr_all doc subst body) go (Case scrut bndr ty alts) = Case (go scrut) - bndr' - (substTy subst ty) - (map (go_alt subst') alts) - where (subst', bndr') = substBndr subst bndr + bndr + ty + (map (go_alt subst) alts) + + go_alt subst (con, bndrs, rhs) = (con, bndrs, subst_expr_all doc subst rhs) - go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr_all doc subst' rhs) - where (subst', bndrs') = substBndrs subst bndrs +mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b +mapBnd f (NonRec b e) = NonRec b (f e) +mapBnd f (Rec bs ) = Rec (map (second f) bs) -substLet :: CoreExpr -> CoreExpr -substLet (Lam b body) = Lam b (substLet body) -substLet (Let b body) - | NonRec x e <- b = substLet - (substExprAll O.empty (extendIdSubst emptySubst x e) body) - | otherwise = Let b (substLet body) -substLet e = e +-- substLet :: CoreExpr -> CoreExpr +-- substLet (Lam b body) = Lam b (substLet body) +-- substLet (Let b body) +-- | NonRec x e <- b = substLet +-- (substExprAll O.empty (extendIdSubst emptySubst x e) body) +-- | otherwise = Let b (substLet body) +-- substLet e = e -buildDictSubst :: CoreProgram -> Subst +buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr buildDictSubst = cata f where - f Nil = emptySubst + f Nil = M.empty f (Cons b s) - | NonRec x e <- b, isDFunId x || isDictonaryId x = extendIdSubst s x e + | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s | otherwise = s buildSimplifier :: CoreProgram -> CoreExpr -> Ghc CoreExpr buildSimplifier cbs e = do df <- getDynFlags - liftIO $ simplifyExpr df e' + liftIO $ simplifyExpr (df `gopt_set` Opt_SuppressUnfoldings) e' where -- fvs = fmap (\x -> (x, getUnique x, isLocalId x)) (freeVars mempty e) dictSubst = buildDictSubst cbs @@ -520,29 +523,24 @@ elaborateSpecType' partialTp coreToLogic simplify t = (GM.showSDoc $ O.hcat (pprErrMsgBagWithLoc (snd msgs))) ) Just eeWithLamsCore -> do - let (_, bs, ee) = GM.notracePpr "collectTyAndValBinders" - $ collectTyAndValBinders (substLet eeWithLamsCore) - ee' <- simplify ee + eeWithLamsCore' <- simplify eeWithLamsCore let - eeFix = coreToLogic (GM.notracePpr "eeWithLamsCore" ee') - -- (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams) + eeWithLams = + coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore') + (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams) (dictbs, nondictbs) = - L.partition (F.isPrefixOfSym (F.symbol "$d")) (fmap F.symbol bs) + L.partition (F.isPrefixOfSym (F.symbol "$d")) bs' -- invariant: length nondictbs == length origBinders subst = if length nondictbs == length origBinders - then F.notracepp "SUBST" $ zip nondictbs origBinders + then F.notracepp "SUBST" $ zip (L.reverse nondictbs) origBinders else panic Nothing - ( "Oops, Ghc gave back more/less binders than I expected:" - ++ F.showpp nondictbs - ++ " " - ++ F.showpp dictbs - ) + "Oops, Ghc gave back more/less binders than I expected" ret <- nonTrivialCont - (L.reverse dictbs) + dictbs (F.notracepp "nonTrivialContEE" . eliminateEta $ F.substa (\x -> Mb.fromMaybe x (L.lookup x subst)) - eeFix + ee ) -- (GM.dropModuleUnique <$> bs') pure (F.notracepp "result" ret) -- (F.substa ) diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 9419473ab5..29dfa3f491 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -217,9 +217,12 @@ configureDynFlags cfg tmp = do , objectDir = Just tmp , hiDir = Just tmp , stubDir = Just tmp + -- , optLevel = 0 + , ufCreationThreshold = 0 } `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_PIC `gopt_set` Opt_DeferTypedHoles + `gopt_set` Opt_SuppressUnfoldings `xopt_set` MagicHash `xopt_set` DeriveGeneric `xopt_set` StandaloneDeriving @@ -450,7 +453,7 @@ processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = d "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}" execOptions void $ execStmt - "let {infix 4 ==; _ == _ = undefined}" + "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}" execOptions void $ execStmt "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}" From c01f5044c1c02bed9cb7624748d5fc8269a12826 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 23 Feb 2020 19:48:59 -0500 Subject: [PATCH 26/38] inline less aggressively --- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 17 ++--- .../Haskell/Liquid/Transforms/InlineAux.hs | 68 ++++++++++++++++--- 2 files changed, 66 insertions(+), 19 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 2896e27de5..0adc249770 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -112,17 +112,18 @@ buildDictSubst = cata f where f Nil = M.empty f (Cons b s) - | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s + | NonRec x e <- b, isDFunId x -- || isDictonaryId x + = M.insert x e s | otherwise = s buildSimplifier :: CoreProgram -> CoreExpr -> Ghc CoreExpr -buildSimplifier cbs e = do - df <- getDynFlags - liftIO $ simplifyExpr (df `gopt_set` Opt_SuppressUnfoldings) e' - where - -- fvs = fmap (\x -> (x, getUnique x, isLocalId x)) (freeVars mempty e) - dictSubst = buildDictSubst cbs - e' = substExprAll O.empty dictSubst e +buildSimplifier cbs e = pure e-- do + -- df <- getDynFlags + -- liftIO $ simplifyExpr (df `gopt_set` Opt_SuppressUnfoldings) e' + -- where + -- -- fvs = fmap (\x -> (x, getUnique x, isLocalId x)) (freeVars mempty e) + -- dictSubst = buildDictSubst cbs + -- e' = substExprAll O.empty dictSubst e -- | Base functor of RType diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index 2546a4d755..8d9f5825bd 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -2,12 +2,12 @@ module Language.Haskell.Liquid.Transforms.InlineAux ( inlineAux + , inlineDFun ) where import CoreSyn import qualified Outputable as O - ( empty ) import Control.Arrow ( second ) import OccurAnal ( occurAnalysePgm ) import qualified Language.Haskell.Liquid.GHC.Misc @@ -31,11 +31,20 @@ import GHC ( isDictonaryId ) import SimplMonad import Simplify import Control.Monad.State +import Data.Functor.Foldable + +buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr +buildDictSubst = cata f + where + f Nil = M.empty + f (Cons b s) + | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s + | otherwise = s inlineAux :: Module -> CoreProgram -> CoreProgram -inlineAux m cbs = inlineDFun - $ occurAnalysePgm m (const False) (const False) [] (map f cbs) +inlineAux m cbs = inlineDFun $ + occurAnalysePgm m (const False) (const False) [] (map f cbs) where f :: CoreBind -> CoreBind f all@(NonRec x e) @@ -54,16 +63,53 @@ inlineAux m cbs = inlineDFun inlineDFun :: CoreProgram -> CoreProgram -inlineDFun = flip evalState emptySubst . mapM go +inlineDFun cbs = map go cbs where go orig@(NonRec x e) - | isDFunId x || isDictonaryId x = do - subst <- get - let e' = substExpr O.empty subst e - modify (\s -> extendIdSubst s x e') - pure (NonRec x e') - | otherwise = pure orig - go recs = pure recs + | isDFunId x = NonRec x (-- substExprAll O.empty subst $ + substExprAll O.empty subst e) + | otherwise = orig + go recs = recs + subst = buildDictSubst cbs + + +lookupIdSubstAll :: O.SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr +lookupIdSubstAll doc env v | Just e <- M.lookup v env = e + | otherwise = Var v + -- Vital! See Note [Extending the Subst] + -- | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v + -- $$ ppr in_scope) + +substExprAll :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr +substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr + + +subst_expr_all :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr +subst_expr_all doc subst expr = go expr + where + go (Var v) = lookupIdSubstAll (doc O.$$ O.text "subst_expr_all") subst v + go (Type ty ) = Type ty + go (Coercion co ) = Coercion co + go (Lit lit ) = Lit lit + go (App fun arg ) = App (go fun) (go arg) + go (Tick tickish e ) = Tick tickish (go e) + go (Cast e co ) = Cast (go e) co + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr (subst_expr_all doc subst body) + + go (Let bind body) = Let (mapBnd go bind) (subst_expr_all doc subst body) + + go (Case scrut bndr ty alts) = + Case (go scrut) bndr ty (map (go_alt subst) alts) + + go_alt subst (con, bndrs, rhs) = (con, bndrs, subst_expr_all doc subst rhs) + + -- grab the dictionaries grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)] From 1ab1d57514dfc0b14dceaa8111893ec89ff84b5d Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 24 Feb 2020 15:44:12 -0500 Subject: [PATCH 27/38] commenting out inlineDFun. strengthen selector signatures --- src/Language/Haskell/Liquid/Bare/DataType.hs | 40 +++++++++++++++++-- src/Language/Haskell/Liquid/Transforms/ANF.hs | 4 +- .../Haskell/Liquid/Transforms/InlineAux.hs | 40 ++++++++++++------- 3 files changed, 65 insertions(+), 19 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 32bf8a8c8a..abffaa12aa 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -43,6 +43,7 @@ import Control.Monad -- import qualified Language.Fixpoint.Types.Visitor as V import qualified Language.Fixpoint.Types as F +import Control.Monad.Reader import qualified Language.Haskell.Liquid.GHC.Misc as GM import qualified Language.Haskell.Liquid.GHC.API as Ghc import Language.Haskell.Liquid.Types.PredType (dataConPSpecType) @@ -477,7 +478,8 @@ classDeclToDataDecl env m rcls = DataDecl -- -- don't need this step -- -- (yts, ot) = qualifyDataCtor (not isGadt) name dLoc (zip ) -- dLoc = F.Loc _loc_beg _loc_end - + + elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> (Ghc.CoreExpr -> Ghc.Ghc Ghc.CoreExpr) -> DataConP -> Ghc.Ghc (DataConP , DataConP) elaborateClassDcp coreToLg simplifier dcp = do t' <- forM fts $ elaborateSpecType coreToLg simplifier @@ -503,7 +505,7 @@ elaborateClassDcp coreToLg simplifier dcp = do strengthenTy x t = mkUnivs tvs pvs (RFun z cls (t' `RT.strengthen` mt) r) where (tvs, pvs, (RFun z cls t' r)) = bkUniv t vv = rTypeValueVar t' - mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z))) + mt = F.tracepp ("strengthening:" ++ F.showpp x ++ " " ++ F.showpp z) $ RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z))) substClassOpBinding :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr @@ -837,13 +839,45 @@ checkRecordSelectorSigs vts = [ (v, take1 v ts) | (v, ts) <- Misc.groupList vts (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error) _ -> impossible Nothing "checkRecordSelectorSigs" + +-- The type passed in must have full type signature (forall a. Semigroup a => ... ) +strengthenClassSel :: Ghc.Var -> LocSpecType -> LocSpecType +strengthenClassSel v lt = lt {val = t} + where t = runReader (go (F.val lt)) (1,[]) + s = GM.namedLocSymbol v + extend :: F.Symbol -> (Int, [F.Symbol]) -> (Int, [F.Symbol]) + extend x (i, xs) = (i + 1, x:xs) + go :: SpecType -> Reader (Int, [F.Symbol]) SpecType + go (RAllT a t r) = RAllT a <$> go t <*> pure r + go (RAllP p t) = RAllP p <$> go t + go (RFun x tx t r) | isEmbeddedClass tx = + RFun <$> pure x <*> pure tx <*> go t <*> pure r + go (RFun x tx t r) = do + x' <- unDummy x <$> reader fst + r' <- singletonApp s <$> (L.reverse <$> reader snd) + RFun x' tx <$> local (extend x') (go t) <*> pure (F.meet r r') + go t = RT.strengthen t . singletonApp s . L.reverse <$> reader snd + +singletonApp :: F.Symbolic a => F.LocSymbol -> [a] -> UReft F.Reft +singletonApp s ys = MkUReft r mempty + where + r = F.exprReft (F.mkEApp s (F.eVar <$> ys)) + + +-- stolen from Axiom.hs +unDummy :: F.Symbol -> Int -> F.Symbol +unDummy x i + | x /= F.dummySymbol = x + | otherwise = F.symbol ("_cls_lq" ++ show i) + + makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var, LocSpecType)] makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne where makeOne (Loc l l' dcp) | Just cls <- maybe_cls = let cfs = Ghc.classAllSelIds cls in - [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)] + F.tracepp "classSelectors" $ fmap ((,) <$> fst <*> uncurry strengthenClassSel) [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)] | null fls -- no field labels || any (isFunTy . snd) args && not (higherOrderFlag env) -- OR function-valued fields || dcpIsGadt dcp -- OR GADT style datcon diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 792ad5ce96..f20b10f346 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -59,7 +59,9 @@ import SimplCore anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind] -------------------------------------------------------------------------------- anormalize cfg hscEnv modGuts = do - rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} + let df = hsc_dflags hscEnv + rwr_simpl_cbs = rwr_cbs + -- rwr_simpl_cbs <- inlineDFun df rwr_cbs whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index 8d9f5825bd..ed3da83b48 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -7,7 +7,9 @@ module Language.Haskell.Liquid.Transforms.InlineAux where import CoreSyn +import DynFlags import qualified Outputable as O +import MkCore import Control.Arrow ( second ) import OccurAnal ( occurAnalysePgm ) import qualified Language.Haskell.Liquid.GHC.Misc @@ -18,6 +20,7 @@ import CoreFVs ( exprFreeVarsList ) import InstEnv import TcType ( tcSplitDFunTy ) import GhcPlugins ( isDFunId + , exprType , OccName , Module , occNameString @@ -29,21 +32,21 @@ import qualified Data.HashMap.Strict as M import CoreSubst import GHC ( isDictonaryId ) import SimplMonad -import Simplify +import SimplCore import Control.Monad.State -import Data.Functor.Foldable +import Data.Functor.Foldable buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr buildDictSubst = cata f where f Nil = M.empty - f (Cons b s) - | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s - | otherwise = s + f (Cons b s) | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s + | otherwise = s inlineAux :: Module -> CoreProgram -> CoreProgram -inlineAux m cbs = inlineDFun $ +inlineAux m cbs = -- inlineDFun + -- $ occurAnalysePgm m (const False) (const False) [] (map f cbs) where f :: CoreBind -> CoreBind @@ -62,15 +65,22 @@ inlineAux m cbs = inlineDFun $ auxToMethodToAux = mconcat $ fmap (uncurry dfunIdSubst) (grepDFunIds cbs) -inlineDFun :: CoreProgram -> CoreProgram -inlineDFun cbs = map go cbs - where - go orig@(NonRec x e) - | isDFunId x = NonRec x (-- substExprAll O.empty subst $ - substExprAll O.empty subst e) - | otherwise = orig - go recs = recs - subst = buildDictSubst cbs +inlineDFun :: DynFlags -> CoreProgram -> IO CoreProgram +inlineDFun df cbs = pure cbs-- mapM go cbs + -- where + -- go orig@(NonRec x e) | isDFunId x = do + -- -- e''' <- simplifyExpr df e'' + -- let newBody = mkCoreApps (GM.tracePpr ("substituted type:" ++ GM.showPpr (exprType (mkCoreApps e' binders))) e') (fmap Var binders) + -- bind = NonRec (mkWildValBinder (exprType newBody)) newBody + -- pure $ NonRec x (mkLet bind e) + -- | otherwise = pure orig + -- where + -- -- wcBinder = mkWildValBinder t + -- (binders, _) = GM.tracePpr "collectBinders"$ collectBinders e + -- e' = substExprAll O.empty subst e + -- go recs = pure recs + -- subst = buildDictSubst cbs + lookupIdSubstAll :: O.SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr From e70a61560dd8fdda1d04dba3636cf5043193f825 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 26 Feb 2020 19:54:48 -0500 Subject: [PATCH 28/38] update submodule --- liquid-fixpoint | 2 +- src/Language/Haskell/Liquid/Transforms/ANF.hs | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/liquid-fixpoint b/liquid-fixpoint index 1876aa6b4c..71ad8e4b78 160000 --- a/liquid-fixpoint +++ b/liquid-fixpoint @@ -1 +1 @@ -Subproject commit 1876aa6b4cce989224994795de23d3bf370ff169 +Subproject commit 71ad8e4b78a2e2bf5c204638be0876f64e95e011 diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index f20b10f346..853bafc7b9 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -60,8 +60,9 @@ anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind] -------------------------------------------------------------------------------- anormalize cfg hscEnv modGuts = do let df = hsc_dflags hscEnv - rwr_simpl_cbs = rwr_cbs - -- rwr_simpl_cbs <- inlineDFun df rwr_cbs + -- rwr_simpl_cbs = rwr_cbs + -- inlineDFun df rwr_cbs + -- rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" @@ -71,8 +72,8 @@ anormalize cfg hscEnv modGuts = do putStrLn "***************************** REC CoreBinds ***************************" putStrLn $ GM.showCBs untidy orig_cbs putStrLn "***************************** RWR CoreBinds ***************************" - putStrLn $ GM.showCBs untidy rwr_simpl_cbs - let act = Misc.concatMapM (normalizeTopBind γ0) rwr_simpl_cbs + putStrLn $ GM.showCBs untidy rwr_cbs + let act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act where err = panic Nothing "Oops, cannot A-Normalize GHC Core!" From 9cf44f295da797c1cf0500fa4e44d45e584ef994 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 27 Feb 2020 19:07:04 -0500 Subject: [PATCH 29/38] add coherence obligation generator --- src/Language/Haskell/Liquid/GHC/Misc.hs | 43 ++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index b018fd53cd..ee47139b25 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -16,17 +17,20 @@ module Language.Haskell.Liquid.GHC.Misc where -import Class (classKey) +import Class (classKey, classSCSelIds, classBigSig) import Data.String import qualified Data.List as L import Inst import GhcMonad import DsMonad +import Control.Monad.State (evalState, modify, get) import DsExpr import RnExpr import TcRnMonad +import qualified Data.Map.Strict as OM import TcExpr import TcSimplify +import GhcPlugins (eqType, nonDetCmpType, getClassPredTys, piResultTys, mkClassPred) import TcHsSyn import TcEvidence import PrelNames (fractionalClassKeys, itName, ordClassKey, numericClassKeys, eqClassKey) @@ -979,3 +983,40 @@ elabRnExpr hsc_env mode rdr_expr = TM_Inst -> (True, NoRestrictions, id) TM_NoInst -> (False, NoRestrictions, id) TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +newtype HashableType = HashableType {getHType :: Type} + +instance Eq HashableType where + x == y = eqType (getHType x) (getHType y) + +instance Ord HashableType where + compare x y = nonDetCmpType (getHType x) (getHType y) + +instance Outputable HashableType where + ppr = ppr . getHType + + +canonSelectorChains :: PredType -> OM.Map HashableType [Id] +canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs) + where + (cls, ts) = getClassPredTys t + scIdTys = classSCSelIds cls + ys = fmap (\d -> (d, piResultTys (idType d) (ts ++ [t]))) scIdTys + zs = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys + xs = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys + + +buildCoherenceOblig :: Class -> [[([Id], [Id])]] +buildCoherenceOblig cls = evalState (mapM f xs) mempty + where + (ts, _, selIds, _) = classBigSig cls + tts = mkTyVarTy <$> ts + t = mkClassPred cls tts + ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds + xs = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys + f tid = do + ctid' <- get + modify (flip (OM.unionWith const) tid) + pure . OM.elems $ OM.intersectionWith (,) ctid' tid + + From e70f9dd546027eb756293d50ba86cd9d497b8f3e Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 27 Feb 2020 20:47:11 -0500 Subject: [PATCH 30/38] add coherence proof obligatoin --- src/Language/Haskell/Liquid/Bare/DataType.hs | 24 ++++++++++++++++---- src/Language/Haskell/Liquid/GHC/Misc.hs | 16 ++++++++++--- 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index abffaa12aa..32e3e875e7 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -482,10 +482,23 @@ classDeclToDataDecl env m rcls = DataDecl elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> (Ghc.CoreExpr -> Ghc.Ghc Ghc.CoreExpr) -> DataConP -> Ghc.Ghc (DataConP , DataConP) elaborateClassDcp coreToLg simplifier dcp = do - t' <- forM fts $ elaborateSpecType coreToLg simplifier + t' <- flip (zipWith addCoherenceOblig) prefts <$> forM fts (elaborateSpecType coreToLg simplifier) let ts' = F.notracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> t' - pure (F.tracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs t')}) + pure (F.tracepp "elaborateClassDcp" $ + dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, + dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs t')}) where + addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType + addCoherenceOblig t Nothing = t + addCoherenceOblig t (Just r) = F.tracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `RT.strengthen` r} + where rrep = toRTypeRep t + res = ty_res rrep + prefts = L.reverse . take (length fts) $ fmap (F.tracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing + preftss = F.tracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) + + -- ugly, should have passed cls as an argument + cls = Mb.fromJust $ Ghc.tyConClass_maybe (Ghc.dataConTyCon dc) + recsel = F.symbol ("lq$recsel" :: String) resTy = dcpTyRes dcp dc = dcpCon dcp tvars = @@ -500,7 +513,7 @@ elaborateClassDcp coreToLg simplifier dcp = do fullTy :: SpecType -> SpecType fullTy t = F.notracepp "fullTy" $ - mkArrow tvars [] [] [(F.symbol dc, F.notracepp "resTy" resTy, mempty)] t + mkArrow tvars [] [] [(recsel{- F.symbol dc-}, F.notracepp "resTy" resTy, mempty)] t strengthenTy :: F.Symbol -> SpecType -> SpecType strengthenTy x t = mkUnivs tvs pvs (RFun z cls (t' `RT.strengthen` mt) r) where (tvs, pvs, (RFun z cls t' r)) = bkUniv t @@ -862,7 +875,10 @@ singletonApp :: F.Symbolic a => F.LocSymbol -> [a] -> UReft F.Reft singletonApp s ys = MkUReft r mempty where r = F.exprReft (F.mkEApp s (F.eVar <$> ys)) - + + +-- singletonAppRes :: F.Symbolic a => Ghc.Var -> [a] -> UReft F.Reft + -- stolen from Axiom.hs unDummy :: F.Symbol -> Int -> F.Symbol diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index ee47139b25..21c673387f 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -734,6 +734,9 @@ isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol isMethod :: Symbolic a => a -> Bool isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol +isSCSel :: Symbolic a => a -> Bool +isSCSel = isPrefixOfSym "$p" . dropModuleNames . symbol + isInternal :: Symbolic a => a -> Bool isInternal = isPrefixOfSym "$" . dropModuleNames . symbol @@ -1005,7 +1008,6 @@ canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs) zs = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys xs = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys - buildCoherenceOblig :: Class -> [[([Id], [Id])]] buildCoherenceOblig cls = evalState (mapM f xs) mempty where @@ -1013,10 +1015,18 @@ buildCoherenceOblig cls = evalState (mapM f xs) mempty tts = mkTyVarTy <$> ts t = mkClassPred cls tts ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds - xs = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys + xs = fmap (\(d, t') -> fmap (d:) (canonSelectorChains t')) ys f tid = do ctid' <- get modify (flip (OM.unionWith const) tid) - pure . OM.elems $ OM.intersectionWith (,) ctid' tid + pure . OM.elems $ OM.intersectionWith (,) ctid' (fmap tail tid) +-- to be zipped onto the super class selectors +coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft +coherenceObligToRef d rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs) + where lhs = L.foldr EApp (F.eVar ds) ps0 + rhs = L.foldr EApp (F.eVar F.vv_) ps1 + ps0 = F.eVar . F.symbol <$> L.reverse rps0 + ps1 = F.eVar . F.symbol <$> L.reverse rps1 + ds = F.symbol d From 569fa17129228fa63f10b48233e4b4f55d1204c8 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 27 Feb 2020 21:29:30 -0500 Subject: [PATCH 31/38] refine cp1,cp2 --- src/Language/Haskell/Liquid/Bare.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index f9c0d3fc36..0ea1a494d5 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -242,7 +242,7 @@ makeClassAuxTypesOne :: -> (F.Located DataConP, Ghc.ClsInst, [Ghc.Var]) -> Ghc.Ghc [(Ghc.Var, LocSpecType)] makeClassAuxTypesOne elab (ldcp, inst, methods) = - forM methods $ \method -> do + forM (zip methods prefts) $ \(method, preft) -> do let headlessSig = case L.lookup (mkSymbol method) yts of Nothing -> @@ -256,13 +256,21 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = [(F.dummySymbol, pty, mempty) | pty <- isPredSpecTys] . subst (zip clsTvs isSpecTys) $ headlessSig - elaboratedSig <- elab fullSig + elaboratedSig <- flip addCoherenceOblig preft <$> elab fullSig let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig) pure (method, F.dummyLoc retSig) -- is used as a shorthand for instance, following the convention of the Ghc api where - -- (Monoid.mappend -> $cmappend##Int, ...) + recsel = F.symbol ("lq$recsel" :: String) + prefts = L.reverse . take (length yts) $ fmap (F.tracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing + preftss = F.tracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) + cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp) + addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType + addCoherenceOblig t Nothing = t + addCoherenceOblig t (Just r) = F.tracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `strengthen` r} + where rrep = toRTypeRep t + res = ty_res rrep -- (Monoid.mappend -> $cmappend##Int, ...) -- core rewriting mark2: do the same thing except they don't have to be symbols -- YL: poorly written. use a comprehension instead of assuming methodsSet = F.tracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) @@ -638,7 +646,7 @@ makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ------------------------------------------------------------------------------------------ makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl { gsLogicMap = lmap - , gsAutoInst = makeAutoInst env name mySpec + , gsAutoInst = F.tracepp "autoInst" $ makeAutoInst env name mySpec , gsImpAxioms = concatMap (Ms.axeqs . snd) (M.toList specs) , gsMyAxioms = F.notracepp "gsMyAxioms" myAxioms , gsReflects = lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects From 1ef13fc965e9efa2597d8b90eae834ed54742fe5 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 27 Feb 2020 21:34:04 -0500 Subject: [PATCH 32/38] clean up trace --- src/Language/Haskell/Liquid/Bare.hs | 10 +++++----- src/Language/Haskell/Liquid/Bare/DataType.hs | 16 ++++++++-------- .../Haskell/Liquid/Transforms/InlineAux.hs | 2 +- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 0ea1a494d5..96dd11a5a6 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -263,17 +263,17 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = -- is used as a shorthand for instance, following the convention of the Ghc api where recsel = F.symbol ("lq$recsel" :: String) - prefts = L.reverse . take (length yts) $ fmap (F.tracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing - preftss = F.tracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) + prefts = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing + preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp) addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType addCoherenceOblig t Nothing = t - addCoherenceOblig t (Just r) = F.tracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `strengthen` r} + addCoherenceOblig t (Just r) = F.notracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `strengthen` r} where rrep = toRTypeRep t res = ty_res rrep -- (Monoid.mappend -> $cmappend##Int, ...) -- core rewriting mark2: do the same thing except they don't have to be symbols -- YL: poorly written. use a comprehension instead of assuming - methodsSet = F.tracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) + methodsSet = F.notracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) -- core rewriting mark1: dfunId dfunSym = F.symbol $ Ghc.instanceDFunId inst (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst @@ -646,7 +646,7 @@ makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ------------------------------------------------------------------------------------------ makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl { gsLogicMap = lmap - , gsAutoInst = F.tracepp "autoInst" $ makeAutoInst env name mySpec + , gsAutoInst = F.notracepp "autoInst" $ makeAutoInst env name mySpec , gsImpAxioms = concatMap (Ms.axeqs . snd) (M.toList specs) , gsMyAxioms = F.notracepp "gsMyAxioms" myAxioms , gsReflects = lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 32e3e875e7..183b135bb5 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -398,7 +398,7 @@ makeClassDataDecl' :: [(Ghc.Class, [(Ghc.Id, LocBareType)])] -> [DataDecl] makeClassDataDecl' = fmap (uncurry classDeclToDataDecl') classDeclToDataDecl' :: Ghc.Class -> [(Ghc.Id, LocBareType)] -> DataDecl -classDeclToDataDecl' cls refinedIds = F.tracepp "classDeclToDataDecl" $ DataDecl +classDeclToDataDecl' cls refinedIds = F.notracepp "classDeclToDataDecl" $ DataDecl { tycName = DnName (F.symbol <$> GM.locNamedThing cls) , tycTyVars = tyVars , tycPVars = [] @@ -484,17 +484,17 @@ elaborateClassDcp :: (Ghc.CoreExpr -> F.Expr) -> (Ghc.CoreExpr -> Ghc.Ghc Ghc.Co elaborateClassDcp coreToLg simplifier dcp = do t' <- flip (zipWith addCoherenceOblig) prefts <$> forM fts (elaborateSpecType coreToLg simplifier) let ts' = F.notracepp "elaboratedMethod" $ elaborateMethod (F.symbol dc) (S.fromList xs) <$> t' - pure (F.tracepp "elaborateClassDcp" $ + pure (F.notracepp "elaborateClassDcp" $ dcp {dcpTyArgs = zip xs (stripPred <$> ts')}, dcp {dcpTyArgs = fmap (\(x,t) -> (x, strengthenTy x t)) (zip xs t')}) where addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType addCoherenceOblig t Nothing = t - addCoherenceOblig t (Just r) = F.tracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `RT.strengthen` r} + addCoherenceOblig t (Just r) = F.notracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `RT.strengthen` r} where rrep = toRTypeRep t res = ty_res rrep - prefts = L.reverse . take (length fts) $ fmap (F.tracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing - preftss = F.tracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) + prefts = L.reverse . take (length fts) $ fmap (F.notracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing + preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) -- ugly, should have passed cls as an argument cls = Mb.fromJust $ Ghc.tyConClass_maybe (Ghc.dataConTyCon dc) @@ -518,7 +518,7 @@ elaborateClassDcp coreToLg simplifier dcp = do strengthenTy x t = mkUnivs tvs pvs (RFun z cls (t' `RT.strengthen` mt) r) where (tvs, pvs, (RFun z cls t' r)) = bkUniv t vv = rTypeValueVar t' - mt = F.tracepp ("strengthening:" ++ F.showpp x ++ " " ++ F.showpp z) $ RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z))) + mt = F.notracepp ("strengthening:" ++ F.showpp x ++ " " ++ F.showpp z) $ RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z))) substClassOpBinding :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr @@ -893,7 +893,7 @@ makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne makeOne (Loc l l' dcp) | Just cls <- maybe_cls = let cfs = Ghc.classAllSelIds cls in - F.tracepp "classSelectors" $ fmap ((,) <$> fst <*> uncurry strengthenClassSel) [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)] + F.notracepp "classSelectors" $ fmap ((,) <$> fst <*> uncurry strengthenClassSel) [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)] | null fls -- no field labels || any (isFunTy . snd) args && not (higherOrderFlag env) -- OR function-valued fields || dcpIsGadt dcp -- OR GADT style datcon @@ -917,7 +917,7 @@ makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne su = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ] args = dcpTyArgs dcp - z = F.tracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel" + z = F.notracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel" res = dropPreds (dcpTyRes dcp) -- FIXME: this is clearly imprecise, but the preds in the DataConP seem diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs index ed3da83b48..aae91717be 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -162,7 +162,7 @@ inlineAuxExpr dfunId methodToAux e = go e , arg : argsNoTy <- dropWhile isTypeArg args , (Var x, argargs) <- collectArgs arg , x == dfunId - = GM.tracePpr ("inlining in" ++ GM.showPpr e) + = GM.notracePpr ("inlining in" ++ GM.showPpr e) $ mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy)) go (App e0 e1) = App (go e0) (go e1) go e = e From 2d2d165dac604651a462b4d377d812dfe4eb1f1f Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 27 Feb 2020 22:22:38 -0500 Subject: [PATCH 33/38] refine cp1, cp2 (the correct way) --- src/Language/Haskell/Liquid/Bare.hs | 25 +++++++++++++++++-------- src/Language/Haskell/Liquid/GHC/Misc.hs | 8 +++++--- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 96dd11a5a6..7aad990204 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -242,29 +242,36 @@ makeClassAuxTypesOne :: -> (F.Located DataConP, Ghc.ClsInst, [Ghc.Var]) -> Ghc.Ghc [(Ghc.Var, LocSpecType)] makeClassAuxTypesOne elab (ldcp, inst, methods) = - forM (zip methods prefts) $ \(method, preft) -> do - let headlessSig = - case L.lookup (mkSymbol method) yts of + forM methods $ \method -> do + let (headlessSig, preft) = + case L.lookup (mkSymbol method) yts' of Nothing -> impossible Nothing ("makeClassAuxTypesOne : unreachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts) Just sig -> sig + -- dict binder will never be changed because we optimized PAnd[] + -- lq0 lq1 ... + ptys = [(F.vv (Just i), pty, mempty) | (i,pty) <- zip [0,1..] isPredSpecTys] fullSig = mkArrow (zip isRTvs (repeat mempty)) [] [] - [(F.dummySymbol, pty, mempty) | pty <- isPredSpecTys] . + ptys . subst (zip clsTvs isSpecTys) $ headlessSig elaboratedSig <- flip addCoherenceOblig preft <$> elab fullSig + let retSig = mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig) pure (method, F.dummyLoc retSig) - -- is used as a shorthand for instance, following the convention of the Ghc api + -- "is" is used as a shorthand for instance, following the convention of the Ghc api where - recsel = F.symbol ("lq$recsel" :: String) + -- recsel = F.symbol ("lq$recsel" :: String) + (_,predTys,_,_) = Ghc.instanceSig inst + dfunApped = F.mkEApp dfunSymL [F.eVar $ F.vv (Just i) | (i,_) <- zip [0,1..] predTys] prefts = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing - preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRef recsel)) (GM.buildCoherenceOblig cls) + preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRefE dfunApped)) (GM.buildCoherenceOblig cls) + yts' = zip (fst <$> yts) (zip (snd <$> yts) prefts) cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp) addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType addCoherenceOblig t Nothing = t @@ -275,7 +282,9 @@ makeClassAuxTypesOne elab (ldcp, inst, methods) = -- YL: poorly written. use a comprehension instead of assuming methodsSet = F.notracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods)) -- core rewriting mark1: dfunId - dfunSym = F.symbol $ Ghc.instanceDFunId inst + -- () + dfunSymL = GM.namedLocSymbol $ Ghc.instanceDFunId inst + dfunSym = F.val dfunSymL (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst isSpecTys = ofType <$> isTys isPredSpecTys = ofType <$> isPredTys diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index 21c673387f..0e8178c873 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -1024,9 +1024,11 @@ buildCoherenceOblig cls = evalState (mapM f xs) mempty -- to be zipped onto the super class selectors coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft -coherenceObligToRef d rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs) - where lhs = L.foldr EApp (F.eVar ds) ps0 +coherenceObligToRef d = coherenceObligToRefE (F.eVar $ F.symbol d) + +coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft +coherenceObligToRefE e rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs) + where lhs = L.foldr EApp e ps0 rhs = L.foldr EApp (F.eVar F.vv_) ps1 ps0 = F.eVar . F.symbol <$> L.reverse rps0 ps1 = F.eVar . F.symbol <$> L.reverse rps1 - ds = F.symbol d From 34026c2fdc35af094c6769f1360310093fc69fb2 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 28 Feb 2020 15:34:39 -0500 Subject: [PATCH 34/38] run the simplifier on core because it magically fixes termination metric --- src/Language/Haskell/Liquid/Transforms/ANF.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 853bafc7b9..266b48ec1d 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -62,7 +62,7 @@ anormalize cfg hscEnv modGuts = do let df = hsc_dflags hscEnv -- rwr_simpl_cbs = rwr_cbs -- inlineDFun df rwr_cbs - -- rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} + rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" @@ -73,7 +73,7 @@ anormalize cfg hscEnv modGuts = do putStrLn $ GM.showCBs untidy orig_cbs putStrLn "***************************** RWR CoreBinds ***************************" putStrLn $ GM.showCBs untidy rwr_cbs - let act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs + let act = Misc.concatMapM (normalizeTopBind γ0) rwr_simpl_cbs (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act where err = panic Nothing "Oops, cannot A-Normalize GHC Core!" From 6b2f7adf51f61d7e0af8d0a57c314f6a0cead381 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 29 Feb 2020 13:30:31 -0500 Subject: [PATCH 35/38] revert back because simplifier breaks fmapStateId' proof --- src/Language/Haskell/Liquid/Transforms/ANF.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 266b48ec1d..853bafc7b9 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -62,7 +62,7 @@ anormalize cfg hscEnv modGuts = do let df = hsc_dflags hscEnv -- rwr_simpl_cbs = rwr_cbs -- inlineDFun df rwr_cbs - rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} + -- rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" @@ -73,7 +73,7 @@ anormalize cfg hscEnv modGuts = do putStrLn $ GM.showCBs untidy orig_cbs putStrLn "***************************** RWR CoreBinds ***************************" putStrLn $ GM.showCBs untidy rwr_cbs - let act = Misc.concatMapM (normalizeTopBind γ0) rwr_simpl_cbs + let act = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act where err = panic Nothing "Oops, cannot A-Normalize GHC Core!" From 61d707df69c5e358d34fafedf65c026b7f5fa554 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 2 Mar 2020 19:05:27 -0500 Subject: [PATCH 36/38] commit everything --- src/Language/Haskell/Liquid/GHC/Interface.hs | 7 +++++-- src/Language/Haskell/Liquid/Transforms/ANF.hs | 8 +++++--- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 29dfa3f491..7a2aed6b7a 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -217,7 +217,7 @@ configureDynFlags cfg tmp = do , objectDir = Just tmp , hiDir = Just tmp , stubDir = Just tmp - -- , optLevel = 0 + , optLevel = 0 , ufCreationThreshold = 0 } `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_PIC @@ -543,7 +543,7 @@ qImports qns = QImports --------------------------------------------------------------------------------------- lookupTyThings :: HscEnv -> TypecheckedModule -> MGIModGuts -> Ghc [(Name, Maybe TyThing)] lookupTyThings hscEnv tcm mg = - forM (mgNames mg) $ \n -> do + forM (mgNames mg ++ instNames mg) $ \n -> do tt1 <- lookupName n tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n tt3 <- modInfoLookupName mi n @@ -583,6 +583,9 @@ _dumpRdrEnv _hscEnv modGuts = do _mgDeps = Ghc.dep_mods . mgi_deps _hscNames = fmap showPpr . Ghc.ic_tythings . Ghc.hsc_IC +instNames :: MGIModGuts -> [Ghc.Name] +instNames = fmap is_dfun_name . join . maybeToList . mgi_cls_inst + mgNames :: MGIModGuts -> [Ghc.Name] mgNames = fmap Ghc.gre_name . Ghc.globalRdrEnvElts . mgi_rdr_env diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs index 853bafc7b9..3a0fb9ed82 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -60,9 +60,14 @@ anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind] -------------------------------------------------------------------------------- anormalize cfg hscEnv modGuts = do let df = hsc_dflags hscEnv + aux_cbs = inlineAux (mg_module modGuts) $ mg_binds modGuts -- rwr_simpl_cbs = rwr_cbs -- inlineDFun df rwr_cbs + + let orig_cbs = transformRecExpr aux_cbs + rwr_cbs = rewriteBinds cfg orig_cbs -- rwr_simpl_cbs <- mg_binds <$> core2core hscEnv modGuts {mg_binds = rwr_cbs} + whenLoud $ do putStrLn "***************************** GHC CoreBinds ***************************" @@ -79,9 +84,6 @@ anormalize cfg hscEnv modGuts = do err = panic Nothing "Oops, cannot A-Normalize GHC Core!" γ0 = emptyAnfEnv cfg - rwr_cbs = rewriteBinds cfg orig_cbs - orig_cbs = transformRecExpr aux_cbs - aux_cbs = inlineAux (mg_module modGuts) $ mg_binds modGuts untidy = UX.untidyCore cfg {- From 1c357288f20d540f18f66017f0c5b70f3dfd18e3 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 14 Mar 2020 15:54:51 -0400 Subject: [PATCH 37/38] fix <=> --- src/Language/Haskell/Liquid/Bare.hs | 1 + src/Language/Haskell/Liquid/Bare/DataType.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs index 7aad990204..b0068f2fb9 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -326,6 +326,7 @@ substAuxMethod dfun methods e = F.notracepp "substAuxMethod" $ go e go (F.POr es) = F.POr (go <$> es) go (F.PNot e) = F.PNot (go e) go (F.PImp e0 e1) = F.PImp (go e0) (go e1) + go (F.PIff e0 e1) = F.PIff (go e0) (go e1) go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1) go e = F.notracepp "LEAF" e diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs index 183b135bb5..cab9b1b8c9 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -544,6 +544,7 @@ substClassOpBinding tcbind dc methods e = F.notracepp "substClassOpBinding" $ go go (F.POr es) = F.POr (go <$> es) go (F.PNot e) = F.PNot (go e) go (F.PImp e0 e1) = F.PImp (go e0) (go e1) + go (F.PIff e0 e1) = F.PIff (go e0) (go e1) go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1) go e = F.notracepp "LEAF" e From 8b7a9ebfac280b2686257c9f19dcd8ca426f815c Mon Sep 17 00:00:00 2001 From: James Parker Date: Tue, 24 Mar 2020 19:38:39 -0400 Subject: [PATCH 38/38] slightly better elaboration error messages --- src/Language/Haskell/Liquid/Bare/Elaborate.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs index 0adc249770..692b8ba5ca 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -520,8 +520,8 @@ elaborateSpecType' partialTp coreToLogic simplify t = ( "Ghc is unable to elaborate the expression: " ++ GM.showPpr exprWithTySigs ++ "\n" - ++ GM.showPpr - (GM.showSDoc $ O.hcat (pprErrMsgBagWithLoc (snd msgs))) + ++ -- GM.showPpr + (GM.showSDoc $ O.sep (pprErrMsgBagWithLoc (snd msgs))) ) Just eeWithLamsCore -> do eeWithLamsCore' <- simplify eeWithLamsCore